1 module Rakka.Wiki.Engine
11 import qualified Codec.Binary.UTF8.String as UTF8
13 import Control.Arrow.ArrowIO
14 import Control.Arrow.ArrowList
15 import qualified Data.ByteString.Lazy as Lazy
16 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
18 import qualified Data.Map as M
20 import Network.HTTP.Lucu
22 import OpenSSL.EVP.Base64
25 import Rakka.SystemConfig
28 import Rakka.Wiki.Parser
29 import Rakka.Wiki.Formatter
30 import Rakka.Wiki.Interpreter
31 import Text.HyperEstraier hiding (getText)
32 import Text.ParserCombinators.Parsec
33 import Text.XML.HXT.Arrow.XmlArrow hiding (err)
34 import Text.XML.HXT.Arrow.XmlNodeSet
35 import Text.XML.HXT.DOM.TypeDefs
38 type InterpTable = Map String Interpreter
41 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
42 wikifyPage interpTable
44 -> do pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
45 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
46 base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
48 let dataURI = fmap (binToURI pType) base64Data
51 MIMEType "text" "x-rakka" _
52 -> case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
53 Left err -> wikifyParseError -< err
54 Right xs -> returnA -< xs
57 -- <img src="data:image/png;base64,..." />
58 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
60 _ -> if isJust dataURI then
61 -- <a href="data:application/zip;base64,...">
64 returnA -< [ Paragraph [ Anchor
65 [("href", show dataURI)]
71 returnA -< [ Preformatted [Text $ fromJust textData] ]
73 binToURI :: MIMEType -> String -> URI
74 binToURI pType base64Data
77 , uriPath = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
80 stripWhiteSpace :: String -> String
81 stripWhiteSpace [] = []
82 stripWhiteSpace (x:xs)
83 | x `elem` " \t\n" = stripWhiteSpace xs
84 | otherwise = x : stripWhiteSpace xs
87 wikifyBin :: (ArrowXml a, ArrowChoice a) => InterpTable -> a (MIMEType, Lazy.ByteString) WikiPage
90 -> do let text = UTF8.decode $ Lazy.unpack pBin
91 dataURI = binToURI pType pBin
94 MIMEType "text" "x-rakka" _
95 -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
96 Left err -> wikifyParseError -< err
97 Right xs -> returnA -< xs
100 -- <img src="data:image/png;base64,..." />
101 -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
105 -- <a href="data:application/zip;base64,...">
106 -- application/zip (19372 bytes)
108 -> returnA -< [ Paragraph [ Anchor
109 [("href", show dataURI)]
112 show (Lazy.length pBin) ++
117 binToURI :: MIMEType -> Lazy.ByteString -> URI
121 , uriPath = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b)
125 cmdTypeOf :: InterpTable -> String -> Maybe CommandType
126 cmdTypeOf interpTable name
127 = fmap commandType (M.lookup name interpTable)
130 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
135 makeMainXHTML sto sysConf interpTable
137 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
138 wiki <- wikifyPage interpTable -< tree
139 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
140 interpreted <- interpretCommands sto sysConf interpTable
141 -< (Just pName, Just tree, Just wiki, wiki)
142 formatWikiBlocks -< (baseURI, interpreted)
145 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
149 -> a (Maybe PageName, Maybe XmlTree, XmlTree) XmlTree
150 makeSubXHTML sto sysConf interpTable
151 = proc (mainPageName, mainPage, subPage)
152 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
153 mainWiki <- case mainPage of
155 -> do wiki <- wikifyPage interpTable -< page
156 returnA -< Just (page, wiki)
158 -> returnA -< Nothing
159 subWiki <- wikifyPage interpTable -< subPage
160 interpreted <- interpretCommands sto sysConf interpTable
161 -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
162 formatWikiBlocks -< (baseURI, interpreted)
165 makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
169 -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
170 makePreviewXHTML sto sysConf interpTable
171 = proc (name, pageType, pageBin)
172 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
173 wiki <- wikifyBin interpTable -< (pageType, pageBin)
174 interpreted <- interpretCommands sto sysConf interpTable
175 -< (Just name, Nothing, Just wiki, wiki)
176 formatWikiBlocks -< (baseURI, interpreted)
179 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
183 -> a (Maybe PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
184 interpretCommands sto sysConf interpTable
185 = proc (name, mainPage, mainWiki, targetWiki)
186 -> let ctx = InterpreterContext {
188 , ctxMainPage = mainPage
189 , ctxMainWiki = mainWiki
190 , ctxTargetWiki = targetWiki
192 , ctxSysConf = sysConf
195 arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
197 interpElem :: InterpreterContext -> Element -> IO Element
198 interpElem ctx (Block b) = interpBlock ctx b >>= return . Block
199 interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
201 interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
202 interpBlock ctx (List lType lItems) = mapM (interpListItem ctx) lItems >>= return . List lType
203 interpBlock ctx (DefinitionList defs) = mapM (interpDefinition ctx) defs >>= return . DefinitionList
204 interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
205 interpBlock ctx (Paragraph inlines) = mapM (interpInline ctx) inlines >>= return . Paragraph
206 interpBlock ctx (Div attrs elems) = mapM (interpElem ctx) elems >>= return . Div attrs
207 interpBlock ctx (BlockCmd bcmd) = interpBlockCommand ctx bcmd
208 interpBlock _ x = return x
210 interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
211 interpInline ctx (Italic inlines) = mapM (interpInline ctx) inlines >>= return . Italic
212 interpInline ctx (Bold inlines) = mapM (interpInline ctx) inlines >>= return . Bold
213 interpInline ctx (Span attrs inlines) = mapM (interpInline ctx) inlines >>= return . Span attrs
214 interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
215 interpInline ctx (InlineCmd icmd) = interpInlineCommand ctx icmd
216 interpInline _ x = return x
218 interpListItem :: InterpreterContext -> ListItem -> IO ListItem
219 interpListItem = mapM . interpElem
221 interpDefinition :: InterpreterContext -> Definition -> IO Definition
222 interpDefinition ctx (Definition term desc)
223 = do term' <- mapM (interpInline ctx) term
224 desc' <- mapM (interpInline ctx) desc
225 return (Definition term' desc')
227 interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
228 interpBlockCommand ctx cmd
229 = case M.lookup (bCmdName cmd) interpTable of
231 -> fail ("no such interpreter: " ++ bCmdName cmd)
234 -> bciInterpret interp ctx cmd
238 interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
239 interpInlineCommand ctx cmd
240 = case M.lookup (iCmdName cmd) interpTable of
242 -> fail ("no such interpreter: " ++ iCmdName cmd)
245 -> iciInterpret interp ctx cmd
250 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
251 makeDraft interpTable
253 do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
255 Nothing -> makeEntityDraft -< tree
256 Just _ -> makeRedirectDraft -< tree
258 makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
261 do doc <- arrIO0 newDocument -< ()
263 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
264 pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree
265 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
266 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
267 pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree
268 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
269 pLang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
270 pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree
271 pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree
272 pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree
274 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
275 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
276 arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType)
277 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
278 arrIO2 (flip setAttribute "@lang" ) -< (doc, pLang)
279 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
280 arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
281 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
282 arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
284 arrIO2 addHiddenText -< (doc, pName)
287 Just s -> arrIO2 addHiddenText -< (doc, s)
288 Nothing -> returnA -< ()
290 -- otherLang はリンク先ページ名を hidden text で入れる。
291 otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
292 listA ( (arr fst &&& arrL snd)
297 ) -< (doc, otherLangs)
300 MIMEType "text" "css" _
301 -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
303 MIMEType "text" "x-rakka" _
304 -- wikify して興味のある部分を addText する。
305 -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
306 wiki <- wikifyPage interpTable -< tree
307 arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
314 makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
317 do doc <- arrIO0 newDocument -< ()
319 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
320 pRedir <- getXPathTreesInDoc "/page/@redirect/text()" >>> getText -< tree
321 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
322 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
323 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
325 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
326 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
327 arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection")
328 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
329 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
330 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
332 -- リダイレクト先ページ名はテキストとして入れる
333 arrIO2 addText -< (doc, pRedir)
337 addElemText :: Document -> Element -> IO ()
338 addElemText doc (Block b) = addBlockText doc b
339 addElemText doc (Inline i) = addInlineText doc i
341 addBlockText :: Document -> BlockElement -> IO ()
342 addBlockText doc (Heading _ text) = addText doc text
343 addBlockText _ HorizontalLine = return ()
344 addBlockText doc (List _ items) = mapM_ (addListItemText doc) items
345 addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs
346 addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
347 addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines
348 addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems
349 addBlockText _ EmptyBlock = return ()
350 addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd
352 addInlineText :: Document -> InlineElement -> IO ()
353 addInlineText doc (Text text) = addText doc text
354 addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines
355 addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines
356 addInlineText doc (ObjectLink page Nothing) = addText doc page
357 addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page
359 addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
360 addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
362 addInlineText doc (ExternalLink uri Nothing) = addText doc (uriToString id uri "")
363 addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (uriToString id uri "")
365 addInlineText _ (LineBreak _) = return ()
366 addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines
367 addInlineText doc (Image src alt) = do case src of
368 Left uri -> addHiddenText doc (uriToString id uri "")
369 Right page -> addHiddenText doc page
371 Just text -> addHiddenText doc text
373 addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines
374 addInlineText _ (Input _) = return ()
375 addInlineText _ EmptyInline = return ()
376 addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
378 addListItemText :: Document -> ListItem -> IO ()
379 addListItemText = mapM_ . addElemText
381 addDefinitionText :: Document -> Definition -> IO ()
382 addDefinitionText doc (Definition term desc)
383 = do mapM_ (addInlineText doc) term
384 mapM_ (addInlineText doc) desc
386 addBlockCmdText :: Document -> BlockCommand -> IO ()
387 addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
389 addInlineCmdText :: Document -> InlineCommand -> IO ()
390 addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
393 makePageLinkList :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
397 -> a XmlTree [PageName]
398 makePageLinkList sto sysConf interpTable
400 -> do wiki <- wikifyPage interpTable -< tree
401 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
402 interpreted <- interpretCommands sto sysConf interpTable
403 -< (Just pName, Just tree, Just wiki, wiki)
404 returnA -< concatMap extractFromBlock interpreted
406 extractFromElem :: Element -> [PageName]
407 extractFromElem (Block b) = extractFromBlock b
408 extractFromElem (Inline i) = extractFromInline i
410 extractFromBlock :: BlockElement -> [PageName]
411 extractFromBlock (List _ items) = concatMap extractFromListItem items
412 extractFromBlock (DefinitionList defs) = concatMap extractFromDefinition defs
413 extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines
414 extractFromBlock (Paragraph inlines) = concatMap extractFromInline inlines
415 extractFromBlock (Div _ elems) = concatMap extractFromElem elems
416 extractFromBlock _ = []
418 extractFromInline :: InlineElement -> [PageName]
419 extractFromInline (Italic inlines) = concatMap extractFromInline inlines
420 extractFromInline (Bold inlines) = concatMap extractFromInline inlines
421 extractFromInline (Span _ inlines) = concatMap extractFromInline inlines
422 extractFromInline (PageLink (Just name) _ _) = [name]
423 extractFromInline _ = []
425 extractFromListItem :: ListItem -> [PageName]
426 extractFromListItem = concatMap extractFromElem
428 extractFromDefinition :: Definition -> [PageName]
429 extractFromDefinition (Definition term desc)
430 = concatMap extractFromInline term
432 concatMap extractFromInline desc
435 wikifyParseError :: Arrow a => a ParseError WikiPage
436 wikifyParseError = proc err
437 -> returnA -< [Div [("class", "error")]
438 [ Block (Preformatted [Text (show err)]) ]]