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           Rakka.Environment
  12 import           Rakka.Page
  13 import           Rakka.Utils
  14 import           Rakka.Wiki.Engine
  15 import           System.FilePath.Posix
  16 import           Text.XML.HXT.Arrow.Namespace
  17 import           Text.XML.HXT.Arrow.WriteDocument
  18 import           Text.XML.HXT.Arrow.XmlArrow
  19 import           Text.XML.HXT.DOM.TypeDefs
  20 import           Text.XML.HXT.DOM.XmlKeywords
  21
  22
  23 resRender :: Environment -> ResourceDef
  24 resRender env
  25     = ResourceDef {
  26         resUsesNativeThread = False
  27       , resIsGreedy         = True
  28       , resGet              = Nothing
  29       , resHead             = Nothing
  30       , resPost             = Just $ getPathInfo >>= handleRender env . toPageName
  31       , resPut              = Nothing
  32       , resDelete           = Nothing
  33       }
  34     where
  35       toPageName :: [String] -> PageName
  36       toPageName = UTF8.decodeString . joinPath
  37
  38
  39 {-
  40   --- Request ---
  41   POST /render/Foo/Bar HTTP/1.0
  42   Content-Type: text/x-rakka
  43
  44   = foo =
  45   blah blah...
  46
  47   --- Response ---
  48   HTTP/1.1 200 OK
  49   Content-Type: text/xml
  50
  51   <renderResult xmlns:xhtml="http://www.w3.org/1999/xhtml"
  52                 name="Foo/Bar">
  53     <xhtml:h1>foo</xhtml:h1>
  54     <xhtml:p>
  55       blah blah...
  56     </xhtml:p>
  57   </renderResult>
  58 -}
  59 handleRender :: Environment -> PageName -> Resource ()
  60 handleRender env name
  61     = do entity <- inputLBS defaultLimit
  62          cTypeM <- getContentType
  63
  64          let (bin, cType) = case cTypeM of
  65                               Just (MIMEType "application" "x-rakka-base64-stream" _)
  66                                   -> let b = decodeBase64LBS entity
  67                                      in
  68                                        (b, guessMIMEType b)
  69                               Just t
  70                                   -> (entity, t)
  71                               Nothing
  72                                   -> (entity, guessMIMEType entity)
  73
  74          setContentType $ read "text/xml"
  75          [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
  76                                      >>>
  77                                      constA (name, cType, bin)
  78                                      >>>
  79                                      render env
  80                                      >>>
  81                                      writeDocumentToString [ (a_indent         , v_1)
  82                                                            , (a_output_encoding, utf8)
  83                                                            , (a_no_xml_pi      , v_0) ]
  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