X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FWiki%2FEngine.hs;h=1f24e37332b96f1f6f093d75546ed73ce385edc2;hp=07eaff4a594ed5c5ff112f1550997e533bffe6df;hb=656fdb2772ab4de5cd083cbe9e7c1610cccef73b;hpb=ee28059eadd401e5f9256df590bbb7491f952685 diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 07eaff4..1f24e37 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -1,14 +1,17 @@ module Rakka.Wiki.Engine ( InterpTable - , formatEntirePage - , formatUnexistentPage + , xmlizePage + , makeMainXHTML + , makeSubXHTML , makeDraft ) where +import qualified Codec.Binary.Base64 as B64 import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowList +import qualified Data.ByteString.Lazy as L import Data.Encoding import Data.Encoding.UTF8 import Data.Generics @@ -27,287 +30,206 @@ import Rakka.Wiki.Formatter import Rakka.Wiki.Interpreter import Text.HyperEstraier hiding (getText) import Text.ParserCombinators.Parsec -import Text.XML.HXT.Arrow.Namespace import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlNodeSet import Text.XML.HXT.DOM.TypeDefs type InterpTable = Map String Interpreter -formatEntirePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => - Storage - -> SystemConfig - -> InterpTable - -> a Page XmlTree -formatEntirePage sto sysConf interpTable +{- + -- デフォルトでない場合のみ存在 + lastModified="2000-01-01T00:00:00"> + + + blah blah... + -- 存在しない場合もある + + -- 存在しない場合もある + + + + + + blah blah... + + + SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS... + + +-} +xmlizePage :: (ArrowXml a, ArrowChoice a) => a Page XmlTree +xmlizePage = proc page - -> do SiteName siteName <- getSysConfA sysConf -< () - BaseURI baseURI <- getSysConfA sysConf -< () - StyleSheet cssName <- getSysConfA sysConf -< () - - Just pageTitle <- getPageA sto -< ("PageTitle" , Nothing) - Just leftSideBar <- getPageA sto -< ("SideBar/Left" , Nothing) - Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing) - - tree <- ( eelem "/" - += ( eelem "page" - += sattr "site" siteName - += sattr "baseURI" (uriToString id baseURI "") - += sattr "name" (pageName page) - += sattr "type" (show $ pageType page) - += ( case pageLanguage page of - Just x -> sattr "lang" x - _ -> none - ) - += ( case pageFileName page of - Just x -> sattr "fileName" x - _ -> none - ) - += ( case pageType page of - MIMEType "text" "css" _ - -> sattr "isTheme" (yesOrNo $ pageIsTheme page) - _ -> none - ) - += ( case pageType page of - MIMEType "text" "x-rakka" _ - -> sattr "isFeed" (yesOrNo $ pageIsFeed page) - _ -> none - ) - += sattr "isLocked" (yesOrNo $ pageIsLocked page) - += sattr "isBoring" (yesOrNo $ pageIsBoring page) - += sattr "isBinary" (yesOrNo $ pageIsBinary page) - += sattr "revision" (show $ pageRevision page) - += sattr "lastModified" (formatW3CDateTime $ pageLastMod page) - - += ( eelem "styleSheets" - += ( eelem "styleSheet" - += sattr "src" (uriToString id (mkObjectURI baseURI cssName) "") - ) - ) - - += ( eelem "scripts" - += ( eelem "script" - += sattr "src" (uriToString id (baseURI { uriPath = "/js" }) "") - ) - ) - - += ( case pageSummary page of - Nothing -> none - Just s -> eelem "summary" += txt s - ) - - += ( if M.null (pageOtherLang page) then - none - else - selem "otherLang" - [ eelem "link" - += sattr "lang" lang - += sattr "page" page - | (lang, page) <- M.toList (pageOtherLang page) ] - ) - += ( eelem "pageTitle" - += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle) - >>> - formatSubPage sto sysConf interpTable - ) - ) - += ( eelem "sideBar" - += ( eelem "left" - += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar) - >>> - formatSubPage sto sysConf interpTable - ) - ) - += ( eelem "right" - += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar) - >>> - formatSubPage sto sysConf interpTable - ) - ) - ) - += ( eelem "body" - += (constA page >>> formatMainPage sto sysConf interpTable) - ) - += (constA page >>> formatSource) - >>> - uniqueNamespacesFromDeclAndQNames - ) - ) -<< () - returnA -< tree - - -formatSource :: (ArrowXml a, ArrowChoice a) => a Page XmlTree -formatSource = proc page - -> if pageIsBinary page then - none -< () - else - let source = decodeLazy UTF8 (pageContent page) - in - ( eelem "source" += mkText ) -< source - - -formatUnexistentPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => - Storage - -> SystemConfig - -> InterpTable - -> a PageName XmlTree -formatUnexistentPage sto sysConf interpTable - = proc name - -> do SiteName siteName <- getSysConfA sysConf -< () - BaseURI baseURI <- getSysConfA sysConf -< () - StyleSheet cssName <- getSysConfA sysConf -< () - - Just pageTitle <- getPageA sto -< ("PageTitle" , Nothing) - Just leftSideBar <- getPageA sto -< ("SideBar/Left" , Nothing) - Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing) - - tree <- ( eelem "/" - += ( eelem "pageNotFound" - += sattr "site" siteName - += sattr "baseURI" (uriToString id baseURI "") - += sattr "name" name - - += ( eelem "styleSheets" - += ( eelem "styleSheet" - += sattr "src" (uriToString id (mkObjectURI baseURI cssName) "") - ) - ) - - += ( eelem "scripts" - += ( eelem "script" - += sattr "src" (uriToString id (baseURI { uriPath = "/js" }) "") - ) - ) - - += ( eelem "pageTitle" - += ( (constA name &&& constA Nothing &&& constA pageTitle) - >>> - formatSubPage sto sysConf interpTable - ) - ) - += ( eelem "sideBar" - += ( eelem "left" - += ( (constA name &&& constA Nothing &&& constA leftSideBar) - >>> - formatSubPage sto sysConf interpTable - ) - ) - += ( eelem "right" - += ( (constA name &&& constA Nothing &&& constA rightSideBar) - >>> - formatSubPage sto sysConf interpTable - ) - ) - ) - >>> - uniqueNamespacesFromDeclAndQNames - ) - ) -<< () - returnA -< tree - - -formatMainPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => - Storage - -> SystemConfig - -> InterpTable - -> a Page XmlTree -formatMainPage sto sysConf interpTable - = proc page - -> do BaseURI baseURI <- getSysConfA sysConf -< () - wiki <- arr2 wikifyPage -< (interpTable, page) - xs <- interpretCommandsA sto sysConf interpTable - -< (pageName page, Just (page, wiki), wiki) - formatWikiBlocks -< (baseURI, xs) + -> (eelem "/" + += ( eelem "page" + += sattr "name" (pageName page) + += sattr "type" (show $ pageType page) + += ( case pageLanguage page of + Just x -> sattr "lang" x + Nothing -> none + ) + += ( case pageFileName page of + Just x -> sattr "fileName" x + Nothing -> none + ) + += ( case pageType page of + MIMEType "text" "css" _ + -> sattr "isTheme" (yesOrNo $ pageIsTheme page) + MIMEType "text" "x-rakka" _ + -> sattr "isFeed" (yesOrNo $ pageIsFeed page) + _ + -> none + ) + += sattr "isLocked" (yesOrNo $ pageIsLocked page) + += sattr "isBoring" (yesOrNo $ pageIsBoring page) + += sattr "isBinary" (yesOrNo $ pageIsBinary page) + += sattr "revision" (show $ pageRevision page) + += sattr "lastModified" (formatW3CDateTime $ pageLastMod page) + += ( case pageSummary page of + Just s -> eelem "summary" += txt s + Nothing -> none + ) + += ( if M.null (pageOtherLang page) then + none + else + selem "otherLang" + [ eelem "link" + += sattr "lang" lang + += sattr "page" page + | (lang, page) <- M.toList (pageOtherLang page) ] + ) + += ( if pageIsBinary page then + ( eelem "binaryData" + += txt (B64.encode $ L.unpack $ pageContent page) + ) + else + ( eelem "textData" + += txt (decodeLazy UTF8 $ pageContent page) + ) + ) + ) + ) -<< () + + +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 + pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree + pFileName <- maybeA (getXPathTreesInDoc "/page/fileName/text()" >>> getText) -< tree + textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree + + case pType of + MIMEType "text" "x-rakka" _ + -> case parse (wikiPage cmdTypeOf) "" (fromJust textData) of + Left err -> wikifyParseError -< err + Right xs -> returnA -< xs + + MIMEType "image" _ _ + -> returnA -< [ Paragraph [Image pName Nothing] ] + + _ -> if pIsBinary == "yes" then + returnA -< [ Paragraph [ ObjectLink { + objLinkPage = pName + , objLinkText = Just $ fromMaybe (defaultFileName pType pName) pFileName + } + ] + ] + 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 { + 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 -formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => +makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Storage -> SystemConfig -> InterpTable - -> a (PageName, (Maybe Page, Page)) XmlTree -formatSubPage sto sysConf interpTable - = proc (mainPageName, (mainPage, subPage)) + -> 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, 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 <- arr2 wikifyPage -< (interpTable, page) + -> do wiki <- wikifyPage interpTable -< page returnA -< Just (page, wiki) Nothing -> returnA -< Nothing - subWiki <- arr2 wikifyPage -< (interpTable, subPage) - xs <- interpretCommandsA sto sysConf interpTable - -< (mainPageName, mainWiki, subWiki) - formatWikiBlocks -< (baseURI, xs) - - -wikifyPage :: InterpTable -> Page -> WikiPage -wikifyPage interpTable page - = case pageType page of - MIMEType "text" "x-rakka" _ - -> let source = decodeLazy UTF8 (pageContent page) - parser = wikiPage tableToFunc - in - case parse parser "" source of - Left err -> wikifyParseError err - Right xs -> xs - - MIMEType "image" _ _ - -> [ Paragraph [ Image (pageName page) Nothing ] ] - - _ -> if pageIsBinary page then - -- object へのリンクのみ - [ Paragraph [ ObjectLink (pageName page) (Just $ pageFileName' page) ] ] - else - -- pre - let text = decodeLazy UTF8 (pageContent page) - in - [ Preformatted [ Text text ] ] - where - tableToFunc :: String -> Maybe CommandType - tableToFunc name - = fmap commandType (M.lookup name interpTable) - + subWiki <- wikifyPage interpTable -< subPage + interpreted <- interpretCommands sto sysConf interpTable + -< (mainPageName, mainWiki, subWiki) + formatWikiBlocks -< (baseURI, interpreted) -interpretCommandsA :: (ArrowIO a, ArrowApply a) => - Storage - -> SystemConfig - -> InterpTable - -> a (PageName, Maybe (Page, WikiPage), WikiPage) WikiPage -interpretCommandsA sto sysConf interpTable - = proc (name, mainPageAndTree, targetTree) - -> arrIO0 (interpretCommands sto sysConf interpTable name mainPageAndTree targetTree) - -<< () - -interpretCommands :: Storage +interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) => + Storage -> SystemConfig -> InterpTable - -> PageName - -> Maybe (Page, WikiPage) - -> WikiPage - -> IO WikiPage -interpretCommands sto sysConf interpTable name mainPageAndTree targetTree - = everywhereM' (mkM interpBlockCmd) targetTree - >>= - everywhereM' (mkM interpInlineCmd) + -> a (PageName, Maybe (XmlTree, WikiPage), WikiPage) WikiPage +interpretCommands sto sysConf interpTable + = proc (name, mainPageAndWiki, targetWiki) + -> let ctx = InterpreterContext { + ctxPageName = name + , ctxMainPage = fmap fst mainPageAndWiki + , ctxMainWiki = fmap snd mainPageAndWiki + , ctxTargetWiki = targetWiki + , ctxStorage = sto + , ctxSysConf = sysConf + } + in + ( arrIO (everywhereM' (mkM $ interpBlockCmd ctx)) + >>> + arrIO (everywhereM' (mkM $ interpInlineCmd ctx)) + ) -<< targetWiki where - ctx :: InterpreterContext - ctx = InterpreterContext { - ctxPageName = name - , ctxMainPage = fmap fst mainPageAndTree - , ctxMainTree = fmap snd mainPageAndTree - , ctxTargetTree = targetTree - , ctxStorage = sto - , ctxSysConf = sysConf - } - - interpBlockCmd :: BlockElement -> IO BlockElement - interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd - interpBlockCmd others = return others + interpBlockCmd :: InterpreterContext -> BlockElement -> IO BlockElement + interpBlockCmd ctx (BlockCmd cmd) = interpBlockCmd' ctx cmd + interpBlockCmd _ others = return others - interpBlockCmd' :: BlockCommand -> IO BlockElement - interpBlockCmd' cmd + interpBlockCmd' :: InterpreterContext -> BlockCommand -> IO BlockElement + interpBlockCmd' ctx cmd = case M.lookup (bCmdName cmd) interpTable of Nothing -> fail ("no such interpreter: " ++ bCmdName cmd) @@ -316,12 +238,12 @@ interpretCommands sto sysConf interpTable name mainPageAndTree targetTree -> bciInterpret interp ctx cmd - interpInlineCmd :: InlineElement -> IO InlineElement - interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd - interpInlineCmd others = return others + interpInlineCmd :: InterpreterContext -> InlineElement -> IO InlineElement + interpInlineCmd ctx (InlineCmd cmd) = interpInlineCmd' ctx cmd + interpInlineCmd _ others = return others - interpInlineCmd' :: InlineCommand -> IO InlineElement - interpInlineCmd' cmd + interpInlineCmd' :: InterpreterContext -> InlineCommand -> IO InlineElement + interpInlineCmd' ctx cmd = case M.lookup (iCmdName cmd) interpTable of Nothing -> fail ("no such interpreter: " ++ iCmdName cmd) @@ -330,45 +252,67 @@ interpretCommands sto sysConf interpTable name mainPageAndTree targetTree -> iciInterpret interp ctx cmd -makeDraft :: InterpTable -> Page -> IO Document -makeDraft interpTable page - = do doc <- newDocument - - setURI doc $ Just $ mkRakkaURI $ pageName page - setAttribute doc "@title" $ Just $ pageName page - setAttribute doc "@lang" $ pageLanguage page - setAttribute doc "@type" $ Just $ show $ pageType page - setAttribute doc "@mdate" $ Just $ formatW3CDateTime $ pageLastMod page - setAttribute doc "rakka:fileName" $ pageFileName page - setAttribute doc "rakka:isLocked" $ Just $ yesOrNo $ pageIsLocked page - setAttribute doc "rakka:isBoring" $ Just $ yesOrNo $ pageIsBoring page - setAttribute doc "rakka:isBinary" $ Just $ yesOrNo $ pageIsBinary page - setAttribute doc "rakka:revision" $ Just $ show $ pageRevision page - setAttribute doc "rakka:summary" $ pageSummary page - - addHiddenText doc (pageName page) - - case pageType page of - MIMEType "text" "css" _ - -> setAttribute doc "rakka:isTheme" $ Just $ yesOrNo $ pageIsTheme page - MIMEType "text" "x-rakka" _ - -> setAttribute doc "rakka:isFeed" $ Just $ yesOrNo $ pageIsFeed page - _ -> return () - - case pageSummary page of - Nothing -> return () - Just s -> addHiddenText doc s +makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document +makeDraft interpTable + = 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 で入れる。 - sequence_ [ addHiddenText doc x - | (_, x) <- M.toList (pageOtherLang page) ] - - -- wikify して興味のある部分を addText する。 - let wikiPage = wikifyPage interpTable page - everywhereM' (mkM (addBlockText doc)) wikiPage - everywhereM' (mkM (addInlineText doc)) wikiPage - - return doc + 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) + wikiPage <- wikifyPage interpTable -< tree + arrIO0 (everywhereM' (mkM (addBlockText doc)) wikiPage) -<< () + arrIO0 (everywhereM' (mkM (addInlineText doc)) wikiPage) -<< () + returnA -< () + + MIMEType _ _ _ + -> returnA -< () + + returnA -< doc where addBlockText :: Document -> BlockElement -> IO BlockElement addBlockText doc b @@ -403,13 +347,12 @@ makeDraft interpTable page _ -> return () return i - -- Perform monadic transformation in top-down order. everywhereM' :: Monad m => GenericM m -> GenericM m everywhereM' f x = f x >>= gmapM (everywhereM' f) -wikifyParseError :: ParseError -> WikiPage -wikifyParseError err - = [Div [("class", "error")] - [ Block (Preformatted [Text (show err)]) ]] +wikifyParseError :: Arrow a => a ParseError WikiPage +wikifyParseError = proc err + -> returnA -< [Div [("class", "error")] + [ Block (Preformatted [Text (show err)]) ]]