Rakka/Resource/Render.hs

   1 module Rakka.Resource.Render
   2     ( resRender
   3     )
   4     where
   5
   6 import           Control.Arrow
   7 import           Control.Arrow.ArrowIO
   8 import           Control.Arrow.ArrowList
   9 import           Control.Monad.Trans
  10 import qualified Codec.Binary.UTF8.String as UTF8
  11 import qualified Data.ByteString.Lazy as Lazy
  12 import qualified Data.Map as M
  13 import           Network.HTTP.Lucu
  14 import           Network.HTTP.Lucu.Utils
  15 import           Rakka.Environment
  16 import           Rakka.Page
  17 import           Rakka.Utils
  18 import           Rakka.Wiki
  19 import           Rakka.Wiki.Engine
  20 import           Rakka.Wiki.Parser
  21 import           Rakka.Wiki.Interpreter
  22 import           Text.ParserCombinators.Parsec
  23 import           Text.XML.HXT.Arrow.Namespace
  24 import           Text.XML.HXT.Arrow.WriteDocument
  25 import           Text.XML.HXT.Arrow.XmlArrow
  26 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  27 import           Text.XML.HXT.DOM.TypeDefs
  28 import           Text.XML.HXT.DOM.XmlKeywords
  29
  30
  31 resRender :: Environment -> ResourceDef
  32 resRender env
  33     = ResourceDef {
  34         resUsesNativeThread = False
  35       , resIsGreedy         = True
  36       , resGet              = Nothing
  37       , resHead             = Nothing
  38       , resPost             = Just $ getPathInfo >>= handleRender env . toPageName
  39       , resPut              = Nothing
  40       , resDelete           = Nothing
  41       }
  42     where
  43       toPageName :: [String] -> PageName
  44       toPageName = decodePageName . joinWith "/"
  45
  46
  47 {-
  48   --- Request ---
  49   POST /render/Foo/Bar HTTP/1.0
  50   Content-Type: text/x-rakka
  51
  52   = foo =
  53   blah blah...
  54
  55   --- Response ---
  56   HTTP/1.1 200 OK
  57   Content-Type: text/xml
  58
  59   <renderResult xmlns:xhtml="http://www.w3.org/1999/xhtml"
  60                 name="Foo/Bar">
  61     <xhtml:h1>foo</xhtml:h1>
  62     <xhtml:p>
  63       blah blah...
  64     </xhtml:p>
  65   </renderResult>
  66 -}
  67 handleRender :: Environment -> PageName -> Resource ()
  68 handleRender env name
  69     = do bin    <- inputLBS defaultLimit
  70          cTypeM <- getContentType
  71
  72          let cType = case cTypeM of
  73                        Just t  -> t
  74                        Nothing -> guessMIMEType bin
  75
  76          setContentType $ read "text/xml"
  77          [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
  78                                      >>>
  79                                      constA (name, cType, bin)
  80                                      >>>
  81                                      render env
  82                                      >>>
  83                                      writeDocumentToString [ (a_indent, v_1) ]
  84                                    )
  85          output xmlStr
  86
  87
  88 render :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  89           Environment
  90        -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
  91 render env
  92     = proc (pName, pType, pBin)
  93     -> do pageBody <- listA (makePreviewXHTML (envStorage env) (envSysConf env) (envInterpTable env))
  94                       -< (pName, pType, pBin)
  95
  96           ( eelem "/"
  97             += ( eelem "renderResult"
  98                  += sattr "name" pName
  99                  += constL pageBody
 100                  >>>
 101                  uniqueNamespacesFromDeclAndQNames
 102                ) ) -<< ()
 103