1 module Rakka.Wiki.Engine
10 import qualified Data.ByteString.Lazy as Lazy
11 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
13 import qualified Data.Map as M
15 import Network.HTTP.Lucu
17 import OpenSSL.EVP.Base64
20 import Rakka.SystemConfig
23 import Rakka.Wiki.Parser
24 import Rakka.Wiki.Formatter
25 import Rakka.Wiki.Interpreter
26 import Text.HyperEstraier hiding (getText)
27 import Text.ParserCombinators.Parsec
28 import Text.XML.HXT.XPath
31 type InterpTable = Map String Interpreter
34 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
35 wikifyPage interpTable
37 -> do pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
38 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
39 base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
41 let dataURI = fmap (binToURI pType) base64Data
44 MIMEType "text" "x-rakka" _
45 -> case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
46 Left err -> wikifyParseError -< err
47 Right xs -> returnA -< xs
50 -- <img src="data:image/png;base64,..." />
51 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
53 _ -> if isJust dataURI then
54 -- <a href="data:application/zip;base64,...">
57 returnA -< [ Paragraph [ Anchor
58 [("href", show dataURI)]
64 returnA -< [ Preformatted [Text $ fromJust textData] ]
66 binToURI :: MIMEType -> String -> URI
67 binToURI pType base64Data
70 , uriPath = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
73 stripWhiteSpace :: String -> String
74 stripWhiteSpace [] = []
75 stripWhiteSpace (x:xs)
76 | x `elem` " \t\n" = stripWhiteSpace xs
77 | otherwise = x : stripWhiteSpace xs
80 wikifyBin :: (ArrowXml a, ArrowChoice a) => InterpTable -> a (MIMEType, Lazy.ByteString) WikiPage
83 -> do let text = UTF8.decode $ Lazy.unpack pBin
84 dataURI = binToURI pType pBin
87 MIMEType "text" "x-rakka" _
88 -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
89 Left err -> wikifyParseError -< err
90 Right xs -> returnA -< xs
93 -- <img src="data:image/png;base64,..." />
94 -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
98 -- <a href="data:application/zip;base64,...">
99 -- application/zip (19372 bytes)
101 -> returnA -< [ Paragraph [ Anchor
102 [("href", show dataURI)]
105 show (Lazy.length pBin) ++
110 binToURI :: MIMEType -> Lazy.ByteString -> URI
114 , uriPath = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b)
118 cmdTypeOf :: InterpTable -> String -> Maybe CommandType
119 cmdTypeOf interpTable name
120 = fmap commandType (M.lookup name interpTable)
123 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
128 makeMainXHTML sto sysConf interpTable
130 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
131 wiki <- wikifyPage interpTable -< tree
132 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
133 interpreted <- interpretCommands sto sysConf interpTable
134 -< (Just pName, Just tree, Just wiki, wiki)
135 formatWikiBlocks -< (baseURI, interpreted)
138 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
142 -> a (Maybe PageName, Maybe XmlTree, XmlTree) XmlTree
143 makeSubXHTML sto sysConf interpTable
144 = proc (mainPageName, mainPage, subPage)
145 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
146 mainWiki <- case mainPage of
148 -> do wiki <- wikifyPage interpTable -< page
149 returnA -< Just (page, wiki)
151 -> returnA -< Nothing
152 subWiki <- wikifyPage interpTable -< subPage
153 interpreted <- interpretCommands sto sysConf interpTable
154 -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
155 formatWikiBlocks -< (baseURI, interpreted)
158 makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
162 -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
163 makePreviewXHTML sto sysConf interpTable
164 = proc (name, pageType, pageBin)
165 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
166 wiki <- wikifyBin interpTable -< (pageType, pageBin)
167 interpreted <- interpretCommands sto sysConf interpTable
168 -< (Just name, Nothing, Just wiki, wiki)
169 formatWikiBlocks -< (baseURI, interpreted)
172 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
176 -> a (Maybe PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
177 interpretCommands sto sysConf interpTable
178 = proc (name, mainPage, mainWiki, targetWiki)
179 -> let ctx = InterpreterContext {
181 , ctxMainPage = mainPage
182 , ctxMainWiki = mainWiki
183 , ctxTargetWiki = targetWiki
185 , ctxSysConf = sysConf
188 arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
190 interpElem :: InterpreterContext -> Element -> IO Element
191 interpElem ctx (Block b) = interpBlock ctx b >>= return . Block
192 interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
194 interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
195 interpBlock ctx (List lType lItems) = mapM (interpListItem ctx) lItems >>= return . List lType
196 interpBlock ctx (DefinitionList defs) = mapM (interpDefinition ctx) defs >>= return . DefinitionList
197 interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
198 interpBlock ctx (Paragraph inlines) = mapM (interpInline ctx) inlines >>= return . Paragraph
199 interpBlock ctx (Div attrs elems) = mapM (interpElem ctx) elems >>= return . Div attrs
200 interpBlock ctx (BlockCmd bcmd) = interpBlockCommand ctx bcmd
201 interpBlock _ x = return x
203 interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
204 interpInline ctx (Italic inlines) = mapM (interpInline ctx) inlines >>= return . Italic
205 interpInline ctx (Bold inlines) = mapM (interpInline ctx) inlines >>= return . Bold
206 interpInline ctx (Span attrs inlines) = mapM (interpInline ctx) inlines >>= return . Span attrs
207 interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
208 interpInline ctx (InlineCmd icmd) = interpInlineCommand ctx icmd
209 interpInline _ x = return x
211 interpListItem :: InterpreterContext -> ListItem -> IO ListItem
212 interpListItem = mapM . interpElem
214 interpDefinition :: InterpreterContext -> Definition -> IO Definition
215 interpDefinition ctx (Definition term desc)
216 = do term' <- mapM (interpInline ctx) term
217 desc' <- mapM (interpInline ctx) desc
218 return (Definition term' desc')
220 interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
221 interpBlockCommand ctx cmd
222 = case M.lookup (bCmdName cmd) interpTable of
224 -> fail ("no such interpreter: " ++ bCmdName cmd)
227 -> bciInterpret interp ctx cmd
231 interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
232 interpInlineCommand ctx cmd
233 = case M.lookup (iCmdName cmd) interpTable of
235 -> fail ("no such interpreter: " ++ iCmdName cmd)
238 -> iciInterpret interp ctx cmd
243 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
244 makeDraft interpTable
246 do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
248 Nothing -> makeEntityDraft -< tree
249 Just _ -> makeRedirectDraft -< tree
251 makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
254 do doc <- arrIO0 newDocument -< ()
256 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
257 pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree
258 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
259 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
260 pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree
261 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
262 pLang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
263 pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree
264 pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree
265 pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree
267 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
268 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
269 arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType)
270 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
271 arrIO2 (flip setAttribute "@lang" ) -< (doc, pLang)
272 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
273 arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
274 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
275 arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
277 arrIO2 addHiddenText -< (doc, pName)
280 Just s -> arrIO2 addHiddenText -< (doc, s)
281 Nothing -> returnA -< ()
283 -- otherLang はリンク先ページ名を hidden text で入れる。
284 otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
285 listA ( (arr fst &&& arrL snd)
290 ) -< (doc, otherLangs)
293 MIMEType "text" "css" _
294 -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
296 MIMEType "text" "x-rakka" _
297 -- wikify して興味のある部分を addText する。
298 -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
299 wiki <- wikifyPage interpTable -< tree
300 arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
307 makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
310 do doc <- arrIO0 newDocument -< ()
312 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
313 pRedir <- getXPathTreesInDoc "/page/@redirect/text()" >>> getText -< tree
314 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
315 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
316 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
318 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
319 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
320 arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection")
321 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
322 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
323 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
325 -- リダイレクト先ページ名はテキストとして入れる
326 arrIO2 addText -< (doc, pRedir)
330 addElemText :: Document -> Element -> IO ()
331 addElemText doc (Block b) = addBlockText doc b
332 addElemText doc (Inline i) = addInlineText doc i
334 addBlockText :: Document -> BlockElement -> IO ()
335 addBlockText doc (Heading _ text) = addText doc text
336 addBlockText _ HorizontalLine = return ()
337 addBlockText doc (List _ items) = mapM_ (addListItemText doc) items
338 addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs
339 addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
340 addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines
341 addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems
342 addBlockText _ EmptyBlock = return ()
343 addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd
345 addInlineText :: Document -> InlineElement -> IO ()
346 addInlineText doc (Text text) = addText doc text
347 addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines
348 addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines
349 addInlineText doc (ObjectLink page Nothing) = addText doc page
350 addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page
352 addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
353 addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
355 addInlineText doc (ExternalLink uri Nothing) = addText doc (uriToString id uri "")
356 addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (uriToString id uri "")
358 addInlineText _ (LineBreak _) = return ()
359 addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines
360 addInlineText doc (Image src alt) = do case src of
361 Left uri -> addHiddenText doc (uriToString id uri "")
362 Right page -> addHiddenText doc page
364 Just text -> addHiddenText doc text
366 addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines
367 addInlineText _ (Input _) = return ()
368 addInlineText _ EmptyInline = return ()
369 addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
371 addListItemText :: Document -> ListItem -> IO ()
372 addListItemText = mapM_ . addElemText
374 addDefinitionText :: Document -> Definition -> IO ()
375 addDefinitionText doc (Definition term desc)
376 = do mapM_ (addInlineText doc) term
377 mapM_ (addInlineText doc) desc
379 addBlockCmdText :: Document -> BlockCommand -> IO ()
380 addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
382 addInlineCmdText :: Document -> InlineCommand -> IO ()
383 addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
386 makePageLinkList :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
390 -> a XmlTree [PageName]
391 makePageLinkList sto sysConf interpTable
393 -> do wiki <- wikifyPage interpTable -< tree
394 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
395 interpreted <- interpretCommands sto sysConf interpTable
396 -< (Just pName, Just tree, Just wiki, wiki)
397 returnA -< concatMap extractFromBlock interpreted
399 extractFromElem :: Element -> [PageName]
400 extractFromElem (Block b) = extractFromBlock b
401 extractFromElem (Inline i) = extractFromInline i
403 extractFromBlock :: BlockElement -> [PageName]
404 extractFromBlock (List _ items) = concatMap extractFromListItem items
405 extractFromBlock (DefinitionList defs) = concatMap extractFromDefinition defs
406 extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines
407 extractFromBlock (Paragraph inlines) = concatMap extractFromInline inlines
408 extractFromBlock (Div _ elems) = concatMap extractFromElem elems
409 extractFromBlock _ = []
411 extractFromInline :: InlineElement -> [PageName]
412 extractFromInline (Italic inlines) = concatMap extractFromInline inlines
413 extractFromInline (Bold inlines) = concatMap extractFromInline inlines
414 extractFromInline (Span _ inlines) = concatMap extractFromInline inlines
415 extractFromInline (PageLink (Just name) _ _) = [name]
416 extractFromInline _ = []
418 extractFromListItem :: ListItem -> [PageName]
419 extractFromListItem = concatMap extractFromElem
421 extractFromDefinition :: Definition -> [PageName]
422 extractFromDefinition (Definition term desc)
423 = concatMap extractFromInline term
425 concatMap extractFromInline desc
428 wikifyParseError :: Arrow a => a ParseError WikiPage
429 wikifyParseError = proc err
430 -> returnA -< [Div [("class", "error")]
431 [ Block (Preformatted [Text (show err)]) ]]