From 71f2db55513679098869de2122b5d5989dbc2be2 Mon Sep 17 00:00:00 2001 From: pho Date: Sun, 6 Jan 2008 11:57:06 +0900 Subject: [PATCH] previewer backend now partly works darcs-hash:20080106025706-62b54-39657bc20da7c0b6d22e196234750a0120737783.gz --- Main.hs | 4 +- Rakka.cabal | 1 + Rakka/Page.hs | 12 ++--- Rakka/Resource/PageEntity.hs | 5 ++ Rakka/Resource/Render.hs | 102 +++++++++++++++++++++++++++++++++++ Rakka/Wiki/Engine.hs | 79 +++++++++++++++++++++++---- Rakka/Wiki/Formatter.hs | 14 ++++- 7 files changed, 198 insertions(+), 19 deletions(-) create mode 100644 Rakka/Resource/Render.hs diff --git a/Main.hs b/Main.hs index fd379f3..b3313d6 100644 --- a/Main.hs +++ b/Main.hs @@ -9,6 +9,7 @@ import Rakka.Resource.Index import Rakka.Resource.JavaScript import Rakka.Resource.PageEntity import Rakka.Resource.Object +import Rakka.Resource.Render import Rakka.Storage import Subversion import System.Console.GetOpt @@ -136,8 +137,9 @@ main = withSubversion $ resTree :: Environment -> ResTree resTree env = mkResTree [ ([] , resIndex env) - , (["object"], resObject env) , (["js" ], javaScript ) + , (["object"], resObject env) + , (["render"], resRender env) ] diff --git a/Rakka.cabal b/Rakka.cabal index a66b4a7..08df415 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -53,6 +53,7 @@ Executable rakka Rakka.Resource.JavaScript Rakka.Resource.Object Rakka.Resource.PageEntity + Rakka.Resource.Render Rakka.Storage Rakka.Storage.DefaultPage Rakka.Storage.Repos diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 0d355fa..d6a9369 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -31,7 +31,7 @@ module Rakka.Page where import qualified Codec.Binary.Base64 as B64 -import Codec.Binary.UTF8.String +import qualified Codec.Binary.UTF8.String as UTF8 import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowList @@ -128,7 +128,7 @@ pageRevision p -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。 encodePageName :: PageName -> FilePath -encodePageName = escapeURIString isSafeChar . encodeString . fixPageName +encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName where fixPageName :: PageName -> PageName fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c) @@ -144,11 +144,11 @@ isSafeChar c -- URI unescape して UTF-8 から decode する。 decodePageName :: FilePath -> PageName -decodePageName = decodeString . unEscapeString +decodePageName = UTF8.decodeString . unEscapeString encodeFragment :: String -> String -encodeFragment = escapeURIString isSafeChar . encodeString +encodeFragment = escapeURIString isSafeChar . UTF8.encodeString entityFileName' :: Page -> String @@ -312,7 +312,7 @@ xmlizePage ) else ( eelem "textData" - += txt (decode $ L.unpack $ entityContent page) + += txt (UTF8.decode $ L.unpack $ entityContent page) ) ) )) -<< () @@ -369,7 +369,7 @@ parseEntity let (isBinary, content) = case (textData, binaryData) of - (Just text, Nothing ) -> (False, L.pack $ encode text ) + (Just text, Nothing ) -> (False, L.pack $ UTF8.encode text ) (Nothing , Just binary) -> (True , L.pack $ B64.decode binary) _ -> error "one of textData or binaryData is required" diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index b894088..59753d7 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -20,6 +20,7 @@ import Rakka.Storage import Rakka.SystemConfig import Rakka.Wiki.Engine import System.FilePath +import Text.XML.HXT.Arrow.Namespace import Text.XML.HXT.Arrow.WriteDocument import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlIOStateArrow @@ -193,6 +194,8 @@ entityToXHTML env ) ) ) + >>> + uniqueNamespacesFromDeclAndQNames ) ) -<< page @@ -298,6 +301,8 @@ notFoundToXHTML env ) ) ) + >>> + uniqueNamespacesFromDeclAndQNames ) ) -<< pageNotFound diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs new file mode 100644 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 + + + foo + + blah blah... + + +-} +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 + ) ) -<< () + diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 47ae110..b475f9c 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 @@ -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" _ _ + -- + -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ] + + + _ + -- + -- application/zip (19372 bytes) + -- + -> 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 diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index 0dfe02e..4a3531c 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -4,7 +4,9 @@ module Rakka.Wiki.Formatter where import Control.Arrow +import Control.Arrow.ArrowIf import Control.Arrow.ArrowList +import Control.Arrow.ArrowTree import Data.Char import Data.List import Data.Maybe @@ -20,7 +22,7 @@ formatWikiBlocks = proc (baseURI, blocks) -> do block <- arrL id -< blocks tree <- formatBlock -< (baseURI, block) - returnA -< tree + attachXHtmlNS -< tree formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree @@ -273,3 +275,13 @@ mkAnchor :: (ArrowXml a) => a (String, String) XmlTree mkAnchor = eelem "a" += attr "href" (arr fst >>> mkText) += (arr snd >>> mkText) + + +attachXHtmlNS :: (ArrowXml a) => a XmlTree XmlTree +attachXHtmlNS = processTopDown (changeQName attach `when` isElem) + where + attach :: QName -> QName + attach qn = qn { + namePrefix = "xhtml" + , namespaceUri = "http://www.w3.org/1999/xhtml" + } -- 2.40.0