X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FWiki%2FEngine.hs;h=21bdad1a11a27ac2895cc6745d735aefef277f38;hp=47ae1100073c8a3a49aedeb9ecabff52522c6b32;hb=bc8616eec0bcac3102860c76f93ebfd0da24c2d6;hpb=701592b0fae35ebc8cb4f855c7701c88fc75566b

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 47ae110..21bdad1 100644
--- 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
@@ -35,9 +39,7 @@ type InterpTable = Map String Interpreter
 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
 wikifyPage interpTable
     = proc tree
-    -> do pName      <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
-          pType      <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
-          pFileName  <- maybeA (getXPathTreesInDoc "/page/fileName/text()"   >>> getText) -< tree
+    -> do pType      <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
           textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
           base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
 
@@ -45,7 +47,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
 
@@ -54,20 +56,18 @@ wikifyPage interpTable
                 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
 
             _   -> if isJust dataURI then
-                       -- <a href="data:application/zip;base64,...">foo.zip</a>
+                       -- <a href="data:application/zip;base64,...">
+                       --   application/zip
+                       -- </a>
                        returnA -< [ Paragraph [ Anchor
                                                 [("href", show dataURI)]
-                                                [Text (fromMaybe (defaultFileName pType pName) pFileName)]
+                                                [Text (show pType)]
                                               ]
                                   ]
                    else
                        -- 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
@@ -205,7 +262,6 @@ makeDraft interpTable
                pType     <- getXPathTreesInDoc "/page/@type/text()"         >>> getText -< tree
                pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
                pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()"     >>> getText -< tree
-               pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()"     >>> getText -< tree
                pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()"     >>> getText -< tree
                pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
                pLang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
@@ -221,7 +277,6 @@ makeDraft interpTable
                arrIO2 (flip setAttribute "@lang"         ) -< (doc, pLang)
                arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName)
                arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
-               arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring)
                arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
                arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
                arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)