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