previewer backend now partly works

[Rakka.git] / Rakka / Resource / Render.hs

diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs
new file mode 100644 (file)
index 0000000..01c75e1
--- /dev/null
+++ b/Rakka/Resource/Render.hs
@@ -0,0 +1,102 @@
+module Rakka.Resource.Render
+    ( resRender
+    )
+    where
+
+import           Control.Arrow
+import           Control.Arrow.ArrowIO
+import           Control.Arrow.ArrowList
+import           Control.Monad.Trans
+import qualified Codec.Binary.UTF8.String as UTF8
+import qualified Data.ByteString.Lazy as Lazy
+import qualified Data.Map as M
+import           Network.HTTP.Lucu
+import           Network.HTTP.Lucu.Utils
+import           Rakka.Environment
+import           Rakka.Page
+import           Rakka.Wiki
+import           Rakka.Wiki.Engine
+import           Rakka.Wiki.Parser
+import           Rakka.Wiki.Interpreter
+import           Text.ParserCombinators.Parsec
+import           Text.XML.HXT.Arrow.Namespace
+import           Text.XML.HXT.Arrow.WriteDocument
+import           Text.XML.HXT.Arrow.XmlArrow
+import           Text.XML.HXT.Arrow.XmlIOStateArrow
+import           Text.XML.HXT.DOM.TypeDefs
+import           Text.XML.HXT.DOM.XmlKeywords
+
+
+resRender :: Environment -> ResourceDef
+resRender env
+    = ResourceDef {
+        resUsesNativeThread = False
+      , resIsGreedy         = True
+      , resGet              = Nothing
+      , resHead             = Nothing
+      , resPost             = Just $ getPathInfo >>= handleRender env . toPageName
+      , resPut              = Nothing
+      , resDelete           = Nothing
+      }
+    where
+      toPageName :: [String] -> PageName
+      toPageName = decodePageName . joinWith "/" 
+
+
+{-
+  --- Request ---
+  POST /render/Foo/Bar HTTP/1.0
+  Content-Type: text/x-rakka
+  
+  = foo =
+  blah blah...
+  
+  --- Response ---
+  HTTP/1.1 200 OK
+  Content-Type: text/xml
+  
+  <renderResult xmlns:xhtml="http://www.w3.org/1999/xhtml"
+                name="Foo/Bar">
+    <xhtml:h1>foo</xhtml:h1>
+    <xhtml:p>
+      blah blah...
+    </xhtml:p>
+  </renderResult>
+-}
+handleRender :: Environment -> PageName -> Resource ()
+handleRender env name
+    = do cType <- guessTypeIfNeeded =<< getContentType
+         bin   <- inputLBS defaultLimit
+
+         setContentType $ read "text/xml"
+         [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
+                                     >>>
+                                     constA (name, cType, bin)
+                                     >>>
+                                     render env
+                                     >>>
+                                     writeDocumentToString [ (a_indent, v_1) ]
+                                   )
+         output xmlStr
+    where
+      guessTypeIfNeeded :: Maybe MIMEType -> Resource MIMEType
+      guessTypeIfNeeded (Just t) = return t
+      guessTypeIfNeeded Nothing  = fail "not impl"
+
+
+render :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+          Environment
+       -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
+render env
+    = proc (pName, pType, pBin)
+    -> do pageBody <- listA (makePreviewXHTML (envStorage env) (envSysConf env) (envInterpTable env))
+                      -< (pName, pType, pBin)
+
+          ( eelem "/"
+            += ( eelem "renderResult"
+                 += sattr "name" pName
+                 += constL pageBody
+                 >>>
+                 uniqueNamespacesFromDeclAndQNames
+               ) ) -<< ()
+