Rakka/Wiki/Engine.hs

   1 module Rakka.Wiki.Engine
   2     ( formatPage
   3     )
   4     where
   5
   6 import           Control.Arrow
   7 import           Control.Arrow.ArrowIO
   8 import           Control.Arrow.ArrowTree
   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 tree <- case pageType page of
  32                     MIMEType "text" "x-rakka" _
  33                         -> do let source = decodeLazy UTF8 (pageContent page)
  34                               formatWikiPage env -< (Just page, source)
  35           attachXHtmlNs -< tree
  36
  37
  38 formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  39                   Environment
  40                -> a (Maybe Page, String) XmlTree
  41 formatWikiPage env
  42     = proc (page, source)
  43     -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
  44           interpTable     <- getInterpTableA env -< ()
  45
  46           let parser = wikiPage (tableToFunc interpTable)
  47
  48           case parse parser "" source of
  49             Left  err
  50                 -> formatParseError -< err
  51
  52             Right blocks
  53                 -> do xs <- interpretCommandsA env -< (interpTable, (page, blocks))
  54                       formatWikiBlocks -< (baseURI, xs)
  55     where
  56       tableToFunc :: InterpTable -> String -> Maybe CommandType
  57       tableToFunc table name
  58           = fmap commandType (M.lookup name table)
  59
  60
  61 interpretCommandsA :: ArrowIO a =>
  62                       Environment
  63                    -> a (InterpTable, (Maybe Page, WikiPage)) WikiPage
  64 interpretCommandsA = arrIO3 . interpretCommands
  65
  66
  67 interpretCommands :: Environment -> InterpTable -> Maybe Page -> WikiPage -> IO WikiPage
  68 interpretCommands _   _     _    []     = return []
  69 interpretCommands env table page blocks = everywhereM' (mkM interpBlockCmd) blocks
  70                                           >>=
  71                                           everywhereM' (mkM interpInlineCmd)
  72     where
  73       ctx :: InterpreterContext
  74       ctx = InterpreterContext {
  75                   ctxPage    = page
  76                 , ctxTree    = blocks
  77                 , ctxStorage = envStorage env
  78                 , ctxSysConf = envSysConf env
  79                 }
  80
  81       interpBlockCmd :: BlockElement -> IO BlockElement
  82       interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
  83       interpBlockCmd others         = return others
  84
  85       interpBlockCmd' :: BlockCommand -> IO BlockElement
  86       interpBlockCmd' cmd
  87           = case M.lookup (bCmdName cmd) table of
  88               Nothing
  89                   -> fail ("no such interpreter: " ++ bCmdName cmd)
  90
  91               Just interp
  92                   -> bciInterpret interp ctx cmd
  93
  94
  95       interpInlineCmd :: InlineElement -> IO InlineElement
  96       interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
  97       interpInlineCmd others          = return others
  98
  99       interpInlineCmd' :: InlineCommand -> IO InlineElement
 100       interpInlineCmd' cmd
 101           = case M.lookup (iCmdName cmd) table of
 102               Nothing
 103                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 104
 105               Just interp
 106                   -> iciInterpret interp ctx cmd
 107
 108
 109 -- Perform monadic transformation in top-down order.
 110 everywhereM' :: Monad m => GenericM m -> GenericM m
 111 everywhereM' f x = f x >>= gmapM (everywhereM' f)
 112
 113
 114 formatParseError :: ArrowXml a => a ParseError XmlTree
 115 formatParseError
 116     = proc err -> (eelem "pre" += txt (show err)) -<< ()
 117
 118
 119 attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
 120 attachXHtmlNs = processBottomUp (changeQName attach')
 121     where
 122       attach' :: QName -> QName
 123       attach' qn = qn {
 124                      namePrefix   = "xhtml"
 125                    , namespaceUri = "http://www.w3.org/1999/xhtml"
 126                    }