Rakka/Wiki/Engine.hs

   1 module Rakka.Wiki.Engine
   2     ( formatPage
   3     , formatSubPage
   4     )
   5     where
   6
   7 import           Control.Arrow
   8 import           Control.Arrow.ArrowIO
   9 import           Data.Encoding
  10 import           Data.Encoding.UTF8
  11 import           Data.Generics
  12 import qualified Data.Map as M
  13 import           Network.HTTP.Lucu
  14 import           Rakka.Environment
  15 import           Rakka.Page
  16 import           Rakka.SystemConfig
  17 import           Rakka.Wiki
  18 import           Rakka.Wiki.Parser
  19 import           Rakka.Wiki.Formatter
  20 import           Rakka.Wiki.Interpreter
  21 import           Text.ParserCombinators.Parsec
  22 import           Text.XML.HXT.Arrow.XmlArrow
  23 import           Text.XML.HXT.DOM.TypeDefs
  24
  25
  26 formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  27               Environment
  28            -> a Page XmlTree
  29 formatPage env
  30     = proc page
  31     -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
  32           interpTable     <- getInterpTableA env -< ()
  33           wiki            <- wikifyPage env -< (interpTable, page)
  34           xs              <- interpretCommandsA env -< (interpTable, (pageName page, (Just wiki, wiki)))
  35           formatWikiBlocks -< (baseURI, xs)
  36
  37
  38 formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  39                  Environment
  40               -> a (PageName, (Maybe Page, Page)) XmlTree
  41 formatSubPage env
  42     = proc (mainPageName, (mainPage, subPage))
  43     -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
  44           interpTable     <- getInterpTableA env -< ()
  45           mainWiki        <- case mainPage of
  46                                Just page
  47                                    -> do wiki <- wikifyPage env -< (interpTable, page)
  48                                          returnA -< Just wiki
  49                                Nothing
  50                                    -> returnA -< Nothing
  51           subWiki        <- wikifyPage env -< (interpTable, subPage)
  52           xs             <- interpretCommandsA env -< (interpTable, (mainPageName, (mainWiki, subWiki)))
  53           formatWikiBlocks -< (baseURI, xs)
  54
  55
  56 wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  57                  Environment
  58               -> a (InterpTable, Page) WikiPage
  59 wikifyPage env
  60     = proc (interpTable, page)
  61     -> case pageType page of
  62          MIMEType "text" "x-rakka" _
  63              -> do let source = decodeLazy UTF8 (pageContent page)
  64                        parser = wikiPage (tableToFunc interpTable)
  65
  66                    case parse parser "" source of
  67                      Left  err
  68                          -> wikifyParseError -< err
  69
  70                      Right xs
  71                          -> returnA -< xs
  72     where
  73       tableToFunc :: InterpTable -> String -> Maybe CommandType
  74       tableToFunc table name
  75           = fmap commandType (M.lookup name table)
  76
  77
  78 interpretCommandsA :: ArrowIO a =>
  79                       Environment
  80                    -> a (InterpTable, (PageName, (Maybe WikiPage, WikiPage))) WikiPage
  81 interpretCommandsA = arrIO4 . interpretCommands
  82
  83
  84 interpretCommands :: Environment -> InterpTable -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage
  85 interpretCommands _   _     _    _        []         = return []
  86 interpretCommands env table name mainTree targetTree
  87     = everywhereM' (mkM interpBlockCmd) targetTree
  88       >>=
  89       everywhereM' (mkM interpInlineCmd)
  90     where
  91       ctx :: InterpreterContext
  92       ctx = InterpreterContext {
  93               ctxPageName   = name
  94             , ctxMainTree   = mainTree
  95             , ctxTargetTree = targetTree
  96             , ctxStorage    = envStorage env
  97             , ctxSysConf    = envSysConf env
  98             }
  99
 100       interpBlockCmd :: BlockElement -> IO BlockElement
 101       interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
 102       interpBlockCmd others         = return others
 103
 104       interpBlockCmd' :: BlockCommand -> IO BlockElement
 105       interpBlockCmd' cmd
 106           = case M.lookup (bCmdName cmd) table of
 107               Nothing
 108                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 109
 110               Just interp
 111                   -> bciInterpret interp ctx cmd
 112
 113
 114       interpInlineCmd :: InlineElement -> IO InlineElement
 115       interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
 116       interpInlineCmd others          = return others
 117
 118       interpInlineCmd' :: InlineCommand -> IO InlineElement
 119       interpInlineCmd' cmd
 120           = case M.lookup (iCmdName cmd) table of
 121               Nothing
 122                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 123
 124               Just interp
 125                   -> iciInterpret interp ctx cmd
 126
 127
 128 -- Perform monadic transformation in top-down order.
 129 everywhereM' :: Monad m => GenericM m -> GenericM m
 130 everywhereM' f x = f x >>= gmapM (everywhereM' f)
 131
 132
 133 wikifyParseError :: ArrowXml a => a ParseError WikiPage
 134 wikifyParseError
 135     = proc err -> returnA -< [Div [("class", "error")]
 136                               [ Preformatted [Text (show err)] ]]