Rakka/Resource/Render.hs

   1 {-# LANGUAGE
   2     Arrows
   3   , TypeOperators
   4   , UnicodeSyntax
   5   #-}
   6 module Rakka.Resource.Render
   7     ( resRender
   8     )
   9     where
  10 import qualified Codec.Binary.UTF8.String as UTF8
  11 import           Control.Arrow
  12 import           Control.Arrow.ArrowIO
  13 import           Control.Arrow.ArrowList
  14 import           Control.Arrow.Unicode
  15 import           Control.Monad.Trans
  16 import Control.Monad.Unicode
  17 import qualified Data.ByteString.Lazy as Lazy
  18 import Data.Text as T
  19 import           Network.HTTP.Lucu
  20 import           OpenSSL.EVP.Base64
  21 import Prelude.Unicode
  22 import           Rakka.Environment
  23 import           Rakka.Page
  24 import           Rakka.Utils
  25 import           Rakka.Wiki.Engine
  26 import           System.FilePath.Posix
  27 import           Text.XML.HXT.Arrow.Namespace
  28 import           Text.XML.HXT.Arrow.WriteDocument
  29 import           Text.XML.HXT.Arrow.XmlArrow
  30 import Text.XML.HXT.Arrow.XmlState
  31 import           Text.XML.HXT.DOM.TypeDefs
  32
  33 resRender ∷ Environment → ResourceDef
  34 resRender env
  35     = ResourceDef {
  36         resUsesNativeThread = False
  37       , resIsGreedy         = True
  38       , resGet              = Nothing
  39       , resHead             = Nothing
  40       , resPost             = Just $ getPathInfo ≫= handleRender env ∘ toPageName
  41       , resPut              = Nothing
  42       , resDelete           = Nothing
  43       }
  44     where
  45       toPageName ∷ [String] → PageName
  46       toPageName = T.pack ∘ UTF8.decodeString ∘ joinPath
  47
  48 {-
  49   --- Request ---
  50   POST /render/Foo/Bar HTTP/1.0
  51   Content-Type: text/x-rakka
  52
  53   = foo =
  54   blah blah...
  55
  56   --- Response ---
  57   HTTP/1.1 200 OK
  58   Content-Type: text/xml
  59
  60   <renderResult xmlns:xhtml="http://www.w3.org/1999/xhtml"
  61                 name="Foo/Bar">
  62     <xhtml:h1>foo</xhtml:h1>
  63     <xhtml:p>
  64       blah blah...
  65     </xhtml:p>
  66   </renderResult>
  67 -}
  68 handleRender :: Environment -> PageName -> Resource ()
  69 handleRender env name
  70     = do entity <- inputLBS defaultLimit
  71          cTypeM <- getContentType
  72
  73          let (bin, cType) = case cTypeM of
  74                               Just (MIMEType "application" "x-rakka-base64-stream" _)
  75                                   -> let b = decodeBase64LBS entity
  76                                      in
  77                                        (b, guessMIMEType b)
  78                               Just t
  79                                   -> (entity, t)
  80                               Nothing
  81                                   -> (entity, guessMIMEType entity)
  82
  83          setContentType $ read "text/xml"
  84          [xmlStr] ← liftIO $ runX ( setErrorMsgHandler False fail
  85                                     ⋙
  86                                     constA (name, cType, bin)
  87                                     ⋙
  88                                     render env
  89                                     ⋙
  90                                     writeDocumentToString [ withIndent yes
  91                                                           , withXmlPi  yes
  92                                                           ]
  93                                   )
  94          output $ UTF8.encodeString xmlStr
  95
  96 render ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
  97        ⇒ Environment
  98        → (PageName, MIMEType, Lazy.ByteString) ⇝ XmlTree
  99 render env
 100     = proc (pName, pType, pBin)
 101     → do pageBody ← listA (makePreviewXHTML (envStorage env) (envSysConf env) (envInterpTable env))
 102                     ⤙ (pName, pType, pBin)
 103          ( eelem "/"
 104            += ( eelem "renderResult"
 105                 += sattr "xmlns:xhtml" "http://www.w3.org/1999/xhtml"
 106                 += sattr "name" (T.unpack pName)
 107                 += constL pageBody
 108                 ⋙
 109                 uniqueNamespacesFromDeclAndQNames
 110               ) ) ⤛ ()