X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FEngine.hs;h=02e987cd20f7ed92c6eb7521f3cd2d2e877c6f3f;hb=42f51754dea02201aececaacbf194d714cd58aaf;hp=8d5c8eecc0fa87ffbf53812a8916aece7cb1fa72;hpb=98e508613bb7a50a1f65998ce87f065df957b736;p=Rakka.git diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 8d5c8ee..02e987c 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -1,22 +1,38 @@ +{-# LANGUAGE + Arrows + , OverloadedStrings + , ScopedTypeVariables + , TypeOperators + , UnicodeSyntax + #-} module Rakka.Wiki.Engine ( InterpTable - , formatEntirePage - , formatUnexistentPage + , makeMainXHTML + , makeSubXHTML + , makePreviewXHTML + , makePageLinkList , makeDraft ) where - -import Control.Arrow -import Control.Arrow.ArrowIO -import Control.Arrow.ArrowList -import Data.Encoding -import Data.Encoding.UTF8 -import Data.Generics +import Control.Applicative +import Control.Arrow +import Control.Arrow.ArrowIO +import Control.Arrow.ArrowList +import Control.Arrow.Unicode +import Control.Monad.Unicode +import qualified Codec.Binary.UTF8.String as UTF8 +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 Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T import Network.HTTP.Lucu import Network.URI +import OpenSSL.EVP.Base64 +import Prelude.Unicode import Rakka.Page import Rakka.Storage import Rakka.SystemConfig @@ -27,329 +43,402 @@ 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 - - -type InterpTable = Map String Interpreter +import Text.XML.HXT.Arrow.XmlArrow hiding (err) +import Text.XML.HXT.DOM.TypeDefs +import Text.XML.HXT.XPath + +type InterpTable = Map Text Interpreter + +wikifyPage ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ InterpTable → 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 = 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", T.pack $ show dataURI)] + [Text (T.pack $ show pType)] + ] + ] + else + -- pre + returnA ⤙ [ Preformatted [Text ∘ T.pack $ fromJust textData] ] + where + 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 (⇝), ArrowChoice (⇝)) ⇒ InterpTable → (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", T.pack $ show dataURI)] + [Text (T.concat [ T.pack $ show pType + , "(" + , T.pack ∘ 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) + } -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" - Just leftSideBar <- getPageA sto -< "SideBar/Left" - Just rightSideBar <- getPageA sto -< "SideBar/Right" - - 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 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" - Just leftSideBar <- getPageA sto -< "SideBar/Left" - Just rightSideBar <- getPageA sto -< "SideBar/Right" - - 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 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) => - Storage - -> SystemConfig - -> InterpTable - -> a (PageName, (Maybe Page, Page)) XmlTree -formatSubPage sto sysConf interpTable - = proc (mainPageName, (mainPage, subPage)) +cmdTypeOf ∷ Alternative f ⇒ InterpTable → Text → f CommandType +cmdTypeOf interpTable name + = case M.lookup name interpTable of + Just t → pure $ commandType t + Nothing → empty + +makeMainXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) + ⇒ Storage + → SystemConfig + → InterpTable + → 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 + ⤙ (Just (T.pack pName), Just tree, Just wiki, wiki) + formatWikiBlocks ⤙ (baseURI, interpreted) + + +makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => + Storage + -> SystemConfig + -> InterpTable + -> a (Maybe 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 - where - tableToFunc :: String -> Maybe CommandType - tableToFunc name - = fmap commandType (M.lookup name interpTable) + subWiki <- wikifyPage interpTable -< subPage + interpreted <- interpretCommands sto sysConf interpTable + -< (mainPageName, fmap fst mainWiki, fmap snd 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) - -<< () +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) -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 (Maybe 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 - 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' :: BlockCommand -> IO BlockElement - interpBlockCmd' cmd + 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) + → fail ("no such interpreter: " ⊕ T.unpack (bCmdName cmd)) Just interp - -> bciInterpret interp ctx cmd - + → 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 + interpInlineCommand ∷ InterpreterContext → InlineCommand → IO InlineElement + interpInlineCommand ctx cmd = case M.lookup (iCmdName cmd) interpTable of Nothing - -> fail ("no such interpreter: " ++ iCmdName cmd) + → fail ("no such interpreter: " ⊕ T.unpack (iCmdName cmd)) Just interp - -> 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: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 - - 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 - - -- 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 + → iciInterpret interp ctx cmd ≫= interpInline ctx + +makeDraft ∷ ∀(⇝). (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) ⇒ InterpTable → XmlTree ⇝ Document +makeDraft interpTable + = proc tree → + do redir ← maybeA (getXPathTreesInDoc "/page/@redirect") ⤙ tree + case redir of + Nothing → makeEntityDraft ⤙ tree + Just _ → makeRedirectDraft ⤙ tree + where + makeEntityDraft ∷ 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 + 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 $ T.pack pName ) + arrIO2 (flip setAttribute "@title" ) ⤙ (doc, Just $ T.pack pName ) + arrIO2 (flip setAttribute "@type" ) ⤙ (doc, Just $ T.pack pType ) + arrIO2 (flip setAttribute "@mdate" ) ⤙ (doc, Just $ T.pack pLastMod ) + arrIO2 (flip setAttribute "@lang" ) ⤙ (doc, T.pack <$> pLang) + arrIO2 (flip setAttribute "rakka:isLocked") ⤙ (doc, Just $ T.pack pIsLocked) + arrIO2 (flip setAttribute "rakka:isBinary") ⤙ (doc, Just $ T.pack pIsBinary) + arrIO2 (flip setAttribute "rakka:revision") ⤙ (doc, Just $ T.pack pRevision) + arrIO2 (flip setAttribute "rakka:summary" ) ⤙ (doc, T.pack <$> pSummary) + + arrIO2 addHiddenText ⤙ (doc, T.pack pName) + + case pSummary of + Just s → arrIO2 addHiddenText ⤙ (doc, T.pack 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, T.pack <$> otherLangs) + + case read pType of + MIMEType "text" "css" _ + → arrIO2 (flip setAttribute "rakka:isTheme") ⤙ (doc, T.pack <$> pIsTheme) + + MIMEType "text" "x-rakka" _ + -- wikify して興味のある部分を addText する。 + → do arrIO2 (flip setAttribute "rakka:isFeed") ⤙ (doc, T.pack <$> pIsFeed) + wiki ← wikifyPage interpTable ⤙ tree + arrIO2 (mapM_ ∘ addBlockText) ⤙ (doc, wiki) + + MIMEType _ _ _ + → returnA ⤙ () + + returnA ⤙ doc + + makeRedirectDraft ∷ 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 $ T.pack pName ) + arrIO2 (flip setAttribute "@title" ) -< (doc, Just $ T.pack pName ) + arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection") + arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just $ T.pack pLastMod ) + arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just $ T.pack pIsLocked ) + arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just $ T.pack pRevision ) + + -- リダイレクト先ページ名はテキストとして入れる + arrIO2 addText ⤙ (doc, T.pack 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 ⊕ maybe (∅) (T.cons '#') fragm) + addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragm) + *> addText doc text + addInlineText doc (ExternalLink uri Nothing) = addText doc (T.pack $ uriToString id uri "") + addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (T.pack $ 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 (T.pack $ 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 + + +makePageLinkList ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) + ⇒ Storage + → SystemConfig + → InterpTable + → 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 (T.pack pName), Just tree, Just wiki, wiki) + returnA ⤙ concatMap extractFromBlock interpreted where - 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 - 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")] - [ Preformatted [Text (show err)] ]] + 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 (⇝) ⇒ ParseError ⇝ WikiPage +wikifyParseError = proc err + → returnA -< [Div [("class", "error")] + [ Block (Preformatted [Text (T.pack $ show err)]) ]]