8 module Rakka.Wiki.Engine
17 import Control.Applicative
19 import Control.Arrow.ArrowIO
20 import Control.Arrow.ArrowList
21 import Control.Arrow.Unicode
22 import Control.Monad.Unicode
23 import qualified Codec.Binary.UTF8.String as UTF8
24 import qualified Data.ByteString.Lazy as Lazy
25 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
27 import qualified Data.Map as M
29 import Data.Monoid.Unicode
30 import Data.Text (Text)
31 import qualified Data.Text as T
32 import Network.HTTP.Lucu
34 import OpenSSL.EVP.Base64
35 import Prelude.Unicode
38 import Rakka.SystemConfig
41 import Rakka.Wiki.Parser
42 import Rakka.Wiki.Formatter
43 import Rakka.Wiki.Interpreter
44 import Text.HyperEstraier hiding (getText)
45 import Text.ParserCombinators.Parsec
46 import Text.XML.HXT.Arrow.XmlArrow hiding (err)
47 import Text.XML.HXT.DOM.TypeDefs
48 import Text.XML.HXT.XPath
50 type InterpTable = Map Text Interpreter
52 wikifyPage ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ InterpTable → XmlTree ⇝ WikiPage
53 wikifyPage interpTable
55 → do pType ← getXPathTreesInDoc "/page/@type/text()" ⋙ getText ⋙ arr read ⤙ tree
56 textData ← maybeA (getXPathTreesInDoc "/page/textData/text()" ⋙ getText) ⤙ tree
57 base64Data ← maybeA (getXPathTreesInDoc "/page/binaryData/text()" ⋙ getText) ⤙ tree
59 let dataURI = binToURI pType <$> base64Data
62 MIMEType "text" "x-rakka" _
63 → case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
64 Left err → wikifyParseError ⤙ err
65 Right xs → returnA ⤙ xs
68 -- <img src="data:image/png;base64,..." />
69 → returnA ⤙ [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
71 _ → if isJust dataURI then
72 -- <a href="data:application/zip;base64,...">
75 returnA ⤙ [ Paragraph [ Anchor
76 [("href", T.pack $ show dataURI)]
77 [Text (T.pack $ show pType)]
82 returnA ⤙ [ Preformatted [Text ∘ T.pack $ fromJust textData] ]
84 binToURI :: MIMEType -> String -> URI
85 binToURI pType base64Data
88 , uriPath = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
91 stripWhiteSpace :: String -> String
92 stripWhiteSpace [] = []
93 stripWhiteSpace (x:xs)
94 | x `elem` " \t\n" = stripWhiteSpace xs
95 | otherwise = x : stripWhiteSpace xs
98 wikifyBin :: (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ InterpTable → (MIMEType, Lazy.ByteString) ⇝ WikiPage
101 → do let text = UTF8.decode $ Lazy.unpack pBin
102 dataURI = binToURI pType pBin
105 MIMEType "text" "x-rakka" _
106 -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
107 Left err -> wikifyParseError -< err
108 Right xs -> returnA -< xs
111 -- <img src="data:image/png;base64,..." />
112 -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
114 _ -- <a href="data:application/zip;base64,...">
115 -- application/zip (19372 bytes)
117 -> returnA -< [ Paragraph [ Anchor
118 [("href", T.pack $ show dataURI)]
119 [Text (T.concat [ T.pack $ show pType
121 , T.pack ∘ show $ Lazy.length pBin
127 binToURI :: MIMEType -> Lazy.ByteString -> URI
131 , uriPath = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b)
134 cmdTypeOf ∷ Alternative f ⇒ InterpTable → Text → f CommandType
135 cmdTypeOf interpTable name
136 = case M.lookup name interpTable of
137 Just t → pure $ commandType t
140 makeMainXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
145 makeMainXHTML sto sysConf interpTable
147 → do BaseURI baseURI ← getSysConfA sysConf ⤙ ()
148 wiki ← wikifyPage interpTable ⤙ tree
149 pName ← getXPathTreesInDoc "/page/@name/text()" ⋙ getText ⤙ tree
150 interpreted ← interpretCommands sto sysConf interpTable
151 ⤙ (Just (T.pack pName), Just tree, Just wiki, wiki)
152 formatWikiBlocks ⤙ (baseURI, interpreted)
155 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
159 -> a (Maybe PageName, Maybe XmlTree, XmlTree) XmlTree
160 makeSubXHTML sto sysConf interpTable
161 = proc (mainPageName, mainPage, subPage)
162 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
163 mainWiki <- case mainPage of
165 -> do wiki <- wikifyPage interpTable -< page
166 returnA -< Just (page, wiki)
168 -> returnA -< Nothing
169 subWiki <- wikifyPage interpTable -< subPage
170 interpreted <- interpretCommands sto sysConf interpTable
171 -< (mainPageName, fmap fst mainWiki, fmap snd mainWiki, subWiki)
172 formatWikiBlocks -< (baseURI, interpreted)
175 makePreviewXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
179 -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
180 makePreviewXHTML sto sysConf interpTable
181 = proc (name, pageType, pageBin)
182 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
183 wiki <- wikifyBin interpTable -< (pageType, pageBin)
184 interpreted <- interpretCommands sto sysConf interpTable
185 -< (Just name, Nothing, Just wiki, wiki)
186 formatWikiBlocks -< (baseURI, interpreted)
189 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
193 -> a (Maybe PageName, Maybe XmlTree, Maybe WikiPage, WikiPage) WikiPage
194 interpretCommands sto sysConf interpTable
195 = proc (name, mainPage, mainWiki, targetWiki)
196 -> let ctx = InterpreterContext {
198 , ctxMainPage = mainPage
199 , ctxMainWiki = mainWiki
200 , ctxTargetWiki = targetWiki
202 , ctxSysConf = sysConf
205 arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
207 interpElem :: InterpreterContext -> Element -> IO Element
208 interpElem ctx (Block b) = interpBlock ctx b >>= return . Block
209 interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
211 interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
212 interpBlock ctx (List lType lItems) = mapM (interpListItem ctx) lItems >>= return . List lType
213 interpBlock ctx (DefinitionList defs) = mapM (interpDefinition ctx) defs >>= return . DefinitionList
214 interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
215 interpBlock ctx (Paragraph inlines) = mapM (interpInline ctx) inlines >>= return . Paragraph
216 interpBlock ctx (Div attrs elems) = mapM (interpElem ctx) elems >>= return . Div attrs
217 interpBlock ctx (BlockCmd bcmd) = interpBlockCommand ctx bcmd
218 interpBlock _ x = return x
220 interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
221 interpInline ctx (Italic inlines) = mapM (interpInline ctx) inlines >>= return . Italic
222 interpInline ctx (Bold inlines) = mapM (interpInline ctx) inlines >>= return . Bold
223 interpInline ctx (Span attrs inlines) = mapM (interpInline ctx) inlines >>= return . Span attrs
224 interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
225 interpInline ctx (InlineCmd icmd) = interpInlineCommand ctx icmd
226 interpInline _ x = return x
228 interpListItem :: InterpreterContext -> ListItem -> IO ListItem
229 interpListItem = mapM . interpElem
231 interpDefinition :: InterpreterContext -> Definition -> IO Definition
232 interpDefinition ctx (Definition term desc)
233 = do term' <- mapM (interpInline ctx) term
234 desc' <- mapM (interpInline ctx) desc
235 return (Definition term' desc')
237 interpBlockCommand ∷ InterpreterContext → BlockCommand → IO BlockElement
238 interpBlockCommand ctx cmd
239 = case M.lookup (bCmdName cmd) interpTable of
241 → fail ("no such interpreter: " ⊕ T.unpack (bCmdName cmd))
244 → bciInterpret interp ctx cmd
248 interpInlineCommand ∷ InterpreterContext → InlineCommand → IO InlineElement
249 interpInlineCommand ctx cmd
250 = case M.lookup (iCmdName cmd) interpTable of
252 → fail ("no such interpreter: " ⊕ T.unpack (iCmdName cmd))
255 → iciInterpret interp ctx cmd ≫= interpInline ctx
257 makeDraft ∷ ∀(⇝). (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) ⇒ InterpTable → XmlTree ⇝ Document
258 makeDraft interpTable
260 do redir ← maybeA (getXPathTreesInDoc "/page/@redirect") ⤙ tree
262 Nothing → makeEntityDraft ⤙ tree
263 Just _ → makeRedirectDraft ⤙ tree
265 makeEntityDraft ∷ XmlTree ⇝ Document
268 do doc ← arrIO0 newDocument ⤙ ()
270 pName ← getXPathTreesInDoc "/page/@name/text()" ⋙ getText ⤙ tree
271 pType ← getXPathTreesInDoc "/page/@type/text()" ⋙ getText ⤙ tree
272 pLastMod ← getXPathTreesInDoc "/page/@lastModified/text()" ⋙ getText ⤙ tree
273 pIsLocked ← getXPathTreesInDoc "/page/@isLocked/text()" ⋙ getText ⤙ tree
274 pIsBinary ← getXPathTreesInDoc "/page/@isBinary/text()" ⋙ getText ⤙ tree
275 pRevision ← getXPathTreesInDoc "/page/@revision/text()" ⋙ getText ⤙ tree
276 pLang ← maybeA (getXPathTreesInDoc "/page/@lang/text()" ⋙ getText) ⤙ tree
277 pIsTheme ← maybeA (getXPathTreesInDoc "/page/@isTheme/text()" ⋙ getText) ⤙ tree
278 pIsFeed ← maybeA (getXPathTreesInDoc "/page/@isFeed/text()" ⋙ getText) ⤙ tree
279 pSummary ← maybeA (getXPathTreesInDoc "/page/summary/text()" ⋙ getText) ⤙ tree
281 arrIO2 setURI ⤙ (doc, Just ∘ mkRakkaURI $ T.pack pName )
282 arrIO2 (flip setAttribute "@title" ) ⤙ (doc, Just $ T.pack pName )
283 arrIO2 (flip setAttribute "@type" ) ⤙ (doc, Just $ T.pack pType )
284 arrIO2 (flip setAttribute "@mdate" ) ⤙ (doc, Just $ T.pack pLastMod )
285 arrIO2 (flip setAttribute "@lang" ) ⤙ (doc, T.pack <$> pLang)
286 arrIO2 (flip setAttribute "rakka:isLocked") ⤙ (doc, Just $ T.pack pIsLocked)
287 arrIO2 (flip setAttribute "rakka:isBinary") ⤙ (doc, Just $ T.pack pIsBinary)
288 arrIO2 (flip setAttribute "rakka:revision") ⤙ (doc, Just $ T.pack pRevision)
289 arrIO2 (flip setAttribute "rakka:summary" ) ⤙ (doc, T.pack <$> pSummary)
291 arrIO2 addHiddenText ⤙ (doc, T.pack pName)
294 Just s → arrIO2 addHiddenText ⤙ (doc, T.pack s)
295 Nothing → returnA ⤙ ()
297 -- otherLang はリンク先ページ名を hidden text で入れる。
298 otherLangs ← listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" ⋙ getText) ⤙ tree
299 listA ( (arr fst &&& arrL snd)
304 ) ⤙ (doc, T.pack <$> otherLangs)
307 MIMEType "text" "css" _
308 → arrIO2 (flip setAttribute "rakka:isTheme") ⤙ (doc, T.pack <$> pIsTheme)
310 MIMEType "text" "x-rakka" _
311 -- wikify して興味のある部分を addText する。
312 → do arrIO2 (flip setAttribute "rakka:isFeed") ⤙ (doc, T.pack <$> pIsFeed)
313 wiki ← wikifyPage interpTable ⤙ tree
314 arrIO2 (mapM_ ∘ addBlockText) ⤙ (doc, wiki)
321 makeRedirectDraft ∷ XmlTree ⇝ Document
324 do doc ← arrIO0 newDocument ⤙ ()
326 pName ← getXPathTreesInDoc "/page/@name/text()" ⋙ getText ⤙ tree
327 pRedir ← getXPathTreesInDoc "/page/@redirect/text()" ⋙ getText ⤙ tree
328 pIsLocked ← getXPathTreesInDoc "/page/@isLocked/text()" ⋙ getText ⤙ tree
329 pRevision ← getXPathTreesInDoc "/page/@revision/text()" ⋙ getText ⤙ tree
330 pLastMod ← getXPathTreesInDoc "/page/@lastModified/text()" ⋙ getText ⤙ tree
332 arrIO2 setURI -< (doc, Just ∘ mkRakkaURI $ T.pack pName )
333 arrIO2 (flip setAttribute "@title" ) -< (doc, Just $ T.pack pName )
334 arrIO2 (flip setAttribute "@type" ) -< (doc, Just "application/x-rakka-redirection")
335 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just $ T.pack pLastMod )
336 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just $ T.pack pIsLocked )
337 arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just $ T.pack pRevision )
339 -- リダイレクト先ページ名はテキストとして入れる
340 arrIO2 addText ⤙ (doc, T.pack pRedir)
344 addElemText :: Document -> Element -> IO ()
345 addElemText doc (Block b) = addBlockText doc b
346 addElemText doc (Inline i) = addInlineText doc i
348 addBlockText :: Document -> BlockElement -> IO ()
349 addBlockText doc (Heading _ text) = addText doc text
350 addBlockText _ HorizontalLine = return ()
351 addBlockText doc (List _ items) = mapM_ (addListItemText doc) items
352 addBlockText doc (DefinitionList defs) = mapM_ (addDefinitionText doc) defs
353 addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
354 addBlockText doc (Paragraph inlines) = mapM_ (addInlineText doc) inlines
355 addBlockText doc (Div _ elems) = mapM_ (addElemText doc) elems
356 addBlockText _ EmptyBlock = return ()
357 addBlockText doc (BlockCmd bcmd) = addBlockCmdText doc bcmd
359 addInlineText ∷ Document → InlineElement → IO ()
360 addInlineText doc (Text text) = addText doc text
361 addInlineText doc (Italic inlines) = mapM_ (addInlineText doc) inlines
362 addInlineText doc (Bold inlines) = mapM_ (addInlineText doc) inlines
363 addInlineText doc (ObjectLink page Nothing) = addText doc page
364 addInlineText doc (ObjectLink page (Just text)) = addHiddenText doc page
366 addInlineText doc (PageLink page fragm Nothing) = addText doc (fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragm)
367 addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragm)
369 addInlineText doc (ExternalLink uri Nothing) = addText doc (T.pack $ uriToString id uri "")
370 addInlineText doc (ExternalLink uri (Just text)) = addHiddenText doc (T.pack $ uriToString id uri "")
372 addInlineText _ (LineBreak _) = return ()
373 addInlineText doc (Span _ inlines) = mapM_ (addInlineText doc) inlines
374 addInlineText doc (Image src alt) = do case src of
375 Left uri -> addHiddenText doc (T.pack $ uriToString id uri "")
376 Right page -> addHiddenText doc page
378 Just text -> addHiddenText doc text
380 addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines
381 addInlineText _ (Input _) = return ()
382 addInlineText _ EmptyInline = return ()
383 addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
385 addListItemText :: Document -> ListItem -> IO ()
386 addListItemText = mapM_ . addElemText
388 addDefinitionText :: Document -> Definition -> IO ()
389 addDefinitionText doc (Definition term desc)
390 = do mapM_ (addInlineText doc) term
391 mapM_ (addInlineText doc) desc
393 addBlockCmdText :: Document -> BlockCommand -> IO ()
394 addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
396 addInlineCmdText :: Document -> InlineCommand -> IO ()
397 addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
400 makePageLinkList ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
404 → XmlTree ⇝ [PageName]
405 makePageLinkList sto sysConf interpTable
407 → do wiki ← wikifyPage interpTable ⤙ tree
408 pName ← getXPathTreesInDoc "/page/@name/text()" ⋙ getText ⤙ tree
409 interpreted ← interpretCommands sto sysConf interpTable
410 ⤙ (Just (T.pack pName), Just tree, Just wiki, wiki)
411 returnA ⤙ concatMap extractFromBlock interpreted
413 extractFromElem :: Element -> [PageName]
414 extractFromElem (Block b) = extractFromBlock b
415 extractFromElem (Inline i) = extractFromInline i
417 extractFromBlock :: BlockElement -> [PageName]
418 extractFromBlock (List _ items) = concatMap extractFromListItem items
419 extractFromBlock (DefinitionList defs) = concatMap extractFromDefinition defs
420 extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines
421 extractFromBlock (Paragraph inlines) = concatMap extractFromInline inlines
422 extractFromBlock (Div _ elems) = concatMap extractFromElem elems
423 extractFromBlock _ = []
425 extractFromInline :: InlineElement -> [PageName]
426 extractFromInline (Italic inlines) = concatMap extractFromInline inlines
427 extractFromInline (Bold inlines) = concatMap extractFromInline inlines
428 extractFromInline (Span _ inlines) = concatMap extractFromInline inlines
429 extractFromInline (PageLink (Just name) _ _) = [name]
430 extractFromInline _ = []
432 extractFromListItem :: ListItem -> [PageName]
433 extractFromListItem = concatMap extractFromElem
435 extractFromDefinition :: Definition -> [PageName]
436 extractFromDefinition (Definition term desc)
437 = concatMap extractFromInline term
439 concatMap extractFromInline desc
441 wikifyParseError ∷ Arrow (⇝) ⇒ ParseError ⇝ WikiPage
442 wikifyParseError = proc err
443 → returnA -< [Div [("class", "error")]
444 [ Block (Preformatted [Text (T.pack $ show err)]) ]]