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