module Rakka.Wiki.Engine
( InterpTable
, 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
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
import Text.XML.HXT.Arrow.XmlNodeSet
import Text.XML.HXT.DOM.TypeDefs
type InterpTable = Map String Interpreter
{-
-- デフォルトでない場合のみ存在
lastModified="2000-01-01T00:00:00">
blah blah...
-- 存在しない場合もある
-- 存在しない場合もある
blah blah...
SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
-}
xmlizePage :: (ArrowXml a, ArrowChoice a) => a Page XmlTree
xmlizePage
= proc page
-> (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
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
( arrIO (everywhereM' (mkM $ interpBlockCmd ctx))
>>>
arrIO (everywhereM' (mkM $ interpInlineCmd ctx))
) -<< targetWiki
where
interpBlockCmd :: InterpreterContext -> BlockElement -> IO BlockElement
interpBlockCmd ctx (BlockCmd cmd) = interpBlockCmd' ctx cmd
interpBlockCmd _ others = return others
interpBlockCmd' :: InterpreterContext -> BlockCommand -> IO BlockElement
interpBlockCmd' ctx cmd
= case M.lookup (bCmdName cmd) interpTable of
Nothing
-> fail ("no such interpreter: " ++ bCmdName cmd)
Just interp
-> bciInterpret interp ctx cmd
interpInlineCmd :: InterpreterContext -> InlineElement -> IO InlineElement
interpInlineCmd ctx (InlineCmd cmd) = interpInlineCmd' ctx cmd
interpInlineCmd _ others = return others
interpInlineCmd' :: InterpreterContext -> InlineCommand -> IO InlineElement
interpInlineCmd' ctx cmd
= case M.lookup (iCmdName cmd) interpTable of
Nothing
-> fail ("no such interpreter: " ++ iCmdName cmd)
Just interp
-> iciInterpret interp ctx cmd
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 で入れる。
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
= 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 :: Arrow a => a ParseError WikiPage
wikifyParseError = proc err
-> returnA -< [Div [("class", "error")]
[ Block (Preformatted [Text (show err)]) ]]