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"    , Nothing)
  50           Just leftSideBar  <- getPageA sto -< ("SideBar/Left" , Nothing)
  51           Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing)
  52
  53           tree <- ( eelem "/"
  54                     += ( eelem "page"
  55                          += sattr "site"       siteName
  56                          += sattr "baseURI"    (uriToString id baseURI "")
  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 pageFileName page of
  64                                 Just x -> sattr "fileName" x
  65                                 _      -> none
  66                             )
  67                          += ( case pageType page of
  68                                 MIMEType "text" "css" _
  69                                     -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
  70                                 _   -> none
  71                             )
  72                          += ( case pageType page of
  73                                 MIMEType "text" "x-rakka" _
  74                                     -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
  75                                 _   -> none
  76                             )
  77                          += sattr "isLocked" (yesOrNo $ pageIsLocked page)
  78                          += sattr "isBoring" (yesOrNo $ pageIsBoring page)
  79                          += sattr "isBinary" (yesOrNo $ pageIsBinary page)
  80                          += sattr "revision" (show $ pageRevision page)
  81                          += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
  82
  83                          += ( eelem "styleSheets"
  84                               += ( eelem "styleSheet"
  85                                    += sattr "src" (uriToString id (mkObjectURI baseURI cssName) "")
  86                                  )
  87                             )
  88
  89                          += ( eelem "scripts"
  90                               += ( eelem "script"
  91                                    += sattr "src" (uriToString id (baseURI { uriPath = "/js" }) "")
  92                                  )
  93                             )
  94
  95                          += ( case pageSummary page of
  96                                 Nothing -> none
  97                                 Just s  -> eelem "summary" += txt s
  98                             )
  99
 100                          += ( if M.null (pageOtherLang page) then
 101                                   none
 102                               else
 103                                   selem "otherLang"
 104                                             [ eelem "link"
 105                                               += sattr "lang" lang
 106                                               += sattr "page" page
 107                                                   | (lang, page) <- M.toList (pageOtherLang page) ]
 108                             )
 109                          += ( eelem "pageTitle"
 110                               += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
 111                                    >>>
 112                                    formatSubPage sto sysConf interpTable
 113                                  )
 114                             )
 115                          += ( eelem "sideBar"
 116                               += ( eelem "left"
 117                                    += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
 118                                         >>>
 119                                         formatSubPage sto sysConf interpTable
 120                                       )
 121                                  )
 122                               += ( eelem "right"
 123                                    += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
 124                                         >>>
 125                                         formatSubPage sto sysConf interpTable
 126                                       )
 127                                  )
 128                             )
 129                          += ( eelem "body"
 130                               += (constA page >>> formatMainPage sto sysConf interpTable)
 131                             )
 132                          += (constA page >>> formatSource)
 133                          >>>
 134                          uniqueNamespacesFromDeclAndQNames
 135                        )
 136                   ) -<< ()
 137           returnA -< tree
 138
 139
 140 formatSource :: (ArrowXml a, ArrowChoice a) => a Page XmlTree
 141 formatSource = proc page
 142              -> if pageIsBinary page then
 143                     none -< ()
 144                 else
 145                     let source = decodeLazy UTF8 (pageContent page)
 146                     in
 147                       ( eelem "source" += mkText ) -< source
 148
 149
 150 formatUnexistentPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 151                         Storage
 152                      -> SystemConfig
 153                      -> InterpTable
 154                      -> a PageName XmlTree
 155 formatUnexistentPage sto sysConf interpTable
 156     = proc name
 157     -> do SiteName   siteName <- getSysConfA sysConf -< ()
 158           BaseURI    baseURI  <- getSysConfA sysConf -< ()
 159           StyleSheet cssName  <- getSysConfA sysConf -< ()
 160
 161           Just pageTitle    <- getPageA sto -< ("PageTitle"    , Nothing)
 162           Just leftSideBar  <- getPageA sto -< ("SideBar/Left" , Nothing)
 163           Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing)
 164
 165           tree <- ( eelem "/"
 166                     += ( eelem "pageNotFound"
 167                          += sattr "site"    siteName
 168                          += sattr "baseURI" (uriToString id baseURI "")
 169                          += sattr "name"    name
 170
 171                          += ( eelem "styleSheets"
 172                               += ( eelem "styleSheet"
 173                                    += sattr "src" (uriToString id (mkObjectURI baseURI cssName) "")
 174                                  )
 175                             )
 176
 177                          += ( eelem "scripts"
 178                               += ( eelem "script"
 179                                    += sattr "src" (uriToString id (baseURI { uriPath = "/js" }) "")
 180                                  )
 181                             )
 182
 183                          += ( eelem "pageTitle"
 184                               += ( (constA name &&& constA Nothing &&& constA pageTitle)
 185                                    >>>
 186                                    formatSubPage sto sysConf interpTable
 187                                  )
 188                             )
 189                          += ( eelem "sideBar"
 190                               += ( eelem "left"
 191                                    += ( (constA name &&& constA Nothing &&& constA leftSideBar)
 192                                         >>>
 193                                         formatSubPage sto sysConf interpTable
 194                                       )
 195                                  )
 196                               += ( eelem "right"
 197                                    += ( (constA name &&& constA Nothing &&& constA rightSideBar)
 198                                         >>>
 199                                         formatSubPage sto sysConf interpTable
 200                                       )
 201                                  )
 202                             )
 203                          >>>
 204                          uniqueNamespacesFromDeclAndQNames
 205                        )
 206                   ) -<< ()
 207           returnA -< tree
 208
 209
 210 formatMainPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 211                   Storage
 212                -> SystemConfig
 213                -> InterpTable
 214                -> a Page XmlTree
 215 formatMainPage sto sysConf interpTable
 216     = proc page
 217     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 218           wiki            <- arr2 wikifyPage -< (interpTable, page)
 219           xs              <- interpretCommandsA sto sysConf interpTable
 220                              -< (pageName page, Just (page, wiki), wiki)
 221           formatWikiBlocks -< (baseURI, xs)
 222
 223
 224 formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 225                  Storage
 226               -> SystemConfig
 227               -> InterpTable
 228               -> a (PageName, (Maybe Page, Page)) XmlTree
 229 formatSubPage sto sysConf interpTable
 230     = proc (mainPageName, (mainPage, subPage))
 231     -> do BaseURI baseURI <- getSysConfA sysConf -< ()
 232           mainWiki        <- case mainPage of
 233                                Just page
 234                                    -> do wiki <- arr2 wikifyPage -< (interpTable, page)
 235                                          returnA -< Just (page, wiki)
 236                                Nothing
 237                                    -> returnA -< Nothing
 238           subWiki        <- arr2 wikifyPage -< (interpTable, subPage)
 239           xs             <- interpretCommandsA sto sysConf interpTable
 240                             -< (mainPageName, mainWiki, subWiki)
 241           formatWikiBlocks -< (baseURI, xs)
 242
 243
 244 wikifyPage :: InterpTable -> Page -> WikiPage
 245 wikifyPage interpTable page
 246     = case pageType page of
 247         MIMEType "text" "x-rakka" _
 248             -> let source = decodeLazy UTF8 (pageContent page)
 249                    parser = wikiPage tableToFunc
 250                in
 251                  case parse parser "" source of
 252                    Left err -> wikifyParseError err
 253                    Right xs -> xs
 254
 255         MIMEType "image" _ _
 256             -> [ Paragraph [ Image (pageName page) Nothing ] ]
 257
 258         _   -> if pageIsBinary page then
 259                    -- object へのリンクのみ
 260                    [ Paragraph [ ObjectLink (pageName page) (Just $ pageFileName' page) ] ]
 261                else
 262                    -- pre
 263                    let text = decodeLazy UTF8 (pageContent page)
 264                    in
 265                      [ Preformatted [ Text text ] ]
 266     where
 267       tableToFunc :: String -> Maybe CommandType
 268       tableToFunc name
 269           = fmap commandType (M.lookup name interpTable)
 270
 271
 272 interpretCommandsA :: (ArrowIO a, ArrowApply a) =>
 273                       Storage
 274                    -> SystemConfig
 275                    -> InterpTable
 276                    -> a (PageName, Maybe (Page, WikiPage), WikiPage) WikiPage
 277 interpretCommandsA sto sysConf interpTable
 278     = proc (name, mainPageAndTree, targetTree)
 279     -> arrIO0 (interpretCommands sto sysConf interpTable name mainPageAndTree targetTree)
 280        -<< ()
 281
 282
 283 interpretCommands :: Storage
 284                   -> SystemConfig
 285                   -> InterpTable
 286                   -> PageName
 287                   -> Maybe (Page, WikiPage)
 288                   -> WikiPage
 289                   -> IO WikiPage
 290 interpretCommands sto sysConf interpTable name mainPageAndTree targetTree
 291     = everywhereM' (mkM interpBlockCmd) targetTree
 292       >>=
 293       everywhereM' (mkM interpInlineCmd)
 294     where
 295       ctx :: InterpreterContext
 296       ctx = InterpreterContext {
 297               ctxPageName   = name
 298             , ctxMainPage   = fmap fst mainPageAndTree
 299             , ctxMainTree   = fmap snd mainPageAndTree
 300             , ctxTargetTree = targetTree
 301             , ctxStorage    = sto
 302             , ctxSysConf    = sysConf
 303             }
 304
 305       interpBlockCmd :: BlockElement -> IO BlockElement
 306       interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
 307       interpBlockCmd others         = return others
 308
 309       interpBlockCmd' :: BlockCommand -> IO BlockElement
 310       interpBlockCmd' cmd
 311           = case M.lookup (bCmdName cmd) interpTable of
 312               Nothing
 313                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 314
 315               Just interp
 316                   -> bciInterpret interp ctx cmd
 317
 318
 319       interpInlineCmd :: InlineElement -> IO InlineElement
 320       interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
 321       interpInlineCmd others          = return others
 322
 323       interpInlineCmd' :: InlineCommand -> IO InlineElement
 324       interpInlineCmd' cmd
 325           = case M.lookup (iCmdName cmd) interpTable of
 326               Nothing
 327                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 328
 329               Just interp
 330                   -> iciInterpret interp ctx cmd
 331
 332
 333 makeDraft :: InterpTable -> Page -> IO Document
 334 makeDraft interpTable page
 335     = do doc <- newDocument
 336
 337          setURI       doc                  $ Just $ mkRakkaURI $ pageName page
 338          setAttribute doc "@title"         $ Just $ pageName page
 339          setAttribute doc "@lang"          $ pageLanguage page
 340          setAttribute doc "@type"          $ Just $ show $ pageType page
 341          setAttribute doc "@mdate"         $ Just $ formatW3CDateTime $ pageLastMod page
 342          setAttribute doc "rakka:fileName" $ pageFileName page
 343          setAttribute doc "rakka:isLocked" $ Just $ yesOrNo $ pageIsLocked page
 344          setAttribute doc "rakka:isBoring" $ Just $ yesOrNo $ pageIsBoring page
 345          setAttribute doc "rakka:isBinary" $ Just $ yesOrNo $ pageIsBinary page
 346          setAttribute doc "rakka:revision" $ Just $ show $ pageRevision page
 347          setAttribute doc "rakka:summary"  $ pageSummary page
 348
 349          addHiddenText doc (pageName page)
 350
 351          case pageType page of
 352             MIMEType "text" "css" _
 353                 -> setAttribute doc "rakka:isTheme" $ Just $ yesOrNo $ pageIsTheme page
 354             MIMEType "text" "x-rakka" _
 355                 -> setAttribute doc "rakka:isFeed"  $ Just $ yesOrNo $ pageIsFeed page
 356             _   -> return ()
 357
 358          case pageSummary page of
 359            Nothing -> return ()
 360            Just s  -> addHiddenText doc s
 361
 362          -- otherLang はリンク先ページ名を hidden text で入れる。
 363          sequence_ [ addHiddenText doc x
 364                          | (_, x) <- M.toList (pageOtherLang page) ]
 365
 366          -- wikify して興味のある部分を addText する。
 367          let wikiPage = wikifyPage interpTable page
 368          everywhereM' (mkM (addBlockText  doc)) wikiPage
 369          everywhereM' (mkM (addInlineText doc)) wikiPage
 370
 371          return doc
 372     where
 373       addBlockText :: Document -> BlockElement -> IO BlockElement
 374       addBlockText doc b
 375           = do case b of
 376                  Heading _ text
 377                      -> addText doc text
 378                  _   -> return ()
 379                return b
 380
 381       addInlineText :: Document -> InlineElement -> IO InlineElement
 382       addInlineText doc i
 383           = do case i of
 384                  Text text
 385                      -> addText doc text
 386                  ObjectLink page Nothing
 387                      -> addText doc page
 388                  ObjectLink page (Just text)
 389                      -> do addHiddenText doc page
 390                            addText doc text
 391                  PageLink page fragment Nothing
 392                      -> addText doc (fromMaybe "" page ++
 393                                      fromMaybe "" fragment)
 394                  PageLink page fragment (Just text)
 395                      -> do addHiddenText doc (fromMaybe "" page ++
 396                                               fromMaybe "" fragment)
 397                            addText doc text
 398                  ExternalLink uri Nothing
 399                      -> addText doc (uriToString id uri "")
 400                  ExternalLink uri (Just text)
 401                      -> do addHiddenText doc (uriToString id uri "")
 402                            addText doc text
 403                  _   -> return ()
 404                return i
 405
 406
 407 -- Perform monadic transformation in top-down order.
 408 everywhereM' :: Monad m => GenericM m -> GenericM m
 409 everywhereM' f x = f x >>= gmapM (everywhereM' f)
 410
 411
 412 wikifyParseError :: ParseError -> WikiPage
 413 wikifyParseError err
 414     = [Div [("class", "error")]
 415                [ Block (Preformatted [Text (show err)]) ]]