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           wiki            <- wikifyPage env -< page
  33           xs              <- interpretCommandsA env -< (pageName page, (Just wiki, wiki))
  34           formatWikiBlocks -< (baseURI, xs)
  35
  36
  37 formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  38                  Environment
  39               -> a (PageName, (Maybe Page, Page)) XmlTree
  40 formatSubPage env
  41     = proc (mainPageName, (mainPage, subPage))
  42     -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
  43           mainWiki        <- case mainPage of
  44                                Just page
  45                                    -> do wiki <- wikifyPage env -< page
  46                                          returnA -< Just wiki
  47                                Nothing
  48                                    -> returnA -< Nothing
  49           subWiki        <- wikifyPage env -< subPage
  50           xs             <- interpretCommandsA env -< (mainPageName, (mainWiki, subWiki))
  51           formatWikiBlocks -< (baseURI, xs)
  52
  53
  54 wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  55                  Environment
  56               -> a Page WikiPage
  57 wikifyPage env
  58     = proc page
  59     -> case pageType page of
  60          MIMEType "text" "x-rakka" _
  61              -> do let source = decodeLazy UTF8 (pageContent page)
  62                        parser = wikiPage tableToFunc
  63
  64                    case parse parser "" source of
  65                      Left  err
  66                          -> wikifyParseError -< err
  67
  68                      Right xs
  69                          -> returnA -< xs
  70     where
  71       tableToFunc :: String -> Maybe CommandType
  72       tableToFunc name
  73           = fmap commandType (M.lookup name (envInterpTable env))
  74
  75
  76 interpretCommandsA :: ArrowIO a =>
  77                       Environment
  78                    -> a (PageName, (Maybe WikiPage, WikiPage)) WikiPage
  79 interpretCommandsA = arrIO3 . interpretCommands
  80
  81
  82 interpretCommands :: Environment -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage
  83 interpretCommands _   _    _        []         = return []
  84 interpretCommands env name mainTree targetTree
  85     = everywhereM' (mkM interpBlockCmd) targetTree
  86       >>=
  87       everywhereM' (mkM interpInlineCmd)
  88     where
  89       ctx :: InterpreterContext
  90       ctx = InterpreterContext {
  91               ctxPageName   = name
  92             , ctxMainTree   = mainTree
  93             , ctxTargetTree = targetTree
  94             , ctxStorage    = envStorage env
  95             , ctxSysConf    = envSysConf env
  96             }
  97
  98       interpBlockCmd :: BlockElement -> IO BlockElement
  99       interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
 100       interpBlockCmd others         = return others
 101
 102       interpBlockCmd' :: BlockCommand -> IO BlockElement
 103       interpBlockCmd' cmd
 104           = case M.lookup (bCmdName cmd) (envInterpTable env) of
 105               Nothing
 106                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 107
 108               Just interp
 109                   -> bciInterpret interp ctx cmd
 110
 111
 112       interpInlineCmd :: InlineElement -> IO InlineElement
 113       interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
 114       interpInlineCmd others          = return others
 115
 116       interpInlineCmd' :: InlineCommand -> IO InlineElement
 117       interpInlineCmd' cmd
 118           = case M.lookup (iCmdName cmd) (envInterpTable env) of
 119               Nothing
 120                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 121
 122               Just interp
 123                   -> iciInterpret interp ctx cmd
 124
 125
 126 -- Perform monadic transformation in top-down order.
 127 everywhereM' :: Monad m => GenericM m -> GenericM m
 128 everywhereM' f x = f x >>= gmapM (everywhereM' f)
 129
 130
 131 wikifyParseError :: ArrowXml a => a ParseError WikiPage
 132 wikifyParseError
 133     = proc err -> returnA -< [Div [("class", "error")]
 134                               [ Preformatted [Text (show err)] ]]