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
19 import Rakka.SystemConfig
22 import Rakka.Wiki.Parser
23 import Rakka.Wiki.Formatter
24 import Rakka.Wiki.Interpreter
25 import Text.HyperEstraier hiding (getText)
26 import Text.ParserCombinators.Parsec
27 import Text.XML.HXT.XPath
30 type InterpTable = Map String Interpreter
33 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
34 wikifyPage interpTable
36 -> do pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
37 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
38 base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
40 let dataURI = fmap (binToURI pType) base64Data
43 MIMEType "text" "x-rakka" _
44 -> case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
45 Left err -> wikifyParseError -< err
46 Right xs -> returnA -< xs
49 -- <img src="data:image/png;base64,..." />
50 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
52 _ -> if isJust dataURI then
53 -- <a href="data:application/zip;base64,...">
56 returnA -< [ Paragraph [ Anchor
57 [("href", show dataURI)]
63 returnA -< [ Preformatted [Text $ fromJust textData] ]
65 binToURI :: MIMEType -> String -> URI
66 binToURI pType base64Data
69 , uriPath = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
72 stripWhiteSpace :: String -> String
73 stripWhiteSpace [] = []
74 stripWhiteSpace (x:xs)
75 | x `elem` " \t\n" = stripWhiteSpace xs
76 | otherwise = x : stripWhiteSpace xs
79 wikifyBin :: (ArrowXml a, ArrowChoice a) => InterpTable -> a (MIMEType, Lazy.ByteString) WikiPage
82 -> do let text = UTF8.decode $ Lazy.unpack pBin
83 dataURI = binToURI pType pBin
86 MIMEType "text" "x-rakka" _
87 -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
88 Left err -> wikifyParseError -< err
89 Right xs -> returnA -< xs
92 -- <img src="data:image/png;base64,..." />
93 -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
97 -- <a href="data:application/zip;base64,...">
98 -- application/zip (19372 bytes)
100 -> returnA -< [ Paragraph [ Anchor
101 [("href", show dataURI)]
104 show (Lazy.length pBin) ++
109 binToURI :: MIMEType -> Lazy.ByteString -> URI
113 , uriPath = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b)
117 cmdTypeOf :: InterpTable -> String -> Maybe CommandType
118 cmdTypeOf interpTable name
119 = fmap commandType (M.lookup name interpTable)
122 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
127 makeMainXHTML sto sysConf interpTable
129 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
130 wiki <- wikifyPage interpTable -< tree
131 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
132 interpreted <- interpretCommands sto sysConf interpTable
133 -< (Just pName, Just tree, Just wiki, wiki)
134 formatWikiBlocks -< (baseURI, interpreted)
137 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
141 -> a (Maybe PageName, Maybe XmlTree, XmlTree) XmlTree
142 makeSubXHTML sto sysConf interpTable
143 = proc (mainPageName, mainPage, subPage)
144 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
145 mainWiki <- case mainPage of
147 -> do wiki <- wikifyPage interpTable -< page
148 returnA -< Just (page, wiki)
150 -> returnA -< Nothing
151 subWiki <- wikifyPage interpTable -< subPage
152 interpreted <- interpretCommands sto sysConf interpTable
153 -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
154 formatWikiBlocks -< (baseURI, interpreted)
157 makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
161 -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
162 makePreviewXHTML sto sysConf interpTable
163 = proc (name, pageType, pageBin)
164 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
165 wiki <- wikifyBin interpTable -< (pageType, pageBin)
166 interpreted <- interpretCommands sto sysConf interpTable
167 -< (Just name, Nothing, Just wiki, wiki)
168 formatWikiBlocks -< (baseURI, interpreted)
171 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
175 -> a (Maybe PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
176 interpretCommands sto sysConf interpTable
177 = proc (name, mainPage, mainWiki, targetWiki)
178 -> let ctx = InterpreterContext {
180 , ctxMainPage = mainPage
181 , ctxMainWiki = mainWiki
182 , ctxTargetWiki = targetWiki
184 , ctxSysConf = sysConf
187 arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
189 interpElem :: InterpreterContext -> Element -> IO Element
190 interpElem ctx (Block b) = interpBlock ctx b >>= return . Block
191 interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
193 interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
194 interpBlock ctx (List lType lItems) = mapM (interpListItem ctx) lItems >>= return . List lType
195 interpBlock ctx (DefinitionList defs) = mapM (interpDefinition ctx) defs >>= return . DefinitionList
196 interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
197 interpBlock ctx (Paragraph inlines) = mapM (interpInline ctx) inlines >>= return . Paragraph
198 interpBlock ctx (Div attrs elems) = mapM (interpElem ctx) elems >>= return . Div attrs
199 interpBlock ctx (BlockCmd bcmd) = interpBlockCommand ctx bcmd
200 interpBlock _ x = return x
202 interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
203 interpInline ctx (Italic inlines) = mapM (interpInline ctx) inlines >>= return . Italic
204 interpInline ctx (Bold inlines) = mapM (interpInline ctx) inlines >>= return . Bold
205 interpInline ctx (Span attrs inlines) = mapM (interpInline ctx) inlines >>= return . Span attrs
206 interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
207 interpInline ctx (InlineCmd icmd) = interpInlineCommand ctx icmd
208 interpInline _ x = return x
210 interpListItem :: InterpreterContext -> ListItem -> IO ListItem
211 interpListItem = mapM . interpElem
213 interpDefinition :: InterpreterContext -> Definition -> IO Definition
214 interpDefinition ctx (Definition term desc)
215 = do term' <- mapM (interpInline ctx) term
216 desc' <- mapM (interpInline ctx) desc
217 return (Definition term' desc')
219 interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
220 interpBlockCommand ctx cmd
221 = case M.lookup (bCmdName cmd) interpTable of
223 -> fail ("no such interpreter: " ++ bCmdName cmd)
226 -> bciInterpret interp ctx cmd
230 interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
231 interpInlineCommand ctx cmd
232 = case M.lookup (iCmdName cmd) interpTable of
234 -> fail ("no such interpreter: " ++ iCmdName cmd)
237 -> iciInterpret interp ctx cmd
242 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
243 makeDraft interpTable
245 do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
247 Nothing -> makeEntityDraft -< tree
248 Just _ -> makeRedirectDraft -< tree
250 makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
253 do doc <- arrIO0 newDocument -< ()
255 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
256 pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree
257 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
258 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
259 pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree
260 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
261 pLang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
262 pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree
263 pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree
264 pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree
266 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
267 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
268 arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType)
269 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
270 arrIO2 (flip setAttribute "@lang" ) -< (doc, pLang)
271 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
272 arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
273 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
274 arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
276 arrIO2 addHiddenText -< (doc, pName)
279 Just s -> arrIO2 addHiddenText -< (doc, s)
280 Nothing -> returnA -< ()
282 -- otherLang はリンク先ページ名を hidden text で入れる。
283 otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
284 listA ( (arr fst &&& arrL snd)
289 ) -< (doc, otherLangs)
292 MIMEType "text" "css" _
293 -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
295 MIMEType "text" "x-rakka" _
296 -- wikify して興味のある部分を addText する。
297 -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
298 wiki <- wikifyPage interpTable -< tree
299 arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
306 makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
309 do doc <- arrIO0 newDocument -< ()
311 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
312 pRedir <- getXPathTreesInDoc "/page/@redirect/text()" >>> getText -< tree
313 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
314 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
315 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
317 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
318 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
319 arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection")
320 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
321 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
322 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
324 -- リダイレクト先ページ名はテキストとして入れる
325 arrIO2 addText -< (doc, pRedir)
329 addElemText :: Document -> Element -> IO ()
330 addElemText doc (Block b) = addBlockText doc b
331 addElemText doc (Inline i) = addInlineText doc i
333 addBlockText :: Document -> BlockElement -> IO ()
334 addBlockText doc (Heading _ text) = addText doc text
335 addBlockText _ HorizontalLine = return ()
336 addBlockText doc (List _ items) = mapM_ (addListItemText doc) items
337 addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs
338 addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
339 addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines
340 addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems
341 addBlockText _ EmptyBlock = return ()
342 addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd
344 addInlineText :: Document -> InlineElement -> IO ()
345 addInlineText doc (Text text) = addText doc text
346 addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines
347 addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines
348 addInlineText doc (ObjectLink page Nothing) = addText doc page
349 addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page
351 addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
352 addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
354 addInlineText doc (ExternalLink uri Nothing) = addText doc (uriToString id uri "")
355 addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (uriToString id uri "")
357 addInlineText _ (LineBreak _) = return ()
358 addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines
359 addInlineText doc (Image src alt) = do case src of
360 Left uri -> addHiddenText doc (uriToString id uri "")
361 Right page -> addHiddenText doc page
363 Just text -> addHiddenText doc text
365 addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines
366 addInlineText _ (Input _) = return ()
367 addInlineText _ EmptyInline = return ()
368 addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
370 addListItemText :: Document -> ListItem -> IO ()
371 addListItemText = mapM_ . addElemText
373 addDefinitionText :: Document -> Definition -> IO ()
374 addDefinitionText doc (Definition term desc)
375 = do mapM_ (addInlineText doc) term
376 mapM_ (addInlineText doc) desc
378 addBlockCmdText :: Document -> BlockCommand -> IO ()
379 addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
381 addInlineCmdText :: Document -> InlineCommand -> IO ()
382 addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
385 makePageLinkList :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
389 -> a XmlTree [PageName]
390 makePageLinkList sto sysConf interpTable
392 -> do wiki <- wikifyPage interpTable -< tree
393 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
394 interpreted <- interpretCommands sto sysConf interpTable
395 -< (Just pName, Just tree, Just wiki, wiki)
396 returnA -< concatMap extractFromBlock interpreted
398 extractFromElem :: Element -> [PageName]
399 extractFromElem (Block b) = extractFromBlock b
400 extractFromElem (Inline i) = extractFromInline i
402 extractFromBlock :: BlockElement -> [PageName]
403 extractFromBlock (List _ items) = concatMap extractFromListItem items
404 extractFromBlock (DefinitionList defs) = concatMap extractFromDefinition defs
405 extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines
406 extractFromBlock (Paragraph inlines) = concatMap extractFromInline inlines
407 extractFromBlock (Div _ elems) = concatMap extractFromElem elems
408 extractFromBlock _ = []
410 extractFromInline :: InlineElement -> [PageName]
411 extractFromInline (Italic inlines) = concatMap extractFromInline inlines
412 extractFromInline (Bold inlines) = concatMap extractFromInline inlines
413 extractFromInline (Span _ inlines) = concatMap extractFromInline inlines
414 extractFromInline (PageLink (Just name) _ _) = [name]
415 extractFromInline _ = []
417 extractFromListItem :: ListItem -> [PageName]
418 extractFromListItem = concatMap extractFromElem
420 extractFromDefinition :: Definition -> [PageName]
421 extractFromDefinition (Definition term desc)
422 = concatMap extractFromInline term
424 concatMap extractFromInline desc
427 wikifyParseError :: Arrow a => a ParseError WikiPage
428 wikifyParseError = proc err
429 -> returnA -< [Div [("class", "error")]
430 [ Block (Preformatted [Text (show err)]) ]]