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