1 module Rakka.Wiki.Engine
11 import qualified Codec.Binary.UTF8.String as UTF8
12 import qualified Data.ByteString.Lazy as Lazy
13 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
15 import qualified Data.Map as M
17 import Network.HTTP.Lucu
19 import OpenSSL.EVP.Base64
22 import Rakka.SystemConfig
25 import Rakka.Wiki.Parser
26 import Rakka.Wiki.Formatter
27 import Rakka.Wiki.Interpreter
28 import Text.HyperEstraier hiding (getText)
29 import Text.ParserCombinators.Parsec
30 import Text.XML.HXT.Arrow hiding (err)
31 import Text.XML.HXT.XPath
34 type InterpTable = Map String Interpreter
37 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
38 wikifyPage interpTable
40 -> do pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
41 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
42 base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
44 let dataURI = fmap (binToURI pType) base64Data
47 MIMEType "text" "x-rakka" _
48 -> case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
49 Left err -> wikifyParseError -< err
50 Right xs -> returnA -< xs
53 -- <img src="data:image/png;base64,..." />
54 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
56 _ -> if isJust dataURI then
57 -- <a href="data:application/zip;base64,...">
60 returnA -< [ Paragraph [ Anchor
61 [("href", show dataURI)]
67 returnA -< [ Preformatted [Text $ fromJust textData] ]
69 binToURI :: MIMEType -> String -> URI
70 binToURI pType base64Data
73 , uriPath = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
76 stripWhiteSpace :: String -> String
77 stripWhiteSpace [] = []
78 stripWhiteSpace (x:xs)
79 | x `elem` " \t\n" = stripWhiteSpace xs
80 | otherwise = x : stripWhiteSpace xs
83 wikifyBin :: (ArrowXml a, ArrowChoice a) => InterpTable -> a (MIMEType, Lazy.ByteString) WikiPage
86 -> do let text = UTF8.decode $ Lazy.unpack pBin
87 dataURI = binToURI pType pBin
90 MIMEType "text" "x-rakka" _
91 -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
92 Left err -> wikifyParseError -< err
93 Right xs -> returnA -< xs
96 -- <img src="data:image/png;base64,..." />
97 -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
101 -- <a href="data:application/zip;base64,...">
102 -- application/zip (19372 bytes)
104 -> returnA -< [ Paragraph [ Anchor
105 [("href", show dataURI)]
108 show (Lazy.length pBin) ++
113 binToURI :: MIMEType -> Lazy.ByteString -> URI
117 , uriPath = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b)
121 cmdTypeOf :: InterpTable -> String -> Maybe CommandType
122 cmdTypeOf interpTable name
123 = fmap commandType (M.lookup name interpTable)
126 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
131 makeMainXHTML sto sysConf interpTable
133 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
134 wiki <- wikifyPage interpTable -< tree
135 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
136 interpreted <- interpretCommands sto sysConf interpTable
137 -< (Just pName, Just tree, Just wiki, wiki)
138 formatWikiBlocks -< (baseURI, interpreted)
141 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
145 -> a (Maybe PageName, Maybe XmlTree, XmlTree) XmlTree
146 makeSubXHTML sto sysConf interpTable
147 = proc (mainPageName, mainPage, subPage)
148 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
149 mainWiki <- case mainPage of
151 -> do wiki <- wikifyPage interpTable -< page
152 returnA -< Just (page, wiki)
154 -> returnA -< Nothing
155 subWiki <- wikifyPage interpTable -< subPage
156 interpreted <- interpretCommands sto sysConf interpTable
157 -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
158 formatWikiBlocks -< (baseURI, interpreted)
161 makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
165 -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
166 makePreviewXHTML sto sysConf interpTable
167 = proc (name, pageType, pageBin)
168 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
169 wiki <- wikifyBin interpTable -< (pageType, pageBin)
170 interpreted <- interpretCommands sto sysConf interpTable
171 -< (Just name, Nothing, Just wiki, wiki)
172 formatWikiBlocks -< (baseURI, interpreted)
175 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
179 -> a (Maybe PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
180 interpretCommands sto sysConf interpTable
181 = proc (name, mainPage, mainWiki, targetWiki)
182 -> let ctx = InterpreterContext {
184 , ctxMainPage = mainPage
185 , ctxMainWiki = mainWiki
186 , ctxTargetWiki = targetWiki
188 , ctxSysConf = sysConf
191 arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
193 interpElem :: InterpreterContext -> Element -> IO Element
194 interpElem ctx (Block b) = interpBlock ctx b >>= return . Block
195 interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
197 interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
198 interpBlock ctx (List lType lItems) = mapM (interpListItem ctx) lItems >>= return . List lType
199 interpBlock ctx (DefinitionList defs) = mapM (interpDefinition ctx) defs >>= return . DefinitionList
200 interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
201 interpBlock ctx (Paragraph inlines) = mapM (interpInline ctx) inlines >>= return . Paragraph
202 interpBlock ctx (Div attrs elems) = mapM (interpElem ctx) elems >>= return . Div attrs
203 interpBlock ctx (BlockCmd bcmd) = interpBlockCommand ctx bcmd
204 interpBlock _ x = return x
206 interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
207 interpInline ctx (Italic inlines) = mapM (interpInline ctx) inlines >>= return . Italic
208 interpInline ctx (Bold inlines) = mapM (interpInline ctx) inlines >>= return . Bold
209 interpInline ctx (Span attrs inlines) = mapM (interpInline ctx) inlines >>= return . Span attrs
210 interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
211 interpInline ctx (InlineCmd icmd) = interpInlineCommand ctx icmd
212 interpInline _ x = return x
214 interpListItem :: InterpreterContext -> ListItem -> IO ListItem
215 interpListItem = mapM . interpElem
217 interpDefinition :: InterpreterContext -> Definition -> IO Definition
218 interpDefinition ctx (Definition term desc)
219 = do term' <- mapM (interpInline ctx) term
220 desc' <- mapM (interpInline ctx) desc
221 return (Definition term' desc')
223 interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
224 interpBlockCommand ctx cmd
225 = case M.lookup (bCmdName cmd) interpTable of
227 -> fail ("no such interpreter: " ++ bCmdName cmd)
230 -> bciInterpret interp ctx cmd
234 interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
235 interpInlineCommand ctx cmd
236 = case M.lookup (iCmdName cmd) interpTable of
238 -> fail ("no such interpreter: " ++ iCmdName cmd)
241 -> iciInterpret interp ctx cmd
246 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
247 makeDraft interpTable
249 do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
251 Nothing -> makeEntityDraft -< tree
252 Just _ -> makeRedirectDraft -< tree
254 makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
257 do doc <- arrIO0 newDocument -< ()
259 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
260 pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree
261 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
262 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
263 pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree
264 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
265 pLang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
266 pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree
267 pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree
268 pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree
270 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
271 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
272 arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType)
273 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
274 arrIO2 (flip setAttribute "@lang" ) -< (doc, pLang)
275 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
276 arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
277 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
278 arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
280 arrIO2 addHiddenText -< (doc, pName)
283 Just s -> arrIO2 addHiddenText -< (doc, s)
284 Nothing -> returnA -< ()
286 -- otherLang はリンク先ページ名を hidden text で入れる。
287 otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
288 listA ( (arr fst &&& arrL snd)
293 ) -< (doc, otherLangs)
296 MIMEType "text" "css" _
297 -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
299 MIMEType "text" "x-rakka" _
300 -- wikify して興味のある部分を addText する。
301 -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
302 wiki <- wikifyPage interpTable -< tree
303 arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
310 makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
313 do doc <- arrIO0 newDocument -< ()
315 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
316 pRedir <- getXPathTreesInDoc "/page/@redirect/text()" >>> getText -< tree
317 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
318 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
319 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
321 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
322 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
323 arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection")
324 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
325 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
326 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
328 -- リダイレクト先ページ名はテキストとして入れる
329 arrIO2 addText -< (doc, pRedir)
333 addElemText :: Document -> Element -> IO ()
334 addElemText doc (Block b) = addBlockText doc b
335 addElemText doc (Inline i) = addInlineText doc i
337 addBlockText :: Document -> BlockElement -> IO ()
338 addBlockText doc (Heading _ text) = addText doc text
339 addBlockText _ HorizontalLine = return ()
340 addBlockText doc (List _ items) = mapM_ (addListItemText doc) items
341 addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs
342 addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
343 addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines
344 addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems
345 addBlockText _ EmptyBlock = return ()
346 addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd
348 addInlineText :: Document -> InlineElement -> IO ()
349 addInlineText doc (Text text) = addText doc text
350 addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines
351 addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines
352 addInlineText doc (ObjectLink page Nothing) = addText doc page
353 addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page
355 addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
356 addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
358 addInlineText doc (ExternalLink uri Nothing) = addText doc (uriToString id uri "")
359 addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (uriToString id uri "")
361 addInlineText _ (LineBreak _) = return ()
362 addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines
363 addInlineText doc (Image src alt) = do case src of
364 Left uri -> addHiddenText doc (uriToString id uri "")
365 Right page -> addHiddenText doc page
367 Just text -> addHiddenText doc text
369 addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines
370 addInlineText _ (Input _) = return ()
371 addInlineText _ EmptyInline = return ()
372 addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
374 addListItemText :: Document -> ListItem -> IO ()
375 addListItemText = mapM_ . addElemText
377 addDefinitionText :: Document -> Definition -> IO ()
378 addDefinitionText doc (Definition term desc)
379 = do mapM_ (addInlineText doc) term
380 mapM_ (addInlineText doc) desc
382 addBlockCmdText :: Document -> BlockCommand -> IO ()
383 addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
385 addInlineCmdText :: Document -> InlineCommand -> IO ()
386 addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
389 makePageLinkList :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
393 -> a XmlTree [PageName]
394 makePageLinkList sto sysConf interpTable
396 -> do wiki <- wikifyPage interpTable -< tree
397 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
398 interpreted <- interpretCommands sto sysConf interpTable
399 -< (Just pName, Just tree, Just wiki, wiki)
400 returnA -< concatMap extractFromBlock interpreted
402 extractFromElem :: Element -> [PageName]
403 extractFromElem (Block b) = extractFromBlock b
404 extractFromElem (Inline i) = extractFromInline i
406 extractFromBlock :: BlockElement -> [PageName]
407 extractFromBlock (List _ items) = concatMap extractFromListItem items
408 extractFromBlock (DefinitionList defs) = concatMap extractFromDefinition defs
409 extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines
410 extractFromBlock (Paragraph inlines) = concatMap extractFromInline inlines
411 extractFromBlock (Div _ elems) = concatMap extractFromElem elems
412 extractFromBlock _ = []
414 extractFromInline :: InlineElement -> [PageName]
415 extractFromInline (Italic inlines) = concatMap extractFromInline inlines
416 extractFromInline (Bold inlines) = concatMap extractFromInline inlines
417 extractFromInline (Span _ inlines) = concatMap extractFromInline inlines
418 extractFromInline (PageLink (Just name) _ _) = [name]
419 extractFromInline _ = []
421 extractFromListItem :: ListItem -> [PageName]
422 extractFromListItem = concatMap extractFromElem
424 extractFromDefinition :: Definition -> [PageName]
425 extractFromDefinition (Definition term desc)
426 = concatMap extractFromInline term
428 concatMap extractFromInline desc
431 wikifyParseError :: Arrow a => a ParseError WikiPage
432 wikifyParseError = proc err
433 -> returnA -< [Div [("class", "error")]
434 [ Block (Preformatted [Text (show err)]) ]]