X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FWiki%2FEngine.hs;h=21bdad1a11a27ac2895cc6745d735aefef277f38;hp=aa897e841e01b6429d9dd9fd1d5d81ebedb9f532;hb=bc8616eec0bcac3102860c76f93ebfd0da24c2d6;hpb=b3c3f333cd48bc74eb33f0f21d56a9d1bc65e0ea diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index aa897e8..21bdad1 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -1,139 +1,394 @@ module Rakka.Wiki.Engine - ( formatPage - , formatSubPage + ( InterpTable + , 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.ArrowTree -import Data.Encoding -import Data.Encoding.UTF8 -import Data.Generics +import Control.Arrow.ArrowList +import qualified Data.ByteString.Lazy as Lazy +import Data.Map (Map) import qualified Data.Map as M +import Data.Maybe import Network.HTTP.Lucu -import Rakka.Environment +import Network.URI import Rakka.Page +import Rakka.Storage import Rakka.SystemConfig +import Rakka.Utils import Rakka.Wiki import Rakka.Wiki.Parser import Rakka.Wiki.Formatter import Rakka.Wiki.Interpreter +import Text.HyperEstraier hiding (getText) import Text.ParserCombinators.Parsec -import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlArrow hiding (err) +import Text.XML.HXT.Arrow.XmlNodeSet import Text.XML.HXT.DOM.TypeDefs -formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => - Environment - -> a Page XmlTree -formatPage env - = proc page - -> do tree <- case pageType page of - MIMEType "text" "x-rakka" _ - -> do let source = decodeLazy UTF8 (pageContent page) - formatWikiPage env -< (pageName page, source) - attachXHtmlNs -< tree - - -formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => - Environment - -> a (PageName, Page) XmlTree -formatSubPage env - = proc (mainPageName, subPage) - -> do tree <- case pageType subPage of - MIMEType "text" "x-rakka" _ - -> do let source = decodeLazy UTF8 (pageContent subPage) - formatWikiPage env -< (mainPageName, source) - attachXHtmlNs -< tree - - -formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => - Environment - -> a (PageName, String) XmlTree -formatWikiPage env - = proc (name, source) - -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () - interpTable <- getInterpTableA env -< () - - let parser = wikiPage (tableToFunc interpTable) - - case parse parser "" source of - Left err - -> formatParseError -< err - - Right blocks - -> do xs <- interpretCommandsA env -< (interpTable, (name, blocks)) - formatWikiBlocks -< (baseURI, xs) +type InterpTable = Map String Interpreter + + +wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage +wikifyPage interpTable + = proc 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 + + let dataURI = fmap (binToURI pType) base64Data + + case pType of + MIMEType "text" "x-rakka" _ + -> case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of + Left err -> wikifyParseError -< err + Right xs -> returnA -< xs + + MIMEType "image" _ _ + -- + -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ] + + _ -> if isJust dataURI then + -- + -- application/zip + -- + returnA -< [ Paragraph [ Anchor + [("href", show dataURI)] + [Text (show pType)] + ] + ] + else + -- pre + returnA -< [ Preformatted [Text $ fromJust textData] ] where - tableToFunc :: InterpTable -> String -> Maybe CommandType - tableToFunc table name - = fmap commandType (M.lookup name table) + binToURI :: MIMEType -> String -> URI + binToURI pType base64Data + = nullURI { + uriScheme = "data:" + , uriPath = show pType ++ ";base64," ++ (stripWhiteSpace base64Data) + } + + stripWhiteSpace :: String -> String + stripWhiteSpace [] = [] + stripWhiteSpace (x:xs) + | x `elem` " \t\n" = stripWhiteSpace xs + | 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 -interpretCommandsA :: ArrowIO a => - Environment - -> a (InterpTable, (PageName, WikiPage)) WikiPage -interpretCommandsA = arrIO3 . interpretCommands + 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] ] -interpretCommands :: Environment -> InterpTable -> PageName -> WikiPage -> IO WikiPage -interpretCommands _ _ _ [] = return [] -interpretCommands env table name blocks = everywhereM' (mkM interpBlockCmd) blocks - >>= - everywhereM' (mkM interpInlineCmd) + + _ + -- + -- application/zip (19372 bytes) + -- + -> returnA -< [ Paragraph [ Anchor + [("href", show dataURI)] + [Text (show pType ++ + " (" ++ + show (Lazy.length pBin) ++ + " bytes)")] + ] + ] where - ctx :: InterpreterContext - ctx = InterpreterContext { - ctxPageName = name - , ctxTree = blocks - , ctxStorage = envStorage env - , ctxSysConf = envSysConf env + binToURI :: MIMEType -> Lazy.ByteString -> URI + binToURI m b + = nullURI { + uriScheme = "data:" + , uriPath = show m ++ ";base64," ++ B64.encode (Lazy.unpack b) } - interpBlockCmd :: BlockElement -> IO BlockElement - interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd - interpBlockCmd others = return others - interpBlockCmd' :: BlockCommand -> IO BlockElement - interpBlockCmd' cmd - = case M.lookup (bCmdName cmd) table of +cmdTypeOf :: InterpTable -> String -> Maybe CommandType +cmdTypeOf interpTable name + = fmap commandType (M.lookup name interpTable) + + +makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => + Storage + -> SystemConfig + -> InterpTable + -> a XmlTree XmlTree +makeMainXHTML sto sysConf interpTable + = proc tree + -> do BaseURI baseURI <- getSysConfA sysConf -< () + wiki <- wikifyPage interpTable -< tree + pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree + interpreted <- interpretCommands sto sysConf interpTable + -< (pName, Just tree, Just wiki, wiki) + formatWikiBlocks -< (baseURI, interpreted) + + +makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => + Storage + -> SystemConfig + -> InterpTable + -> a (PageName, Maybe XmlTree, XmlTree) XmlTree +makeSubXHTML sto sysConf interpTable + = proc (mainPageName, mainPage, subPage) + -> do BaseURI baseURI <- getSysConfA sysConf -< () + mainWiki <- case mainPage of + Just page + -> do wiki <- wikifyPage interpTable -< page + returnA -< Just (page, wiki) + Nothing + -> returnA -< Nothing + subWiki <- wikifyPage interpTable -< subPage + interpreted <- interpretCommands sto sysConf interpTable + -< (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) + + +interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) => + Storage + -> SystemConfig + -> InterpTable + -> a (PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage +interpretCommands sto sysConf interpTable + = proc (name, mainPage, mainWiki, targetWiki) + -> let ctx = InterpreterContext { + ctxPageName = name + , ctxMainPage = mainPage + , ctxMainWiki = mainWiki + , ctxTargetWiki = targetWiki + , ctxStorage = sto + , ctxSysConf = sysConf + } + in + arrIO2 (mapM . interpBlock) -< (ctx, targetWiki) + where + interpElem :: InterpreterContext -> Element -> IO Element + interpElem ctx (Block b) = interpBlock ctx b >>= return . Block + interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline + + interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement + interpBlock ctx (List lType lItems) = mapM (interpListItem ctx) lItems >>= return . List lType + interpBlock ctx (DefinitionList defs) = mapM (interpDefinition ctx) defs >>= return . DefinitionList + interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted + interpBlock ctx (Paragraph inlines) = mapM (interpInline ctx) inlines >>= return . Paragraph + interpBlock ctx (Div attrs elems) = mapM (interpElem ctx) elems >>= return . Div attrs + interpBlock ctx (BlockCmd bcmd) = interpBlockCommand ctx bcmd + interpBlock _ x = return x + + interpInline :: InterpreterContext -> InlineElement -> IO InlineElement + interpInline ctx (Italic inlines) = mapM (interpInline ctx) inlines >>= return . Italic + interpInline ctx (Bold inlines) = mapM (interpInline ctx) inlines >>= return . Bold + interpInline ctx (Span attrs inlines) = mapM (interpInline ctx) inlines >>= return . Span attrs + interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs + interpInline ctx (InlineCmd icmd) = interpInlineCommand ctx icmd + interpInline _ x = return x + + interpListItem :: InterpreterContext -> ListItem -> IO ListItem + interpListItem = mapM . interpElem + + interpDefinition :: InterpreterContext -> Definition -> IO Definition + interpDefinition ctx (Definition term desc) + = do term' <- mapM (interpInline ctx) term + desc' <- mapM (interpInline ctx) desc + return (Definition term' desc') + + interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement + interpBlockCommand ctx cmd + = case M.lookup (bCmdName cmd) interpTable of Nothing -> fail ("no such interpreter: " ++ bCmdName cmd) Just interp -> bciInterpret interp ctx cmd + >>= + interpBlock ctx - - interpInlineCmd :: InlineElement -> IO InlineElement - interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd - interpInlineCmd others = return others - - interpInlineCmd' :: InlineCommand -> IO InlineElement - interpInlineCmd' cmd - = case M.lookup (iCmdName cmd) table of + interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement + interpInlineCommand ctx cmd + = case M.lookup (iCmdName cmd) interpTable of Nothing -> fail ("no such interpreter: " ++ iCmdName cmd) Just interp -> iciInterpret interp ctx cmd + >>= + interpInline ctx --- Perform monadic transformation in top-down order. -everywhereM' :: Monad m => GenericM m -> GenericM m -everywhereM' f x = f x >>= gmapM (everywhereM' f) +makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document +makeDraft interpTable + = proc tree -> + do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree + case redir of + Nothing -> makeEntityDraft -< tree + Just _ -> makeRedirectDraft -< tree + where + makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document + makeEntityDraft + = proc tree -> + do doc <- arrIO0 newDocument -< () + + pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree + pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree + pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree + pIsLocked <- getXPathTreesInDoc "/page/@isLocked/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 + pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree + pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree + pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree + pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree + arrIO2 setURI -< (doc, Just $ mkRakkaURI pName) + arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName) + arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType) + arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod) + 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:isBinary") -< (doc, Just pIsBinary) + arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision) + arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary) -formatParseError :: ArrowXml a => a ParseError XmlTree -formatParseError - = proc err -> (eelem "pre" += txt (show err)) -<< () + arrIO2 addHiddenText -< (doc, pName) + case pSummary of + Just s -> arrIO2 addHiddenText -< (doc, s) + Nothing -> returnA -< () -attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree -attachXHtmlNs = processBottomUp (changeQName attach') - where - attach' :: QName -> QName - attach' qn = qn { - namePrefix = "xhtml" - , namespaceUri = "http://www.w3.org/1999/xhtml" - } + -- otherLang はリンク先ページ名を hidden text で入れる。 + otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree + listA ( (arr fst &&& arrL snd) + >>> + arrIO2 addHiddenText + >>> + none + ) -< (doc, otherLangs) + + case read pType of + MIMEType "text" "css" _ + -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme) + + MIMEType "text" "x-rakka" _ + -- wikify して興味のある部分を addText する。 + -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed) + wiki <- wikifyPage interpTable -< tree + arrIO2 (mapM_ . addBlockText) -< (doc, wiki) + + MIMEType _ _ _ + -> returnA -< () + + returnA -< doc + + makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document + makeRedirectDraft + = proc tree -> + do doc <- arrIO0 newDocument -< () + + pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree + pRedir <- getXPathTreesInDoc "/page/@redirect/text()" >>> getText -< tree + pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree + pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree + + arrIO2 setURI -< (doc, Just $ mkRakkaURI pName) + arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName) + arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection") + arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod) + arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision) + + -- リダイレクト先ページ名はテキストとして入れる + arrIO2 addText -< (doc, pRedir) + + returnA -< doc + + addElemText :: Document -> Element -> IO () + addElemText doc (Block b) = addBlockText doc b + addElemText doc (Inline i) = addInlineText doc i + + addBlockText :: Document -> BlockElement -> IO () + addBlockText doc (Heading _ text) = addText doc text + addBlockText _ HorizontalLine = return () + addBlockText doc (List _ items) = mapM_ (addListItemText doc) items + addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs + addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines + addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines + addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems + addBlockText _ EmptyBlock = return () + addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd + + addInlineText :: Document -> InlineElement -> IO () + addInlineText doc (Text text) = addText doc text + addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines + addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines + addInlineText doc (ObjectLink page Nothing) = addText doc page + addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page + >> addText doc text + addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe "" page ++ fromMaybe "" fragm) + addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm) + >> addText doc text + addInlineText doc (ExternalLink uri Nothing) = addText doc (uriToString id uri "") + addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (uriToString id uri "") + >> addText doc text + addInlineText _ (LineBreak _) = return () + addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines + addInlineText doc (Image src alt) = do case src of + Left uri -> addHiddenText doc (uriToString id uri "") + Right page -> addHiddenText doc page + case alt of + Just text -> addHiddenText doc text + Nothing -> return () + addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines + addInlineText _ (Input _) = return () + addInlineText _ EmptyInline = return () + addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd + + addListItemText :: Document -> ListItem -> IO () + addListItemText = mapM_ . addElemText + + addDefinitionText :: Document -> Definition -> IO () + addDefinitionText doc (Definition term desc) + = do mapM_ (addInlineText doc) term + mapM_ (addInlineText doc) desc + + addBlockCmdText :: Document -> BlockCommand -> IO () + addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks + + addInlineCmdText :: Document -> InlineCommand -> IO () + addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines + + +wikifyParseError :: Arrow a => a ParseError WikiPage +wikifyParseError = proc err + -> returnA -< [Div [("class", "error")] + [ Block (Preformatted [Text (show err)]) ]]