Rakka/Wiki/Engine.hs

   1 module Rakka.Wiki.Engine
   2     ( InterpTable
   3     , formatEntirePage
   4     , formatUnexistentPage
   5     , makeDraft
   6     )
   7     where
   8
   9 import           Control.Arrow
  10 import           Control.Arrow.ArrowIO
  11 import           Control.Arrow.ArrowList
  12 import           Data.Encoding
  13 import           Data.Encoding.UTF8
  14 import           Data.Generics
  15 import           Data.Map (Map)
  16 import qualified Data.Map as M
  17 import           Data.Maybe
  18 import           Network.HTTP.Lucu
  19 import           Network.URI
  20 import           Rakka.Page
  21 import           Rakka.Storage
  22 import           Rakka.SystemConfig
  23 import           Rakka.Utils
  24 import           Rakka.Wiki
  25 import           Rakka.Wiki.Parser
  26 import           Rakka.Wiki.Formatter
  27 import           Rakka.Wiki.Interpreter
  28 import           Text.HyperEstraier hiding (getText)
  29 import           Text.ParserCombinators.Parsec
  30 import           Text.XML.HXT.Arrow.Namespace
  31 import           Text.XML.HXT.Arrow.XmlArrow
  32 import           Text.XML.HXT.DOM.TypeDefs
  33
  34
  35 type InterpTable = Map String Interpreter
  36
  37
  38 formatEntirePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  39                     Storage
  40                  -> SystemConfig
  41                  -> InterpTable
  42                  -> a Page XmlTree
  43 formatEntirePage sto sysConf interpTable
  44     = proc page
  45     -> do SiteName   siteName <- getSysConfA sysConf -< ()
  46           BaseURI    baseURI  <- getSysConfA sysConf -< ()
  47           StyleSheet cssName  <- getSysConfA sysConf -< ()
  48
  49           Just pageTitle    <- getPageA sto -< "PageTitle"
  50           Just leftSideBar  <- getPageA sto -< "SideBar/Left"
  51           Just rightSideBar <- getPageA sto -< "SideBar/Right"
  52
  53           tree <- ( eelem "/"
  54                     += ( eelem "page"
  55                          += sattr "site"       siteName
  56                          += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
  57                          += sattr "name"       (pageName page)
  58                          += sattr "type"       (show $ pageType page)
  59                          += ( case pageLanguage page of
  60                                 Just x -> sattr "lang" x
  61                                 _      -> none
  62                             )
  63                          += ( case pageType page of
  64                                 MIMEType "text" "css" _
  65                                     -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
  66                                 _   -> none
  67                             )
  68                          += ( case pageType page of
  69                                 MIMEType "text" "x-rakka" _
  70                                     -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
  71                                 _   -> none
  72                             )
  73                          += sattr "isLocked" (yesOrNo $ pageIsLocked page)
  74                          += sattr "isBoring" (yesOrNo $ pageIsBoring page)
  75                          += sattr "isBinary" (yesOrNo $ pageIsBinary page)
  76                          += sattr "revision" (show $ pageRevision page)
  77                          += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
  78
  79                          += ( case pageSummary page of
  80                                 Nothing -> none
  81                                 Just s  -> eelem "summary" += txt s
  82                             )
  83
  84                          += ( if M.null (pageOtherLang page) then
  85                                   none
  86                               else
  87                                   selem "otherLang"
  88                                             [ eelem "link"
  89                                               += sattr "lang" lang
  90                                               += sattr "page" page
  91                                                   | (lang, page) <- M.toList (pageOtherLang page) ]
  92                             )
  93                          += ( eelem "pageTitle"
  94                               += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
  95                                    >>>
  96                                    formatSubPage sto sysConf interpTable
  97                                  )
  98                             )
  99                          += ( eelem "sideBar"
 100                               += ( eelem "left"
 101                                    += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
 102                                         >>>
 103                                         formatSubPage sto sysConf interpTable
 104                                       )
 105                                  )
 106                               += ( eelem "right"
 107                                    += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
 108                                         >>>
 109                                         formatSubPage sto sysConf interpTable
 110                                       )
 111                                  )
 112                             )
 113                          += ( eelem "body"
 114                               += (constA page >>> formatMainPage sto sysConf interpTable)
 115                             )
 116                          >>>
 117                          uniqueNamespacesFromDeclAndQNames
 118                        )
 119                   ) -<< ()
 120           returnA -< tree
 121
 122
 123 formatUnexistentPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 124                         Storage
 125                      -> SystemConfig
 126                      -> InterpTable
 127                      -> a PageName XmlTree
 128 formatUnexistentPage sto sysConf interpTable
 129     = proc name
 130     -> do SiteName   siteName <- getSysConfA sysConf -< ()
 131           BaseURI    baseURI  <- getSysConfA sysConf -< ()
 132           StyleSheet cssName  <- getSysConfA sysConf -< ()
 133
 134           Just pageTitle    <- getPageA sto -< "PageTitle"
 135           Just leftSideBar  <- getPageA sto -< "SideBar/Left"
 136           Just rightSideBar <- getPageA sto -< "SideBar/Right"
 137
 138           tree <- ( eelem "/"
 139                     += ( eelem "pageNotFound"
 140                          += sattr "site"       siteName
 141                          += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
 142                          += sattr "name"       name
 143
 144                          += ( eelem "pageTitle"
 145                               += ( (constA name &&& constA Nothing &&& constA pageTitle)
 146                                    >>>
 147                                    formatSubPage sto sysConf interpTable
 148                                  )
 149                             )
 150                          += ( eelem "sideBar"
 151                               += ( eelem "left"
 152                                    += ( (constA name &&& constA Nothing &&& constA leftSideBar)
 153                                         >>>
 154                                         formatSubPage sto sysConf interpTable
 155                                       )
 156                                  )
 157                               += ( eelem "right"
 158                                    += ( (constA name &&& constA Nothing &&& constA rightSideBar)
 159                                         >>>
 160                                         formatSubPage sto sysConf interpTable
 161                                       )
 162                                  )
 163                             )
 164                          >>>
 165                          uniqueNamespacesFromDeclAndQNames
 166                        )
 167                   ) -<< ()
 168           returnA -< tree
 169
 170
 171 formatMainPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 172                   Storage
 173                -> SystemConfig
 174                -> InterpTable
 175                -> a Page XmlTree
 176 formatMainPage sto sysConf interpTable
 177     = proc page
 178     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 179           wiki            <- arr2 wikifyPage -< (interpTable, page)
 180           xs              <- interpretCommandsA sto sysConf interpTable
 181                              -< (pageName page, Just (page, wiki), wiki)
 182           formatWikiBlocks -< (baseURI, xs)
 183
 184
 185 formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 186                  Storage
 187               -> SystemConfig
 188               -> InterpTable
 189               -> a (PageName, (Maybe Page, Page)) XmlTree
 190 formatSubPage sto sysConf interpTable
 191     = proc (mainPageName, (mainPage, subPage))
 192     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 193           mainWiki        <- case mainPage of
 194                                Just page
 195                                    -> do wiki <- arr2 wikifyPage -< (interpTable, page)
 196                                          returnA -< Just (page, wiki)
 197                                Nothing
 198                                    -> returnA -< Nothing
 199           subWiki        <- arr2 wikifyPage -< (interpTable, subPage)
 200           xs             <- interpretCommandsA sto sysConf interpTable
 201                             -< (mainPageName, mainWiki, subWiki)
 202           formatWikiBlocks -< (baseURI, xs)
 203
 204
 205 wikifyPage :: InterpTable -> Page -> WikiPage
 206 wikifyPage interpTable page
 207     = case pageType page of
 208         MIMEType "text" "x-rakka" _
 209             -> let source = decodeLazy UTF8 (pageContent page)
 210                    parser = wikiPage tableToFunc
 211                in
 212                  case parse parser "" source of
 213                    Left err -> wikifyParseError err
 214                    Right xs -> xs
 215     where
 216       tableToFunc :: String -> Maybe CommandType
 217       tableToFunc name
 218           = fmap commandType (M.lookup name interpTable)
 219
 220
 221 interpretCommandsA :: (ArrowIO a, ArrowApply a) =>
 222                       Storage
 223                    -> SystemConfig
 224                    -> InterpTable
 225                    -> a (PageName, Maybe (Page, WikiPage), WikiPage) WikiPage
 226 interpretCommandsA sto sysConf interpTable
 227     = proc (name, mainPageAndTree, targetTree)
 228     -> arrIO0 (interpretCommands sto sysConf interpTable name mainPageAndTree targetTree)
 229        -<< ()
 230
 231
 232 interpretCommands :: Storage
 233                   -> SystemConfig
 234                   -> InterpTable
 235                   -> PageName
 236                   -> Maybe (Page, WikiPage)
 237                   -> WikiPage
 238                   -> IO WikiPage
 239 interpretCommands sto sysConf interpTable name mainPageAndTree targetTree
 240     = everywhereM' (mkM interpBlockCmd) targetTree
 241       >>=
 242       everywhereM' (mkM interpInlineCmd)
 243     where
 244       ctx :: InterpreterContext
 245       ctx = InterpreterContext {
 246               ctxPageName   = name
 247             , ctxMainPage   = fmap fst mainPageAndTree
 248             , ctxMainTree   = fmap snd mainPageAndTree
 249             , ctxTargetTree = targetTree
 250             , ctxStorage    = sto
 251             , ctxSysConf    = sysConf
 252             }
 253
 254       interpBlockCmd :: BlockElement -> IO BlockElement
 255       interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
 256       interpBlockCmd others         = return others
 257
 258       interpBlockCmd' :: BlockCommand -> IO BlockElement
 259       interpBlockCmd' cmd
 260           = case M.lookup (bCmdName cmd) interpTable of
 261               Nothing
 262                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 263
 264               Just interp
 265                   -> bciInterpret interp ctx cmd
 266
 267
 268       interpInlineCmd :: InlineElement -> IO InlineElement
 269       interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
 270       interpInlineCmd others          = return others
 271
 272       interpInlineCmd' :: InlineCommand -> IO InlineElement
 273       interpInlineCmd' cmd
 274           = case M.lookup (iCmdName cmd) interpTable of
 275               Nothing
 276                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 277
 278               Just interp
 279                   -> iciInterpret interp ctx cmd
 280
 281
 282 makeDraft :: InterpTable -> Page -> IO Document
 283 makeDraft interpTable page
 284     = do doc <- newDocument
 285
 286          setURI       doc                  $ Just $ mkRakkaURI $ pageName page
 287          setAttribute doc "@title"         $ Just $ pageName page
 288          setAttribute doc "@lang"          $ pageLanguage page
 289          setAttribute doc "@type"          $ Just $ show $ pageType page
 290          setAttribute doc "@mdate"         $ Just $ formatW3CDateTime $ pageLastMod page
 291          setAttribute doc "rakka:isLocked" $ Just $ yesOrNo $ pageIsLocked page
 292          setAttribute doc "rakka:isBoring" $ Just $ yesOrNo $ pageIsBoring page
 293          setAttribute doc "rakka:isBinary" $ Just $ yesOrNo $ pageIsBinary page
 294          setAttribute doc "rakka:revision" $ Just $ show $ pageRevision page
 295
 296          case pageType page of
 297             MIMEType "text" "css" _
 298                 -> setAttribute doc "rakka:isTheme" $ Just $ yesOrNo $ pageIsTheme page
 299             MIMEType "text" "x-rakka" _
 300                 -> setAttribute doc "rakka:isFeed"  $ Just $ yesOrNo $ pageIsFeed page
 301             _   -> return ()
 302
 303          case pageSummary page of
 304            Nothing -> return ()
 305            Just s  -> addHiddenText doc s
 306
 307          -- otherLang はリンク先ページ名を hidden text で入れる。
 308          sequence_ [ addHiddenText doc x
 309                          | (_, x) <- M.toList (pageOtherLang page) ]
 310
 311          -- wikify して興味のある部分を addText する。
 312          let wikiPage = wikifyPage interpTable page
 313          everywhereM' (mkM (addBlockText  doc)) wikiPage
 314          everywhereM' (mkM (addInlineText doc)) wikiPage
 315
 316          return doc
 317     where
 318       addBlockText :: Document -> BlockElement -> IO BlockElement
 319       addBlockText doc b
 320           = do case b of
 321                  Heading _ text
 322                      -> addText doc text
 323                  _   -> return ()
 324                return b
 325
 326       addInlineText :: Document -> InlineElement -> IO InlineElement
 327       addInlineText doc i
 328           = do case i of
 329                  Text text
 330                      -> addText doc text
 331                  PageLink page fragment Nothing
 332                      -> addText doc (fromMaybe "" page ++
 333                                      fromMaybe "" fragment)
 334                  PageLink page fragment (Just text)
 335                      -> do addHiddenText doc (fromMaybe "" page ++
 336                                               fromMaybe "" fragment)
 337                            addText doc text
 338                  ExternalLink uri Nothing
 339                      -> addText doc (uriToString id uri "")
 340                  ExternalLink uri (Just text)
 341                      -> do addHiddenText doc (uriToString id uri "")
 342                            addText doc text
 343                  _   -> return ()
 344                return i
 345
 346
 347 -- Perform monadic transformation in top-down order.
 348 everywhereM' :: Monad m => GenericM m -> GenericM m
 349 everywhereM' f x = f x >>= gmapM (everywhereM' f)
 350
 351
 352 wikifyParseError :: ParseError -> WikiPage
 353 wikifyParseError err
 354     = [Div [("class", "error")]
 355                [ Preformatted [Text (show err)] ]]