X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FEngine.hs;h=afbc610ab0f1497ec94f9b9b8991fb819049c7c2;hb=e43bb104a7313dd696b8bb8aa3bafff94706a187;hp=aa897e841e01b6429d9dd9fd1d5d81ebedb9f532;hpb=b3c3f333cd48bc74eb33f0f21d56a9d1bc65e0ea;p=Rakka.git diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index aa897e8..afbc610 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -1,94 +1,270 @@ module Rakka.Wiki.Engine - ( formatPage - , formatSubPage + ( InterpTable + , formatEntirePage + , formatUnexistentPage + , makeDraft ) where import Control.Arrow import Control.Arrow.ArrowIO -import Control.Arrow.ArrowTree +import Control.Arrow.ArrowList import Data.Encoding import Data.Encoding.UTF8 import Data.Generics +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.Namespace import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.DOM.TypeDefs -formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => - Environment - -> a Page XmlTree -formatPage env +type InterpTable = Map String Interpreter + + +formatEntirePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => + Storage + -> SystemConfig + -> InterpTable + -> a Page XmlTree +formatEntirePage sto sysConf interpTable + = 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 "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "") + += 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) + + += ( 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) + ) + >>> + uniqueNamespacesFromDeclAndQNames + ) + ) -<< () + returnA -< tree + + +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 "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "") + += sattr "name" name + + += ( 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 tree <- case pageType page of - MIMEType "text" "x-rakka" _ - -> do let source = decodeLazy UTF8 (pageContent page) - formatWikiPage env -< (pageName page, source) - attachXHtmlNs -< tree + -> do BaseURI baseURI <- getSysConfA sysConf -< () + wiki <- arr2 wikifyPage -< (interpTable, page) + xs <- interpretCommandsA sto sysConf interpTable + -< (pageName page, Just (page, wiki), wiki) + formatWikiBlocks -< (baseURI, xs) 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) + Storage + -> SystemConfig + -> InterpTable + -> a (PageName, (Maybe Page, Page)) XmlTree +formatSubPage sto sysConf interpTable + = proc (mainPageName, (mainPage, subPage)) + -> do BaseURI baseURI <- getSysConfA sysConf -< () + mainWiki <- case mainPage of + Just page + -> do wiki <- arr2 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 :: InterpTable -> String -> Maybe CommandType - tableToFunc table name - = fmap commandType (M.lookup name table) + tableToFunc :: String -> Maybe CommandType + tableToFunc name + = fmap commandType (M.lookup name interpTable) -interpretCommandsA :: ArrowIO a => - Environment - -> a (InterpTable, (PageName, WikiPage)) WikiPage -interpretCommandsA = arrIO3 . interpretCommands +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 :: Environment -> InterpTable -> PageName -> WikiPage -> IO WikiPage -interpretCommands _ _ _ [] = return [] -interpretCommands env table name blocks = everywhereM' (mkM interpBlockCmd) blocks - >>= - everywhereM' (mkM interpInlineCmd) +interpretCommands :: Storage + -> SystemConfig + -> InterpTable + -> PageName + -> Maybe (Page, WikiPage) + -> WikiPage + -> IO WikiPage +interpretCommands sto sysConf interpTable name mainPageAndTree targetTree + = everywhereM' (mkM interpBlockCmd) targetTree + >>= + everywhereM' (mkM interpInlineCmd) where ctx :: InterpreterContext ctx = InterpreterContext { - ctxPageName = name - , ctxTree = blocks - , ctxStorage = envStorage env - , ctxSysConf = envSysConf env + ctxPageName = name + , ctxMainPage = fmap fst mainPageAndTree + , ctxMainTree = fmap snd mainPageAndTree + , ctxTargetTree = targetTree + , ctxStorage = sto + , ctxSysConf = sysConf } interpBlockCmd :: BlockElement -> IO BlockElement @@ -97,7 +273,7 @@ interpretCommands env table name blocks = everywhereM' (mkM interpBlockCmd) bloc interpBlockCmd' :: BlockCommand -> IO BlockElement interpBlockCmd' cmd - = case M.lookup (bCmdName cmd) table of + = case M.lookup (bCmdName cmd) interpTable of Nothing -> fail ("no such interpreter: " ++ bCmdName cmd) @@ -111,7 +287,7 @@ interpretCommands env table name blocks = everywhereM' (mkM interpBlockCmd) bloc interpInlineCmd' :: InlineCommand -> IO InlineElement interpInlineCmd' cmd - = case M.lookup (iCmdName cmd) table of + = case M.lookup (iCmdName cmd) interpTable of Nothing -> fail ("no such interpreter: " ++ iCmdName cmd) @@ -119,21 +295,86 @@ interpretCommands env table name blocks = everywhereM' (mkM interpBlockCmd) bloc -> iciInterpret interp ctx cmd --- Perform monadic transformation in top-down order. -everywhereM' :: Monad m => GenericM m -> GenericM m -everywhereM' f x = f x >>= gmapM (everywhereM' f) +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 -formatParseError :: ArrowXml a => a ParseError XmlTree -formatParseError - = proc err -> (eelem "pre" += txt (show err)) -<< () + 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 () -attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree -attachXHtmlNs = processBottomUp (changeQName attach') + case pageSummary page of + Nothing -> return () + Just s -> addHiddenText doc s + + -- 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 where - attach' :: QName -> QName - attach' qn = qn { - namePrefix = "xhtml" - , namespaceUri = "http://www.w3.org/1999/xhtml" - } + addBlockText :: Document -> BlockElement -> IO BlockElement + addBlockText doc b + = do case b of + Heading _ text + -> addText doc text + _ -> return () + return b + + addInlineText :: Document -> InlineElement -> IO InlineElement + addInlineText doc i + = do case i of + Text text + -> addText doc text + ObjectLink page Nothing + -> addText doc page + ObjectLink page (Just text) + -> do addHiddenText doc page + addText doc text + PageLink page fragment Nothing + -> addText doc (fromMaybe "" page ++ + fromMaybe "" fragment) + PageLink page fragment (Just text) + -> do addHiddenText doc (fromMaybe "" page ++ + fromMaybe "" fragment) + addText doc text + ExternalLink uri Nothing + -> addText doc (uriToString id uri "") + ExternalLink uri (Just text) + -> do addHiddenText doc (uriToString id uri "") + addText doc text + _ -> 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)]) ]]