]> gitweb @ CieloNegro.org - Rakka.git/blob - Rakka/Resource/Render.hs
new task to ditz
[Rakka.git] / 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