Rakka/Resource/Render.hs

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