1 module Rakka.Wiki.Engine
10 import qualified Codec.Binary.Base64 as B64
12 import Control.Arrow.ArrowIO
13 import Control.Arrow.ArrowList
14 import qualified Data.ByteString.Lazy as L
16 import Data.Encoding.UTF8
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
33 import Text.XML.HXT.Arrow.XmlNodeSet
34 import Text.XML.HXT.DOM.TypeDefs
37 type InterpTable = Map String Interpreter
43 lang="ja" -- 存在しない場合もある
44 fileName="bar.rakka" -- 存在しない場合もある
45 isTheme="no" -- text/css の場合のみ存在
46 isFeed="no" -- text/x-rakka の場合のみ存在
49 revision="112"> -- デフォルトでない場合のみ存在
50 lastModified="2000-01-01T00:00:00">
54 </summary> -- 存在しない場合もある
56 <otherLang> -- 存在しない場合もある
57 <link lang="ja" page="Bar/Baz" />
65 SKJaHKS8JK/DH8KS43JDK2aKKaSFLLS...
69 xmlizePage :: (ArrowXml a, ArrowChoice a) => a Page XmlTree
74 += sattr "name" (pageName page)
75 += sattr "type" (show $ pageType page)
76 += ( case pageLanguage page of
77 Just x -> sattr "lang" x
80 += ( case pageFileName page of
81 Just x -> sattr "fileName" x
84 += ( case pageType page of
85 MIMEType "text" "css" _
86 -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
87 MIMEType "text" "x-rakka" _
88 -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
92 += sattr "isLocked" (yesOrNo $ pageIsLocked page)
93 += sattr "isBoring" (yesOrNo $ pageIsBoring page)
94 += sattr "isBinary" (yesOrNo $ pageIsBinary page)
95 += sattr "revision" (show $ pageRevision page)
96 += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
97 += ( case pageSummary page of
98 Just s -> eelem "summary" += txt s
101 += ( if M.null (pageOtherLang page) then
108 | (lang, page) <- M.toList (pageOtherLang page) ]
110 += ( if pageIsBinary page then
112 += txt (B64.encode $ L.unpack $ pageContent page)
116 += txt (decodeLazy UTF8 $ pageContent page)
123 wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
124 wikifyPage interpTable
126 -> do pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
127 pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
128 pFileName <- maybeA (getXPathTreesInDoc "/page/fileName/text()" >>> getText) -< tree
129 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
130 base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
132 let dataURI = fmap (binToURI pType) base64Data
135 MIMEType "text" "x-rakka" _
136 -> case parse (wikiPage cmdTypeOf) "" (fromJust textData) of
137 Left err -> wikifyParseError -< err
138 Right xs -> returnA -< xs
141 -- <img src="data:image/png;base64,..." />
142 -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
144 _ -> if isJust dataURI then
145 -- <a href="data:application/zip;base64,...">foo.zip</a>
146 returnA -< [ Paragraph [ Anchor
147 [("href", show dataURI)]
148 [Text (fromMaybe (defaultFileName pType pName) pFileName)]
153 returnA -< [ Preformatted [Text $ fromJust textData] ]
155 cmdTypeOf :: String -> Maybe CommandType
157 = fmap commandType (M.lookup name interpTable)
159 binToURI :: MIMEType -> String -> URI
160 binToURI pType base64Data
163 , uriPath = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
166 stripWhiteSpace :: String -> String
167 stripWhiteSpace [] = []
168 stripWhiteSpace (x:xs)
169 | x `elem` " \t\n" = stripWhiteSpace xs
170 | otherwise = x : stripWhiteSpace xs
173 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
178 makeMainXHTML sto sysConf interpTable
180 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
181 wiki <- wikifyPage interpTable -< tree
182 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
183 interpreted <- interpretCommands sto sysConf interpTable
184 -< (pName, Just (tree, wiki), wiki)
185 formatWikiBlocks -< (baseURI, interpreted)
188 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
192 -> a (PageName, Maybe XmlTree, XmlTree) XmlTree
193 makeSubXHTML sto sysConf interpTable
194 = proc (mainPageName, mainPage, subPage)
195 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
196 mainWiki <- case mainPage of
198 -> do wiki <- wikifyPage interpTable -< page
199 returnA -< Just (page, wiki)
201 -> returnA -< Nothing
202 subWiki <- wikifyPage interpTable -< subPage
203 interpreted <- interpretCommands sto sysConf interpTable
204 -< (mainPageName, mainWiki, subWiki)
205 formatWikiBlocks -< (baseURI, interpreted)
208 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
212 -> a (PageName, Maybe (XmlTree, WikiPage), WikiPage) WikiPage
213 interpretCommands sto sysConf interpTable
214 = proc (name, mainPageAndWiki, targetWiki)
215 -> let ctx = InterpreterContext {
217 , ctxMainPage = fmap fst mainPageAndWiki
218 , ctxMainWiki = fmap snd mainPageAndWiki
219 , ctxTargetWiki = targetWiki
221 , ctxSysConf = sysConf
224 arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
226 interpElem :: InterpreterContext -> Element -> IO Element
227 interpElem ctx (Block b) = interpBlock ctx b >>= return . Block
228 interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
230 interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
231 interpBlock ctx (List lType lItems) = mapM (interpListItem ctx) lItems >>= return . List lType
232 interpBlock ctx (DefinitionList defs) = mapM (interpDefinition ctx) defs >>= return . DefinitionList
233 interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
234 interpBlock ctx (Paragraph inlines) = mapM (interpInline ctx) inlines >>= return . Paragraph
235 interpBlock ctx (Div attrs elems) = mapM (interpElem ctx) elems >>= return . Div attrs
236 interpBlock ctx (BlockCmd bcmd) = interpBlockCommand ctx bcmd
237 interpBlock _ x = return x
239 interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
240 interpInline ctx (Italic inlines) = mapM (interpInline ctx) inlines >>= return . Italic
241 interpInline ctx (Bold inlines) = mapM (interpInline ctx) inlines >>= return . Bold
242 interpInline ctx (Span attrs inlines) = mapM (interpInline ctx) inlines >>= return . Span attrs
243 interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
244 interpInline ctx (InlineCmd icmd) = interpInlineCommand ctx icmd
245 interpInline _ x = return x
247 interpListItem :: InterpreterContext -> ListItem -> IO ListItem
248 interpListItem = mapM . interpElem
250 interpDefinition :: InterpreterContext -> Definition -> IO Definition
251 interpDefinition ctx (Definition term desc)
252 = do term' <- mapM (interpInline ctx) term
253 desc' <- mapM (interpInline ctx) desc
254 return (Definition term' desc')
256 interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
257 interpBlockCommand ctx cmd
258 = case M.lookup (bCmdName cmd) interpTable of
260 -> fail ("no such interpreter: " ++ bCmdName cmd)
263 -> bciInterpret interp ctx cmd
267 interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
268 interpInlineCommand ctx cmd
269 = case M.lookup (iCmdName cmd) interpTable of
271 -> fail ("no such interpreter: " ++ iCmdName cmd)
274 -> iciInterpret interp ctx cmd
279 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
280 makeDraft interpTable
282 do doc <- arrIO0 newDocument -< ()
284 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
285 pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree
286 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
287 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
288 pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()" >>> getText -< tree
289 pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree
290 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
291 pLang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
292 pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree
293 pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree
294 pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree
295 pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree
297 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
298 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
299 arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType)
300 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
301 arrIO2 (flip setAttribute "@lang" ) -< (doc, pLang)
302 arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName)
303 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
304 arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring)
305 arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
306 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
307 arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
309 arrIO2 addHiddenText -< (doc, pName)
312 Just s -> arrIO2 addHiddenText -< (doc, s)
313 Nothing -> returnA -< ()
315 -- otherLang はリンク先ページ名を hidden text で入れる。
316 otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
317 listA ( (arr fst &&& arrL snd)
322 ) -< (doc, otherLangs)
325 MIMEType "text" "css" _
326 -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
328 MIMEType "text" "x-rakka" _
329 -- wikify して興味のある部分を addText する。
330 -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
331 wikiPage <- wikifyPage interpTable -< tree
332 arrIO2 (mapM_ . addBlockText) -< (doc, wikiPage)
339 addElemText :: Document -> Element -> IO ()
340 addElemText doc (Block b) = addBlockText doc b
341 addElemText doc (Inline i) = addInlineText doc i
343 addBlockText :: Document -> BlockElement -> IO ()
344 addBlockText doc (Heading _ text) = addText doc text
345 addBlockText _ HorizontalLine = return ()
346 addBlockText doc (List _ items) = mapM_ (addListItemText doc) items
347 addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs
348 addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
349 addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines
350 addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems
351 addBlockText _ EmptyBlock = return ()
352 addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd
354 addInlineText :: Document -> InlineElement -> IO ()
355 addInlineText doc (Text text) = addText doc text
356 addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines
357 addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines
358 addInlineText doc (ObjectLink page Nothing) = addText doc page
359 addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page
361 addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
362 addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
364 addInlineText doc (ExternalLink uri Nothing) = addText doc (uriToString id uri "")
365 addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (uriToString id uri "")
367 addInlineText _ (LineBreak _) = return ()
368 addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines
369 addInlineText doc (Image src alt) = do case src of
370 Left uri -> addHiddenText doc (uriToString id uri "")
371 Right page -> addHiddenText doc page
373 Just text -> addHiddenText doc text
375 addInlineText doc (Anchor attrs inlines) = mapM_ (addInlineText doc) inlines
376 addInlineText _ (Input _) = return ()
377 addInlineText _ EmptyInline = return ()
378 addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
380 addListItemText :: Document -> ListItem -> IO ()
381 addListItemText = mapM_ . addElemText
383 addDefinitionText :: Document -> Definition -> IO ()
384 addDefinitionText doc (Definition term desc)
385 = do mapM_ (addInlineText doc) term
386 mapM_ (addInlineText doc) desc
388 addBlockCmdText :: Document -> BlockCommand -> IO ()
389 addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
391 addInlineCmdText :: Document -> InlineCommand -> IO ()
392 addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
395 wikifyParseError :: Arrow a => a ParseError WikiPage
396 wikifyParseError = proc err
397 -> returnA -< [Div [("class", "error")]
398 [ Block (Preformatted [Text (show err)]) ]]