1 module Rakka.Wiki.Engine
10 import qualified Codec.Binary.Base64 as B64
11 import Codec.Binary.UTF8.String
13 import Control.Arrow.ArrowIO
14 import Control.Arrow.ArrowList
15 import qualified Data.ByteString.Lazy as L
17 import qualified Data.Map as M
20 import Network.HTTP.Lucu
24 import Rakka.SystemConfig
26 import Rakka.W3CDateTime
28 import Rakka.Wiki.Parser
29 import Rakka.Wiki.Formatter
30 import Rakka.Wiki.Interpreter
31 import Text.HyperEstraier hiding (getText)
32 import Text.ParserCombinators.Parsec
33 import Text.XML.HXT.Arrow.XmlArrow hiding (err)
34 import Text.XML.HXT.Arrow.XmlNodeSet
35 import Text.XML.HXT.DOM.TypeDefs
38 type InterpTable = Map String Interpreter
44 lang="ja" -- 存在しない場合もある
45 fileName="bar.rakka" -- 存在しない場合もある
46 isTheme="no" -- text/css の場合のみ存在
47 isFeed="no" -- text/x-rakka の場合のみ存在
50 revision="112"> -- デフォルトでない場合のみ存在
51 lastModified="2000-01-01T00:00:00">
55 </summary> -- 存在しない場合もある
57 <otherLang> -- 存在しない場合もある
58 <link lang="ja" page="Bar/Baz" />
66 SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
70 xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
73 -> do lastMod <- arrIO (utcToLocalZonedTime . pageLastMod) -< page
76 += sattr "name" (pageName page)
77 += sattr "type" (show $ pageType page)
78 += ( case pageLanguage page of
79 Just x -> sattr "lang" x
82 += ( case pageFileName page of
83 Just x -> sattr "fileName" x
86 += ( case pageType page of
87 MIMEType "text" "css" _
88 -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
89 MIMEType "text" "x-rakka" _
90 -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
94 += sattr "isLocked" (yesOrNo $ pageIsLocked page)
95 += sattr "isBoring" (yesOrNo $ pageIsBoring page)
96 += sattr "isBinary" (yesOrNo $ pageIsBinary page)
97 += sattr "revision" (show $ pageRevision page)
98 += sattr "lastModified" (formatW3CDateTime lastMod)
99 += ( case pageSummary page of
100 Just s -> eelem "summary" += txt s
103 += ( if M.null (pageOtherLang page) then
110 | (lang, name) <- M.toList (pageOtherLang page) ]
112 += ( if pageIsBinary page then
114 += txt (B64.encode $ L.unpack $ pageContent page)
118 += txt (decode $ L.unpack $ pageContent page)
124 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
125 wikifyPage interpTable
127 -> do pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
128 pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
129 pFileName <- maybeA (getXPathTreesInDoc "/page/fileName/text()" >>> getText) -< tree
130 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
131 base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
133 let dataURI = fmap (binToURI pType) base64Data
136 MIMEType "text" "x-rakka" _
137 -> case parse (wikiPage cmdTypeOf) "" (fromJust textData) of
138 Left err -> wikifyParseError -< err
139 Right xs -> returnA -< xs
142 -- <img src="data:image/png;base64,..." />
143 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
145 _ -> if isJust dataURI then
146 -- <a href="data:application/zip;base64,...">foo.zip</a>
147 returnA -< [ Paragraph [ Anchor
148 [("href", show dataURI)]
149 [Text (fromMaybe (defaultFileName pType pName) pFileName)]
154 returnA -< [ Preformatted [Text $ fromJust textData] ]
156 cmdTypeOf :: String -> Maybe CommandType
158 = fmap commandType (M.lookup name interpTable)
160 binToURI :: MIMEType -> String -> URI
161 binToURI pType base64Data
164 , uriPath = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
167 stripWhiteSpace :: String -> String
168 stripWhiteSpace [] = []
169 stripWhiteSpace (x:xs)
170 | x `elem` " \t\n" = stripWhiteSpace xs
171 | otherwise = x : stripWhiteSpace xs
174 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
179 makeMainXHTML sto sysConf interpTable
181 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
182 wiki <- wikifyPage interpTable -< tree
183 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
184 interpreted <- interpretCommands sto sysConf interpTable
185 -< (pName, Just (tree, wiki), wiki)
186 formatWikiBlocks -< (baseURI, interpreted)
189 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
193 -> a (PageName, Maybe XmlTree, XmlTree) XmlTree
194 makeSubXHTML sto sysConf interpTable
195 = proc (mainPageName, mainPage, subPage)
196 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
197 mainWiki <- case mainPage of
199 -> do wiki <- wikifyPage interpTable -< page
200 returnA -< Just (page, wiki)
202 -> returnA -< Nothing
203 subWiki <- wikifyPage interpTable -< subPage
204 interpreted <- interpretCommands sto sysConf interpTable
205 -< (mainPageName, mainWiki, subWiki)
206 formatWikiBlocks -< (baseURI, interpreted)
209 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
213 -> a (PageName, Maybe (XmlTree, WikiPage), WikiPage) WikiPage
214 interpretCommands sto sysConf interpTable
215 = proc (name, mainPageAndWiki, targetWiki)
216 -> let ctx = InterpreterContext {
218 , ctxMainPage = fmap fst mainPageAndWiki
219 , ctxMainWiki = fmap snd mainPageAndWiki
220 , ctxTargetWiki = targetWiki
222 , ctxSysConf = sysConf
225 arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
227 interpElem :: InterpreterContext -> Element -> IO Element
228 interpElem ctx (Block b) = interpBlock ctx b >>= return . Block
229 interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
231 interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
232 interpBlock ctx (List lType lItems) = mapM (interpListItem ctx) lItems >>= return . List lType
233 interpBlock ctx (DefinitionList defs) = mapM (interpDefinition ctx) defs >>= return . DefinitionList
234 interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
235 interpBlock ctx (Paragraph inlines) = mapM (interpInline ctx) inlines >>= return . Paragraph
236 interpBlock ctx (Div attrs elems) = mapM (interpElem ctx) elems >>= return . Div attrs
237 interpBlock ctx (BlockCmd bcmd) = interpBlockCommand ctx bcmd
238 interpBlock _ x = return x
240 interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
241 interpInline ctx (Italic inlines) = mapM (interpInline ctx) inlines >>= return . Italic
242 interpInline ctx (Bold inlines) = mapM (interpInline ctx) inlines >>= return . Bold
243 interpInline ctx (Span attrs inlines) = mapM (interpInline ctx) inlines >>= return . Span attrs
244 interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
245 interpInline ctx (InlineCmd icmd) = interpInlineCommand ctx icmd
246 interpInline _ x = return x
248 interpListItem :: InterpreterContext -> ListItem -> IO ListItem
249 interpListItem = mapM . interpElem
251 interpDefinition :: InterpreterContext -> Definition -> IO Definition
252 interpDefinition ctx (Definition term desc)
253 = do term' <- mapM (interpInline ctx) term
254 desc' <- mapM (interpInline ctx) desc
255 return (Definition term' desc')
257 interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
258 interpBlockCommand ctx cmd
259 = case M.lookup (bCmdName cmd) interpTable of
261 -> fail ("no such interpreter: " ++ bCmdName cmd)
264 -> bciInterpret interp ctx cmd
268 interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
269 interpInlineCommand ctx cmd
270 = case M.lookup (iCmdName cmd) interpTable of
272 -> fail ("no such interpreter: " ++ iCmdName cmd)
275 -> iciInterpret interp ctx cmd
280 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
281 makeDraft interpTable
283 do doc <- arrIO0 newDocument -< ()
285 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
286 pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree
287 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
288 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
289 pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()" >>> getText -< tree
290 pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree
291 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
292 pLang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
293 pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree
294 pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree
295 pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree
296 pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree
298 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
299 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
300 arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType)
301 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
302 arrIO2 (flip setAttribute "@lang" ) -< (doc, pLang)
303 arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName)
304 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
305 arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring)
306 arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
307 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
308 arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
310 arrIO2 addHiddenText -< (doc, pName)
313 Just s -> arrIO2 addHiddenText -< (doc, s)
314 Nothing -> returnA -< ()
316 -- otherLang はリンク先ページ名を hidden text で入れる。
317 otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
318 listA ( (arr fst &&& arrL snd)
323 ) -< (doc, otherLangs)
326 MIMEType "text" "css" _
327 -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
329 MIMEType "text" "x-rakka" _
330 -- wikify して興味のある部分を addText する。
331 -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
332 wiki <- wikifyPage interpTable -< tree
333 arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
340 addElemText :: Document -> Element -> IO ()
341 addElemText doc (Block b) = addBlockText doc b
342 addElemText doc (Inline i) = addInlineText doc i
344 addBlockText :: Document -> BlockElement -> IO ()
345 addBlockText doc (Heading _ text) = addText doc text
346 addBlockText _ HorizontalLine = return ()
347 addBlockText doc (List _ items) = mapM_ (addListItemText doc) items
348 addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs
349 addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
350 addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines
351 addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems
352 addBlockText _ EmptyBlock = return ()
353 addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd
355 addInlineText :: Document -> InlineElement -> IO ()
356 addInlineText doc (Text text) = addText doc text
357 addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines
358 addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines
359 addInlineText doc (ObjectLink page Nothing) = addText doc page
360 addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page
362 addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
363 addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
365 addInlineText doc (ExternalLink uri Nothing) = addText doc (uriToString id uri "")
366 addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (uriToString id uri "")
368 addInlineText _ (LineBreak _) = return ()
369 addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines
370 addInlineText doc (Image src alt) = do case src of
371 Left uri -> addHiddenText doc (uriToString id uri "")
372 Right page -> addHiddenText doc page
374 Just text -> addHiddenText doc text
376 addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines
377 addInlineText _ (Input _) = return ()
378 addInlineText _ EmptyInline = return ()
379 addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
381 addListItemText :: Document -> ListItem -> IO ()
382 addListItemText = mapM_ . addElemText
384 addDefinitionText :: Document -> Definition -> IO ()
385 addDefinitionText doc (Definition term desc)
386 = do mapM_ (addInlineText doc) term
387 mapM_ (addInlineText doc) desc
389 addBlockCmdText :: Document -> BlockCommand -> IO ()
390 addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
392 addInlineCmdText :: Document -> InlineCommand -> IO ()
393 addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
396 wikifyParseError :: Arrow a => a ParseError WikiPage
397 wikifyParseError = proc err
398 -> returnA -< [Div [("class", "error")]
399 [ Block (Preformatted [Text (show err)]) ]]