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 -< (pName, Just tree, Just wiki, wiki)
141 formatWikiBlocks -< (baseURI, interpreted)
144 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
148 -> a (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 -< (name, Nothing, Just wiki, wiki)
175 formatWikiBlocks -< (baseURI, interpreted)
178 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
182 -> a (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 pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/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:fileName") -< (doc, pFileName)
280 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
281 arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
282 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
283 arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
285 arrIO2 addHiddenText -< (doc, pName)
288 Just s -> arrIO2 addHiddenText -< (doc, s)
289 Nothing -> returnA -< ()
291 -- otherLang はリンク先ページ名を hidden text で入れる。
292 otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
293 listA ( (arr fst &&& arrL snd)
298 ) -< (doc, otherLangs)
301 MIMEType "text" "css" _
302 -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
304 MIMEType "text" "x-rakka" _
305 -- wikify して興味のある部分を addText する。
306 -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
307 wiki <- wikifyPage interpTable -< tree
308 arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
315 makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
318 do doc <- arrIO0 newDocument -< ()
320 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
321 pRedir <- getXPathTreesInDoc "/page/@redirect/text()" >>> getText -< tree
322 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
323 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
324 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
326 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
327 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
328 arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection")
329 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
330 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
331 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
333 -- リダイレクト先ページ名はテキストとして入れる
334 arrIO2 addText -< (doc, pRedir)
338 addElemText :: Document -> Element -> IO ()
339 addElemText doc (Block b) = addBlockText doc b
340 addElemText doc (Inline i) = addInlineText doc i
342 addBlockText :: Document -> BlockElement -> IO ()
343 addBlockText doc (Heading _ text) = addText doc text
344 addBlockText _ HorizontalLine = return ()
345 addBlockText doc (List _ items) = mapM_ (addListItemText doc) items
346 addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs
347 addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
348 addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines
349 addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems
350 addBlockText _ EmptyBlock = return ()
351 addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd
353 addInlineText :: Document -> InlineElement -> IO ()
354 addInlineText doc (Text text) = addText doc text
355 addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines
356 addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines
357 addInlineText doc (ObjectLink page Nothing) = addText doc page
358 addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page
360 addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
361 addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
363 addInlineText doc (ExternalLink uri Nothing) = addText doc (uriToString id uri "")
364 addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (uriToString id uri "")
366 addInlineText _ (LineBreak _) = return ()
367 addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines
368 addInlineText doc (Image src alt) = do case src of
369 Left uri -> addHiddenText doc (uriToString id uri "")
370 Right page -> addHiddenText doc page
372 Just text -> addHiddenText doc text
374 addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines
375 addInlineText _ (Input _) = return ()
376 addInlineText _ EmptyInline = return ()
377 addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
379 addListItemText :: Document -> ListItem -> IO ()
380 addListItemText = mapM_ . addElemText
382 addDefinitionText :: Document -> Definition -> IO ()
383 addDefinitionText doc (Definition term desc)
384 = do mapM_ (addInlineText doc) term
385 mapM_ (addInlineText doc) desc
387 addBlockCmdText :: Document -> BlockCommand -> IO ()
388 addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
390 addInlineCmdText :: Document -> InlineCommand -> IO ()
391 addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
394 makePageLinkList :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
398 -> a XmlTree [PageName]
399 makePageLinkList sto sysConf interpTable
401 -> do wiki <- wikifyPage interpTable -< tree
402 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
403 interpreted <- interpretCommands sto sysConf interpTable
404 -< (pName, Just tree, Just wiki, wiki)
405 returnA -< concatMap extractFromBlock interpreted
407 extractFromElem :: Element -> [PageName]
408 extractFromElem (Block b) = extractFromBlock b
409 extractFromElem (Inline i) = extractFromInline i
411 extractFromBlock :: BlockElement -> [PageName]
412 extractFromBlock (List _ items) = concatMap extractFromListItem items
413 extractFromBlock (DefinitionList defs) = concatMap extractFromDefinition defs
414 extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines
415 extractFromBlock (Paragraph inlines) = concatMap extractFromInline inlines
416 extractFromBlock (Div _ elems) = concatMap extractFromElem elems
417 extractFromBlock _ = []
419 extractFromInline :: InlineElement -> [PageName]
420 extractFromInline (Italic inlines) = concatMap extractFromInline inlines
421 extractFromInline (Bold inlines) = concatMap extractFromInline inlines
422 extractFromInline (Span _ inlines) = concatMap extractFromInline inlines
423 extractFromInline (PageLink (Just name) _ _) = [name]
424 extractFromInline _ = []
426 extractFromListItem :: ListItem -> [PageName]
427 extractFromListItem = concatMap extractFromElem
429 extractFromDefinition :: Definition -> [PageName]
430 extractFromDefinition (Definition term desc)
431 = concatMap extractFromInline term
433 concatMap extractFromInline desc
436 wikifyParseError :: Arrow a => a ParseError WikiPage
437 wikifyParseError = proc err
438 -> returnA -< [Div [("class", "error")]
439 [ Block (Preformatted [Text (show err)]) ]]