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 (page, 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 (page, 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 (Page, WikiPage), WikiPage)) WikiPage
  79 interpretCommandsA = arrIO3 . interpretCommands
  80
  81
  82 interpretCommands :: Environment -> PageName -> Maybe (Page, WikiPage) -> WikiPage -> IO WikiPage
  83 interpretCommands _   _    _        []         = return []
  84 interpretCommands env name mainPageAndTree targetTree
  85     = everywhereM' (mkM interpBlockCmd) targetTree
  86       >>=
  87       everywhereM' (mkM interpInlineCmd)
  88     where
  89       ctx :: InterpreterContext
  90       ctx = InterpreterContext {
  91               ctxPageName   = name
  92             , ctxMainPage   = fmap fst mainPageAndTree
  93             , ctxMainTree   = fmap snd mainPageAndTree
  94             , ctxTargetTree = targetTree
  95             , ctxStorage    = envStorage env
  96             , ctxSysConf    = envSysConf env
  97             }
  98
  99       interpBlockCmd :: BlockElement -> IO BlockElement
 100       interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
 101       interpBlockCmd others         = return others
 102
 103       interpBlockCmd' :: BlockCommand -> IO BlockElement
 104       interpBlockCmd' cmd
 105           = case M.lookup (bCmdName cmd) (envInterpTable env) of
 106               Nothing
 107                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 108
 109               Just interp
 110                   -> bciInterpret interp ctx cmd
 111
 112
 113       interpInlineCmd :: InlineElement -> IO InlineElement
 114       interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
 115       interpInlineCmd others          = return others
 116
 117       interpInlineCmd' :: InlineCommand -> IO InlineElement
 118       interpInlineCmd' cmd
 119           = case M.lookup (iCmdName cmd) (envInterpTable env) of
 120               Nothing
 121                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 122
 123               Just interp
 124                   -> iciInterpret interp ctx cmd
 125
 126
 127 -- Perform monadic transformation in top-down order.
 128 everywhereM' :: Monad m => GenericM m -> GenericM m
 129 everywhereM' f x = f x >>= gmapM (everywhereM' f)
 130
 131
 132 wikifyParseError :: ArrowXml a => a ParseError WikiPage
 133 wikifyParseError
 134     = proc err -> returnA -< [Div [("class", "error")]
 135                               [ Preformatted [Text (show err)] ]]