1 module Rakka.Wiki.Engine
11 import qualified Codec.Binary.Base64 as B64
12 import qualified Codec.Binary.UTF8.String as UTF8
14 import Control.Arrow.ArrowIO
15 import Control.Arrow.ArrowList
16 import qualified Data.ByteString.Lazy as Lazy
18 import qualified Data.Map as M
20 import Network.HTTP.Lucu
24 import Rakka.SystemConfig
27 import Rakka.Wiki.Parser
28 import Rakka.Wiki.Formatter
29 import Rakka.Wiki.Interpreter
30 import Text.HyperEstraier hiding (getText)
31 import Text.ParserCombinators.Parsec
32 import Text.XML.HXT.Arrow.XmlArrow hiding (err)
33 import Text.XML.HXT.Arrow.XmlNodeSet
34 import Text.XML.HXT.DOM.TypeDefs
37 type InterpTable = Map String Interpreter
40 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
41 wikifyPage interpTable
43 -> do pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
44 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
45 base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
47 let dataURI = fmap (binToURI pType) base64Data
50 MIMEType "text" "x-rakka" _
51 -> case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
52 Left err -> wikifyParseError -< err
53 Right xs -> returnA -< xs
56 -- <img src="data:image/png;base64,..." />
57 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
59 _ -> if isJust dataURI then
60 -- <a href="data:application/zip;base64,...">
63 returnA -< [ Paragraph [ Anchor
64 [("href", show dataURI)]
70 returnA -< [ Preformatted [Text $ fromJust textData] ]
72 binToURI :: MIMEType -> String -> URI
73 binToURI pType base64Data
76 , uriPath = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
79 stripWhiteSpace :: String -> String
80 stripWhiteSpace [] = []
81 stripWhiteSpace (x:xs)
82 | x `elem` " \t\n" = stripWhiteSpace xs
83 | otherwise = x : stripWhiteSpace xs
86 wikifyBin :: (ArrowXml a, ArrowChoice a) => InterpTable -> a (MIMEType, Lazy.ByteString) WikiPage
89 -> do let text = UTF8.decode $ Lazy.unpack pBin
90 dataURI = binToURI pType pBin
93 MIMEType "text" "x-rakka" _
94 -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
95 Left err -> wikifyParseError -< err
96 Right xs -> returnA -< xs
99 -- <img src="data:image/png;base64,..." />
100 -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
104 -- <a href="data:application/zip;base64,...">
105 -- application/zip (19372 bytes)
107 -> returnA -< [ Paragraph [ Anchor
108 [("href", show dataURI)]
111 show (Lazy.length pBin) ++
116 binToURI :: MIMEType -> Lazy.ByteString -> URI
120 , uriPath = show m ++ ";base64," ++ B64.encode (Lazy.unpack b)
124 cmdTypeOf :: InterpTable -> String -> Maybe CommandType
125 cmdTypeOf interpTable name
126 = fmap commandType (M.lookup name interpTable)
129 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
134 makeMainXHTML sto sysConf interpTable
136 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
137 wiki <- wikifyPage interpTable -< tree
138 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
139 interpreted <- interpretCommands sto sysConf interpTable
140 -< (Just pName, Just tree, Just wiki, wiki)
141 formatWikiBlocks -< (baseURI, interpreted)
144 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
148 -> a (Maybe PageName, Maybe XmlTree, XmlTree) XmlTree
149 makeSubXHTML sto sysConf interpTable
150 = proc (mainPageName, mainPage, subPage)
151 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
152 mainWiki <- case mainPage of
154 -> do wiki <- wikifyPage interpTable -< page
155 returnA -< Just (page, wiki)
157 -> returnA -< Nothing
158 subWiki <- wikifyPage interpTable -< subPage
159 interpreted <- interpretCommands sto sysConf interpTable
160 -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
161 formatWikiBlocks -< (baseURI, interpreted)
164 makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
168 -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
169 makePreviewXHTML sto sysConf interpTable
170 = proc (name, pageType, pageBin)
171 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
172 wiki <- wikifyBin interpTable -< (pageType, pageBin)
173 interpreted <- interpretCommands sto sysConf interpTable
174 -< (Just name, Nothing, Just wiki, wiki)
175 formatWikiBlocks -< (baseURI, interpreted)
178 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
182 -> a (Maybe PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
183 interpretCommands sto sysConf interpTable
184 = proc (name, mainPage, mainWiki, targetWiki)
185 -> let ctx = InterpreterContext {
187 , ctxMainPage = mainPage
188 , ctxMainWiki = mainWiki
189 , ctxTargetWiki = targetWiki
191 , ctxSysConf = sysConf
194 arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
196 interpElem :: InterpreterContext -> Element -> IO Element
197 interpElem ctx (Block b) = interpBlock ctx b >>= return . Block
198 interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
200 interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
201 interpBlock ctx (List lType lItems) = mapM (interpListItem ctx) lItems >>= return . List lType
202 interpBlock ctx (DefinitionList defs) = mapM (interpDefinition ctx) defs >>= return . DefinitionList
203 interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
204 interpBlock ctx (Paragraph inlines) = mapM (interpInline ctx) inlines >>= return . Paragraph
205 interpBlock ctx (Div attrs elems) = mapM (interpElem ctx) elems >>= return . Div attrs
206 interpBlock ctx (BlockCmd bcmd) = interpBlockCommand ctx bcmd
207 interpBlock _ x = return x
209 interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
210 interpInline ctx (Italic inlines) = mapM (interpInline ctx) inlines >>= return . Italic
211 interpInline ctx (Bold inlines) = mapM (interpInline ctx) inlines >>= return . Bold
212 interpInline ctx (Span attrs inlines) = mapM (interpInline ctx) inlines >>= return . Span attrs
213 interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
214 interpInline ctx (InlineCmd icmd) = interpInlineCommand ctx icmd
215 interpInline _ x = return x
217 interpListItem :: InterpreterContext -> ListItem -> IO ListItem
218 interpListItem = mapM . interpElem
220 interpDefinition :: InterpreterContext -> Definition -> IO Definition
221 interpDefinition ctx (Definition term desc)
222 = do term' <- mapM (interpInline ctx) term
223 desc' <- mapM (interpInline ctx) desc
224 return (Definition term' desc')
226 interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
227 interpBlockCommand ctx cmd
228 = case M.lookup (bCmdName cmd) interpTable of
230 -> fail ("no such interpreter: " ++ bCmdName cmd)
233 -> bciInterpret interp ctx cmd
237 interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
238 interpInlineCommand ctx cmd
239 = case M.lookup (iCmdName cmd) interpTable of
241 -> fail ("no such interpreter: " ++ iCmdName cmd)
244 -> iciInterpret interp ctx cmd
249 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
250 makeDraft interpTable
252 do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
254 Nothing -> makeEntityDraft -< tree
255 Just _ -> makeRedirectDraft -< tree
257 makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
260 do doc <- arrIO0 newDocument -< ()
262 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
263 pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree
264 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
265 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
266 pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree
267 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
268 pLang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
269 pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree
270 pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree
271 pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree
273 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
274 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
275 arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType)
276 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
277 arrIO2 (flip setAttribute "@lang" ) -< (doc, pLang)
278 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
279 arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
280 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
281 arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
283 arrIO2 addHiddenText -< (doc, pName)
286 Just s -> arrIO2 addHiddenText -< (doc, s)
287 Nothing -> returnA -< ()
289 -- otherLang はリンク先ページ名を hidden text で入れる。
290 otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
291 listA ( (arr fst &&& arrL snd)
296 ) -< (doc, otherLangs)
299 MIMEType "text" "css" _
300 -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
302 MIMEType "text" "x-rakka" _
303 -- wikify して興味のある部分を addText する。
304 -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
305 wiki <- wikifyPage interpTable -< tree
306 arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
313 makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
316 do doc <- arrIO0 newDocument -< ()
318 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
319 pRedir <- getXPathTreesInDoc "/page/@redirect/text()" >>> getText -< tree
320 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
321 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
322 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
324 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
325 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
326 arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection")
327 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
328 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
329 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
331 -- リダイレクト先ページ名はテキストとして入れる
332 arrIO2 addText -< (doc, pRedir)
336 addElemText :: Document -> Element -> IO ()
337 addElemText doc (Block b) = addBlockText doc b
338 addElemText doc (Inline i) = addInlineText doc i
340 addBlockText :: Document -> BlockElement -> IO ()
341 addBlockText doc (Heading _ text) = addText doc text
342 addBlockText _ HorizontalLine = return ()
343 addBlockText doc (List _ items) = mapM_ (addListItemText doc) items
344 addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs
345 addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
346 addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines
347 addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems
348 addBlockText _ EmptyBlock = return ()
349 addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd
351 addInlineText :: Document -> InlineElement -> IO ()
352 addInlineText doc (Text text) = addText doc text
353 addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines
354 addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines
355 addInlineText doc (ObjectLink page Nothing) = addText doc page
356 addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page
358 addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
359 addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
361 addInlineText doc (ExternalLink uri Nothing) = addText doc (uriToString id uri "")
362 addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (uriToString id uri "")
364 addInlineText _ (LineBreak _) = return ()
365 addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines
366 addInlineText doc (Image src alt) = do case src of
367 Left uri -> addHiddenText doc (uriToString id uri "")
368 Right page -> addHiddenText doc page
370 Just text -> addHiddenText doc text
372 addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines
373 addInlineText _ (Input _) = return ()
374 addInlineText _ EmptyInline = return ()
375 addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
377 addListItemText :: Document -> ListItem -> IO ()
378 addListItemText = mapM_ . addElemText
380 addDefinitionText :: Document -> Definition -> IO ()
381 addDefinitionText doc (Definition term desc)
382 = do mapM_ (addInlineText doc) term
383 mapM_ (addInlineText doc) desc
385 addBlockCmdText :: Document -> BlockCommand -> IO ()
386 addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
388 addInlineCmdText :: Document -> InlineCommand -> IO ()
389 addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
392 makePageLinkList :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
396 -> a XmlTree [PageName]
397 makePageLinkList sto sysConf interpTable
399 -> do wiki <- wikifyPage interpTable -< tree
400 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
401 interpreted <- interpretCommands sto sysConf interpTable
402 -< (Just pName, Just tree, Just wiki, wiki)
403 returnA -< concatMap extractFromBlock interpreted
405 extractFromElem :: Element -> [PageName]
406 extractFromElem (Block b) = extractFromBlock b
407 extractFromElem (Inline i) = extractFromInline i
409 extractFromBlock :: BlockElement -> [PageName]
410 extractFromBlock (List _ items) = concatMap extractFromListItem items
411 extractFromBlock (DefinitionList defs) = concatMap extractFromDefinition defs
412 extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines
413 extractFromBlock (Paragraph inlines) = concatMap extractFromInline inlines
414 extractFromBlock (Div _ elems) = concatMap extractFromElem elems
415 extractFromBlock _ = []
417 extractFromInline :: InlineElement -> [PageName]
418 extractFromInline (Italic inlines) = concatMap extractFromInline inlines
419 extractFromInline (Bold inlines) = concatMap extractFromInline inlines
420 extractFromInline (Span _ inlines) = concatMap extractFromInline inlines
421 extractFromInline (PageLink (Just name) _ _) = [name]
422 extractFromInline _ = []
424 extractFromListItem :: ListItem -> [PageName]
425 extractFromListItem = concatMap extractFromElem
427 extractFromDefinition :: Definition -> [PageName]
428 extractFromDefinition (Definition term desc)
429 = concatMap extractFromInline term
431 concatMap extractFromInline desc
434 wikifyParseError :: Arrow a => a ParseError WikiPage
435 wikifyParseError = proc err
436 -> returnA -< [Div [("class", "error")]
437 [ Block (Preformatted [Text (show err)]) ]]