1 module Rakka.Resource.Render
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 Network.HTTP.Lucu
12 import Network.HTTP.Lucu.Utils
13 import OpenSSL.EVP.Base64
14 import Rakka.Environment
17 import Rakka.Wiki.Engine
18 import Text.XML.HXT.Arrow.Namespace
19 import Text.XML.HXT.Arrow.WriteDocument
20 import Text.XML.HXT.Arrow.XmlArrow
21 import Text.XML.HXT.Arrow.XmlIOStateArrow
22 import Text.XML.HXT.DOM.TypeDefs
23 import Text.XML.HXT.DOM.XmlKeywords
26 resRender :: Environment -> ResourceDef
29 resUsesNativeThread = False
33 , resPost = Just $ getPathInfo >>= handleRender env . toPageName
38 toPageName :: [String] -> PageName
39 toPageName = decodePageName . joinWith "/"
44 POST /render/Foo/Bar HTTP/1.0
45 Content-Type: text/x-rakka
52 Content-Type: text/xml
54 <renderResult xmlns:xhtml="http://www.w3.org/1999/xhtml"
56 <xhtml:h1>foo</xhtml:h1>
62 handleRender :: Environment -> PageName -> Resource ()
64 = do entity <- inputLBS defaultLimit
65 cTypeM <- getContentType
67 let (bin, cType) = case cTypeM of
68 Just (MIMEType "application" "x-rakka-base64-stream" _)
69 -> let b = decodeBase64LBS entity
75 -> (entity, guessMIMEType entity)
77 setContentType $ read "text/xml"
78 [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
80 constA (name, cType, bin)
84 writeDocumentToString [ (a_indent , v_1)
85 , (a_output_encoding, utf8)
86 , (a_no_xml_pi , v_0) ]
91 render :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
93 -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
95 = proc (pName, pType, pBin)
96 -> do pageBody <- listA (makePreviewXHTML (envStorage env) (envSysConf env) (envInterpTable env))
97 -< (pName, pType, pBin)
100 += ( eelem "renderResult"
101 += sattr "name" pName
104 uniqueNamespacesFromDeclAndQNames