1 module Rakka.Wiki.Engine
10 import qualified Codec.Binary.Base64 as B64
11 import qualified Codec.Binary.UTF8.String as UTF8
13 import Control.Arrow.ArrowIO
14 import Control.Arrow.ArrowList
15 import qualified Data.ByteString.Lazy as Lazy
17 import qualified Data.Map as M
19 import Network.HTTP.Lucu
23 import Rakka.SystemConfig
26 import Rakka.Wiki.Parser
27 import Rakka.Wiki.Formatter
28 import Rakka.Wiki.Interpreter
29 import Text.HyperEstraier hiding (getText)
30 import Text.ParserCombinators.Parsec
31 import Text.XML.HXT.Arrow.XmlArrow hiding (err)
32 import Text.XML.HXT.Arrow.XmlNodeSet
33 import Text.XML.HXT.DOM.TypeDefs
36 type InterpTable = Map String Interpreter
39 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
40 wikifyPage interpTable
42 -> do pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
43 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
44 base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
46 let dataURI = fmap (binToURI pType) base64Data
49 MIMEType "text" "x-rakka" _
50 -> case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
51 Left err -> wikifyParseError -< err
52 Right xs -> returnA -< xs
55 -- <img src="data:image/png;base64,..." />
56 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
58 _ -> if isJust dataURI then
59 -- <a href="data:application/zip;base64,...">
62 returnA -< [ Paragraph [ Anchor
63 [("href", show dataURI)]
69 returnA -< [ Preformatted [Text $ fromJust textData] ]
71 binToURI :: MIMEType -> String -> URI
72 binToURI pType base64Data
75 , uriPath = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
78 stripWhiteSpace :: String -> String
79 stripWhiteSpace [] = []
80 stripWhiteSpace (x:xs)
81 | x `elem` " \t\n" = stripWhiteSpace xs
82 | otherwise = x : stripWhiteSpace xs
85 wikifyBin :: (ArrowXml a, ArrowChoice a) => InterpTable -> a (MIMEType, Lazy.ByteString) WikiPage
88 -> do let text = UTF8.decode $ Lazy.unpack pBin
89 dataURI = binToURI pType pBin
92 MIMEType "text" "x-rakka" _
93 -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
94 Left err -> wikifyParseError -< err
95 Right xs -> returnA -< xs
98 -- <img src="data:image/png;base64,..." />
99 -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
103 -- <a href="data:application/zip;base64,...">
104 -- application/zip (19372 bytes)
106 -> returnA -< [ Paragraph [ Anchor
107 [("href", show dataURI)]
110 show (Lazy.length pBin) ++
115 binToURI :: MIMEType -> Lazy.ByteString -> URI
119 , uriPath = show m ++ ";base64," ++ B64.encode (Lazy.unpack b)
123 cmdTypeOf :: InterpTable -> String -> Maybe CommandType
124 cmdTypeOf interpTable name
125 = fmap commandType (M.lookup name interpTable)
128 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
133 makeMainXHTML sto sysConf interpTable
135 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
136 wiki <- wikifyPage interpTable -< tree
137 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
138 interpreted <- interpretCommands sto sysConf interpTable
139 -< (pName, Just tree, Just wiki, wiki)
140 formatWikiBlocks -< (baseURI, interpreted)
143 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
147 -> a (PageName, Maybe XmlTree, XmlTree) XmlTree
148 makeSubXHTML sto sysConf interpTable
149 = proc (mainPageName, mainPage, subPage)
150 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
151 mainWiki <- case mainPage of
153 -> do wiki <- wikifyPage interpTable -< page
154 returnA -< Just (page, wiki)
156 -> returnA -< Nothing
157 subWiki <- wikifyPage interpTable -< subPage
158 interpreted <- interpretCommands sto sysConf interpTable
159 -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
160 formatWikiBlocks -< (baseURI, interpreted)
163 makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
167 -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
168 makePreviewXHTML sto sysConf interpTable
169 = proc (name, pageType, pageBin)
170 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
171 wiki <- wikifyBin interpTable -< (pageType, pageBin)
172 interpreted <- interpretCommands sto sysConf interpTable
173 -< (name, Nothing, Just wiki, wiki)
174 formatWikiBlocks -< (baseURI, interpreted)
177 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
181 -> a (PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
182 interpretCommands sto sysConf interpTable
183 = proc (name, mainPage, mainWiki, targetWiki)
184 -> let ctx = InterpreterContext {
186 , ctxMainPage = mainPage
187 , ctxMainWiki = mainWiki
188 , ctxTargetWiki = targetWiki
190 , ctxSysConf = sysConf
193 arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
195 interpElem :: InterpreterContext -> Element -> IO Element
196 interpElem ctx (Block b) = interpBlock ctx b >>= return . Block
197 interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
199 interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
200 interpBlock ctx (List lType lItems) = mapM (interpListItem ctx) lItems >>= return . List lType
201 interpBlock ctx (DefinitionList defs) = mapM (interpDefinition ctx) defs >>= return . DefinitionList
202 interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
203 interpBlock ctx (Paragraph inlines) = mapM (interpInline ctx) inlines >>= return . Paragraph
204 interpBlock ctx (Div attrs elems) = mapM (interpElem ctx) elems >>= return . Div attrs
205 interpBlock ctx (BlockCmd bcmd) = interpBlockCommand ctx bcmd
206 interpBlock _ x = return x
208 interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
209 interpInline ctx (Italic inlines) = mapM (interpInline ctx) inlines >>= return . Italic
210 interpInline ctx (Bold inlines) = mapM (interpInline ctx) inlines >>= return . Bold
211 interpInline ctx (Span attrs inlines) = mapM (interpInline ctx) inlines >>= return . Span attrs
212 interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
213 interpInline ctx (InlineCmd icmd) = interpInlineCommand ctx icmd
214 interpInline _ x = return x
216 interpListItem :: InterpreterContext -> ListItem -> IO ListItem
217 interpListItem = mapM . interpElem
219 interpDefinition :: InterpreterContext -> Definition -> IO Definition
220 interpDefinition ctx (Definition term desc)
221 = do term' <- mapM (interpInline ctx) term
222 desc' <- mapM (interpInline ctx) desc
223 return (Definition term' desc')
225 interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
226 interpBlockCommand ctx cmd
227 = case M.lookup (bCmdName cmd) interpTable of
229 -> fail ("no such interpreter: " ++ bCmdName cmd)
232 -> bciInterpret interp ctx cmd
236 interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
237 interpInlineCommand ctx cmd
238 = case M.lookup (iCmdName cmd) interpTable of
240 -> fail ("no such interpreter: " ++ iCmdName cmd)
243 -> iciInterpret interp ctx cmd
248 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
249 makeDraft interpTable
251 do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
253 Nothing -> makeEntityDraft -< tree
254 Just _ -> makeRedirectDraft -< tree
256 makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
259 do doc <- arrIO0 newDocument -< ()
261 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
262 pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree
263 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
264 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
265 pIsBoring <- getXPathTreesInDoc "/page/@isBoring/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:isBoring") -< (doc, Just pIsBoring)
282 arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
283 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
284 arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
286 arrIO2 addHiddenText -< (doc, pName)
289 Just s -> arrIO2 addHiddenText -< (doc, s)
290 Nothing -> returnA -< ()
292 -- otherLang はリンク先ページ名を hidden text で入れる。
293 otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
294 listA ( (arr fst &&& arrL snd)
299 ) -< (doc, otherLangs)
302 MIMEType "text" "css" _
303 -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
305 MIMEType "text" "x-rakka" _
306 -- wikify して興味のある部分を addText する。
307 -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
308 wiki <- wikifyPage interpTable -< tree
309 arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
316 makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
319 do doc <- arrIO0 newDocument -< ()
321 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
322 pRedir <- getXPathTreesInDoc "/page/@redirect/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:revision") -< (doc, Just pRevision)
332 -- リダイレクト先ページ名はテキストとして入れる
333 arrIO2 addText -< (doc, pRedir)
337 addElemText :: Document -> Element -> IO ()
338 addElemText doc (Block b) = addBlockText doc b
339 addElemText doc (Inline i) = addInlineText doc i
341 addBlockText :: Document -> BlockElement -> IO ()
342 addBlockText doc (Heading _ text) = addText doc text
343 addBlockText _ HorizontalLine = return ()
344 addBlockText doc (List _ items) = mapM_ (addListItemText doc) items
345 addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs
346 addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
347 addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines
348 addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems
349 addBlockText _ EmptyBlock = return ()
350 addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd
352 addInlineText :: Document -> InlineElement -> IO ()
353 addInlineText doc (Text text) = addText doc text
354 addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines
355 addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines
356 addInlineText doc (ObjectLink page Nothing) = addText doc page
357 addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page
359 addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
360 addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
362 addInlineText doc (ExternalLink uri Nothing) = addText doc (uriToString id uri "")
363 addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (uriToString id uri "")
365 addInlineText _ (LineBreak _) = return ()
366 addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines
367 addInlineText doc (Image src alt) = do case src of
368 Left uri -> addHiddenText doc (uriToString id uri "")
369 Right page -> addHiddenText doc page
371 Just text -> addHiddenText doc text
373 addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines
374 addInlineText _ (Input _) = return ()
375 addInlineText _ EmptyInline = return ()
376 addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
378 addListItemText :: Document -> ListItem -> IO ()
379 addListItemText = mapM_ . addElemText
381 addDefinitionText :: Document -> Definition -> IO ()
382 addDefinitionText doc (Definition term desc)
383 = do mapM_ (addInlineText doc) term
384 mapM_ (addInlineText doc) desc
386 addBlockCmdText :: Document -> BlockCommand -> IO ()
387 addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
389 addInlineCmdText :: Document -> InlineCommand -> IO ()
390 addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
393 wikifyParseError :: Arrow a => a ParseError WikiPage
394 wikifyParseError = proc err
395 -> returnA -< [Div [("class", "error")]
396 [ Block (Preformatted [Text (show err)]) ]]