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