Rakka/Resource/Render.hs

   1 module Rakka.Resource.Render
   2     ( resRender
   3     )
   4     where
   5
   6 import qualified Codec.Binary.UTF8.String as UTF8
   7 import           Control.Arrow
   8 import           Control.Arrow.ArrowIO
   9 import           Control.Arrow.ArrowList
  10 import           Control.Monad.Trans
  11 import qualified Data.ByteString.Lazy as Lazy
  12 import           Network.HTTP.Lucu
  13 import           OpenSSL.EVP.Base64
  14 import           Rakka.Environment
  15 import           Rakka.Page
  16 import           Rakka.Utils
  17 import           Rakka.Wiki.Engine
  18 import           System.FilePath.Posix
  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 = UTF8.decodeString . joinPath
  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                                                            , (a_output_encoding, utf8)
  87                                                            , (a_no_xml_pi      , v_0) ]
  88                                    )
  89          output xmlStr
  90
  91
  92 render :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  93           Environment
  94        -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
  95 render env
  96     = proc (pName, pType, pBin)
  97     -> do pageBody <- listA (makePreviewXHTML (envStorage env) (envSysConf env) (envInterpTable env))
  98                       -< (pName, pType, pBin)
  99
 100           ( eelem "/"
 101             += ( eelem "renderResult"
 102                  += sattr "name" pName
 103                  += constL pageBody
 104                  >>>
 105                  uniqueNamespacesFromDeclAndQNames
 106                ) ) -<< ()
 107