6 module Rakka.Resource.Render
10 import qualified Codec.Binary.UTF8.String as UTF8
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
19 import Network.HTTP.Lucu
20 import OpenSSL.EVP.Base64
21 import Prelude.Unicode
22 import Rakka.Environment
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
33 resRender ∷ Environment → ResourceDef
36 resUsesNativeThread = False
40 , resPost = Just $ getPathInfo ≫= handleRender env ∘ toPageName
45 toPageName ∷ [String] → PageName
46 toPageName = T.pack ∘ UTF8.decodeString ∘ joinPath
50 POST /render/Foo/Bar HTTP/1.0
51 Content-Type: text/x-rakka
58 Content-Type: text/xml
60 <renderResult xmlns:xhtml="http://www.w3.org/1999/xhtml"
62 <xhtml:h1>foo</xhtml:h1>
68 handleRender :: Environment -> PageName -> Resource ()
70 = do entity <- inputLBS defaultLimit
71 cTypeM <- getContentType
73 let (bin, cType) = case cTypeM of
74 Just (MIMEType "application" "x-rakka-base64-stream" _)
75 -> let b = decodeBase64LBS entity
81 -> (entity, guessMIMEType entity)
83 setContentType $ read "text/xml"
84 [xmlStr] ← liftIO $ runX ( setErrorMsgHandler False fail
86 constA (name, cType, bin)
90 writeDocumentToString [ withIndent yes
94 output $ UTF8.encodeString xmlStr
96 render ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
98 → (PageName, MIMEType, Lazy.ByteString) ⇝ XmlTree
100 = proc (pName, pType, pBin)
101 → do pageBody ← listA (makePreviewXHTML (envStorage env) (envSysConf env) (envInterpTable env))
102 ⤙ (pName, pType, pBin)
104 += ( eelem "renderResult"
105 += sattr "xmlns:xhtml" "http://www.w3.org/1999/xhtml"
106 += sattr "name" (T.unpack pName)
109 uniqueNamespacesFromDeclAndQNames