module Rakka.Wiki.Engine
( InterpTable
, makeMainXHTML
, makeSubXHTML
, makeDraft
)
where
import Control.Arrow
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Network.HTTP.Lucu
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 hiding (err)
import Text.XML.HXT.Arrow.XmlNodeSet
import Text.XML.HXT.DOM.TypeDefs
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
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) "" (fromJust textData) of
Left err -> wikifyParseError -< err
Right xs -> returnA -< xs
MIMEType "image" _ _
--
-> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
_ -> if isJust dataURI then
-- foo.zip
returnA -< [ Paragraph [ Anchor
[("href", show dataURI)]
[Text (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
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, 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, mainWiki, subWiki)
formatWikiBlocks -< (baseURI, interpreted)
interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
Storage
-> SystemConfig
-> InterpTable
-> 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
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
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
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
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)
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)]) ]]