previewer backend now partly works

[Rakka.git] / Rakka / Wiki / Engine.hs

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 47ae1100073c8a3a49aedeb9ecabff52522c6b32..b475f9c04be3c3db3335f320bd011334a5eac16c 100644 (file)
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -3,12 +3,16 @@ module Rakka.Wiki.Engine
     , makeMainXHTML
     , makeSubXHTML
     , makeDraft
+    , makePreviewXHTML
     )
     where
 
+import qualified Codec.Binary.Base64 as B64
+import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Arrow
 import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowList
+import qualified Data.ByteString.Lazy as Lazy
 import           Data.Map (Map)
 import qualified Data.Map as M
 import           Data.Maybe
@@ -45,7 +49,7 @@ wikifyPage interpTable
 
           case pType of
             MIMEType "text" "x-rakka" _
-                -> case parse (wikiPage cmdTypeOf) "" (fromJust textData) of
+                -> case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
                      Left err -> wikifyParseError -< err
                      Right xs -> returnA -< xs
 
@@ -64,10 +68,6 @@ wikifyPage interpTable
                        -- pre
                        returnA -< [ Preformatted [Text $ fromJust textData] ]
     where
-      cmdTypeOf :: String -> Maybe CommandType
-      cmdTypeOf name
-          = fmap commandType (M.lookup name interpTable)
-
       binToURI :: MIMEType -> String -> URI
       binToURI pType base64Data
           = nullURI {
@@ -82,6 +82,49 @@ wikifyPage interpTable
           | otherwise        = x : stripWhiteSpace xs
 
 
+wikifyBin :: (ArrowXml a, ArrowChoice a) => InterpTable -> a (MIMEType, Lazy.ByteString) WikiPage
+wikifyBin interpTable
+    = proc (pType, pBin)
+    -> do let text    = UTF8.decode $ Lazy.unpack pBin
+              dataURI = binToURI pType pBin
+
+          case pType of
+            MIMEType "text" "x-rakka" _
+                -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
+                     Left err -> wikifyParseError -< err
+                     Right xs -> returnA -< xs
+
+            MIMEType "image" _ _
+                -- <img src="data:image/png;base64,..." />
+                -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
+
+            
+            _
+                -- <a href="data:application/zip;base64,...">
+                --   application/zip (19372 bytes)
+                -- </a>
+                -> returnA -< [ Paragraph [ Anchor
+                                            [("href", show dataURI)]
+                                            [Text (show pType ++
+                                                   " (" ++
+                                                   show (Lazy.length pBin) ++
+                                                   " bytes)")]
+                                          ]
+                              ]
+    where
+      binToURI :: MIMEType -> Lazy.ByteString -> URI
+      binToURI m b
+          = nullURI {
+              uriScheme = "data:"
+            , uriPath   = show m ++ ";base64," ++ B64.encode (Lazy.unpack b)
+            }
+
+
+cmdTypeOf :: InterpTable -> String -> Maybe CommandType
+cmdTypeOf interpTable name
+    = fmap commandType (M.lookup name interpTable)
+
+
 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                  Storage
               -> SystemConfig
@@ -93,7 +136,7 @@ makeMainXHTML sto sysConf interpTable
           wiki            <- wikifyPage interpTable -< tree
           pName           <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
           interpreted     <- interpretCommands sto sysConf interpTable
-                             -< (pName, Just (tree, wiki), wiki)
+                             -< (pName, Just tree, Just wiki, wiki)
           formatWikiBlocks -< (baseURI, interpreted)
 
 
@@ -113,7 +156,21 @@ makeSubXHTML sto sysConf interpTable
                                    -> returnA -< Nothing
           subWiki         <- wikifyPage interpTable -< subPage
           interpreted     <- interpretCommands sto sysConf interpTable
-                             -< (mainPageName, mainWiki, subWiki)
+                             -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
+          formatWikiBlocks -< (baseURI, interpreted)
+
+
+makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+                    Storage
+                 -> SystemConfig
+                 -> InterpTable
+                 -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
+makePreviewXHTML sto sysConf interpTable
+    = proc (name, pageType, pageBin)
+    -> do BaseURI baseURI <- getSysConfA sysConf -< ()
+          wiki            <- wikifyBin interpTable -< (pageType, pageBin)
+          interpreted     <- interpretCommands sto sysConf interpTable
+                             -< (name, Nothing, Just wiki, wiki)
           formatWikiBlocks -< (baseURI, interpreted)
 
 
@@ -121,13 +178,13 @@ interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                      Storage
                   -> SystemConfig
                   -> InterpTable
-                  -> a (PageName, Maybe (XmlTree, WikiPage), WikiPage) WikiPage
+                  -> a (PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
 interpretCommands sto sysConf interpTable
-    = proc (name, mainPageAndWiki, targetWiki)
+    = proc (name, mainPage, mainWiki, targetWiki)
     -> let ctx = InterpreterContext {
                    ctxPageName   = name
-                 , ctxMainPage   = fmap fst mainPageAndWiki
-                 , ctxMainWiki   = fmap snd mainPageAndWiki
+                 , ctxMainPage   = mainPage
+                 , ctxMainWiki   = mainWiki
                  , ctxTargetWiki = targetWiki
                  , ctxStorage    = sto
                  , ctxSysConf    = sysConf