X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FEngine.hs;h=dc3d4f14149f0b3e70f91f7e8a5f0b19dceb4d61;hb=df6079ca32f808d76c595e7953bff7a1dd46b10b;hp=7c4487a3ed178e20518c821861258ba2bae59c19;hpb=9681bedbfde02fa1bcda4fbbacba941378c7a57a;p=Rakka.git diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 7c4487a..dc3d4f1 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -1,20 +1,25 @@ module Rakka.Wiki.Engine ( InterpTable - , xmlizePage , makeMainXHTML , makeSubXHTML + , makePreviewXHTML + , makePageLinkList , makeDraft ) where +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 qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe import Network.HTTP.Lucu import Network.URI +import OpenSSL.EVP.Base64 import Rakka.Page import Rakka.Storage import Rakka.SystemConfig @@ -36,9 +41,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 @@ -46,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 @@ -55,20 +58,18 @@ wikifyPage interpTable -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ] _ -> if isJust dataURI then - -- foo.zip + -- + -- application/zip + -- 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 { @@ -83,6 +84,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," ++ (L8.unpack $ encodeBase64LBS b) + } + + +cmdTypeOf :: InterpTable -> String -> Maybe CommandType +cmdTypeOf interpTable name + = fmap commandType (M.lookup name interpTable) + + makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Storage -> SystemConfig @@ -94,7 +138,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) + -< (Just pName, Just tree, Just wiki, wiki) formatWikiBlocks -< (baseURI, interpreted) @@ -102,7 +146,7 @@ makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Storage -> SystemConfig -> InterpTable - -> a (PageName, Maybe XmlTree, XmlTree) XmlTree + -> a (Maybe PageName, Maybe XmlTree, XmlTree) XmlTree makeSubXHTML sto sysConf interpTable = proc (mainPageName, mainPage, subPage) -> do BaseURI baseURI <- getSysConfA sysConf -< () @@ -114,7 +158,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 + -< (Just name, Nothing, Just wiki, wiki) formatWikiBlocks -< (baseURI, interpreted) @@ -122,13 +180,13 @@ interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Storage -> SystemConfig -> InterpTable - -> a (PageName, Maybe (XmlTree, WikiPage), WikiPage) WikiPage + -> a (Maybe 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 @@ -192,63 +250,90 @@ interpretCommands sto sysConf interpTable makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document makeDraft interpTable = proc tree -> - do doc <- arrIO0 newDocument -< () + 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 - 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 - 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: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) - - arrIO2 addHiddenText -< (doc, pName) - - case pSummary of - Just s -> arrIO2 addHiddenText -< (doc, s) - Nothing -> returnA -< () - - -- 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) + 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 + 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: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) + + arrIO2 addHiddenText -< (doc, pName) + + case pSummary of + Just s -> arrIO2 addHiddenText -< (doc, s) + Nothing -> returnA -< () + + -- 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 "text" "x-rakka" _ + -- wikify して興味のある部分を addText する。 + -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed) + wiki <- wikifyPage interpTable -< tree + arrIO2 (mapM_ . addBlockText) -< (doc, wiki) - MIMEType _ _ _ - -> returnA -< () + 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 + pIsLocked <- getXPathTreesInDoc "/page/@isLocked/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:isLocked") -< (doc, Just pIsLocked) + arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision) + + -- リダイレクト先ページ名はテキストとして入れる + arrIO2 addText -< (doc, pRedir) + + returnA -< doc - returnA -< doc - where addElemText :: Document -> Element -> IO () addElemText doc (Block b) = addBlockText doc b addElemText doc (Inline i) = addInlineText doc i @@ -305,6 +390,48 @@ makeDraft interpTable addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines +makePageLinkList :: (ArrowXml a, ArrowChoice a, ArrowIO a) => + Storage + -> SystemConfig + -> InterpTable + -> a XmlTree [PageName] +makePageLinkList sto sysConf interpTable + = proc tree + -> do wiki <- wikifyPage interpTable -< tree + pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree + interpreted <- interpretCommands sto sysConf interpTable + -< (Just pName, Just tree, Just wiki, wiki) + returnA -< concatMap extractFromBlock interpreted + where + extractFromElem :: Element -> [PageName] + extractFromElem (Block b) = extractFromBlock b + extractFromElem (Inline i) = extractFromInline i + + extractFromBlock :: BlockElement -> [PageName] + extractFromBlock (List _ items) = concatMap extractFromListItem items + extractFromBlock (DefinitionList defs) = concatMap extractFromDefinition defs + extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines + extractFromBlock (Paragraph inlines) = concatMap extractFromInline inlines + extractFromBlock (Div _ elems) = concatMap extractFromElem elems + extractFromBlock _ = [] + + extractFromInline :: InlineElement -> [PageName] + extractFromInline (Italic inlines) = concatMap extractFromInline inlines + extractFromInline (Bold inlines) = concatMap extractFromInline inlines + extractFromInline (Span _ inlines) = concatMap extractFromInline inlines + extractFromInline (PageLink (Just name) _ _) = [name] + extractFromInline _ = [] + + extractFromListItem :: ListItem -> [PageName] + extractFromListItem = concatMap extractFromElem + + extractFromDefinition :: Definition -> [PageName] + extractFromDefinition (Definition term desc) + = concatMap extractFromInline term + ++ + concatMap extractFromInline desc + + wikifyParseError :: Arrow a => a ParseError WikiPage wikifyParseError = proc err -> returnA -< [Div [("class", "error")]