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