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
resTree :: Environment -> ResTree
resTree env
= mkResTree [ ([] , resIndex env)
- , (["object"], resObject env)
, (["js" ], javaScript )
+ , (["object"], resObject env)
+ , (["render"], resRender env)
]
Rakka.Resource.JavaScript
Rakka.Resource.Object
Rakka.Resource.PageEntity
+ Rakka.Resource.Render
Rakka.Storage
Rakka.Storage.DefaultPage
Rakka.Storage.Repos
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
-- 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)
-- 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
)
else
( eelem "textData"
- += txt (decode $ L.unpack $ entityContent page)
+ += txt (UTF8.decode $ L.unpack $ entityContent page)
)
)
)) -<< ()
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"
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
)
)
)
+ >>>
+ uniqueNamespacesFromDeclAndQNames
) ) -<< page
)
)
)
+ >>>
+ uniqueNamespacesFromDeclAndQNames
) ) -<< pageNotFound
--- /dev/null
+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
+ ) ) -<< ()
+
, 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
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
-- 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 {
| 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
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)
-> 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)
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
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
= 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
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"
+ }
projects / Rakka.git / commitdiff