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