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           Network.HTTP.Lucu
  12 import           Rakka.Environment
  13 import           Rakka.Page
  14 import           Rakka.SystemConfig
  15 import           Rakka.Wiki.Parser
  16 import           Rakka.Wiki.Formatter
  17 import           Text.ParserCombinators.Parsec
  18 import           Text.XML.HXT.Arrow.XmlArrow
  19 import           Text.XML.HXT.DOM.TypeDefs
  20
  21
  22 formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  23               Environment
  24            -> a Page XmlTree
  25 formatPage env
  26     = proc page
  27     -> do tree <- case pageType page of
  28                     MIMEType "text" "x-rakka" _
  29                         -> formatWikiPage env -< page
  30           attachXHtmlNs -< tree
  31
  32
  33 formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  34                   Environment
  35                -> a Page XmlTree
  36 formatWikiPage env
  37     = proc page
  38     -> do let source = decodeLazy UTF8 (pageContent page)
  39           case parse wikiPage "" source of
  40             Left  err
  41                 -> formatParseError -< err
  42
  43             Right elems
  44                 -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
  45                       formatWikiElements -< (baseURI, elems)
  46
  47
  48 formatParseError :: ArrowXml a => a ParseError XmlTree
  49 formatParseError
  50     = proc err -> (eelem "pre" += txt (show err)) -<< ()
  51
  52
  53 attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
  54 attachXHtmlNs = processBottomUp (changeQName attach')
  55     where
  56       attach' :: QName -> QName
  57       attach' qn = qn {
  58                      namePrefix   = "xhtml"
  59                    , namespaceUri = "http://www.w3.org/1999/xhtml"
  60                    }