Rakka/Resource/Render.hs

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