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
19 import qualified Data.Map as M
21 import Network.HTTP.Lucu
25 import Rakka.SystemConfig
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
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) => a Page XmlTree
75 += sattr "name" (pageName page)
76 += sattr "type" (show $ pageType page)
77 += ( case pageLanguage page of
78 Just x -> sattr "lang" x
81 += ( case pageFileName page of
82 Just x -> sattr "fileName" x
85 += ( case pageType page of
86 MIMEType "text" "css" _
87 -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
88 MIMEType "text" "x-rakka" _
89 -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
93 += sattr "isLocked" (yesOrNo $ pageIsLocked page)
94 += sattr "isBoring" (yesOrNo $ pageIsBoring page)
95 += sattr "isBinary" (yesOrNo $ pageIsBinary page)
96 += sattr "revision" (show $ pageRevision page)
97 += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
98 += ( case pageSummary page of
99 Just s -> eelem "summary" += txt s
102 += ( if M.null (pageOtherLang page) then
109 | (lang, page) <- M.toList (pageOtherLang page) ]
111 += ( if pageIsBinary page then
113 += txt (B64.encode $ L.unpack $ pageContent page)
117 += txt (decodeLazy UTF8 $ 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 pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree
130 pFileName <- maybeA (getXPathTreesInDoc "/page/fileName/text()" >>> getText) -< tree
131 textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree
134 MIMEType "text" "x-rakka" _
135 -> case parse (wikiPage cmdTypeOf) "" (fromJust textData) of
136 Left err -> wikifyParseError -< err
137 Right xs -> returnA -< xs
140 -> returnA -< [ Paragraph [Image pName Nothing] ]
142 _ -> if pIsBinary == "yes" then
143 returnA -< [ Paragraph [ ObjectLink {
145 , objLinkText = Just $ fromMaybe (defaultFileName pType pName) pFileName
151 returnA -< [ Preformatted [Text $ fromJust textData] ]
153 cmdTypeOf :: String -> Maybe CommandType
155 = fmap commandType (M.lookup name interpTable)
157 binToURI :: MIMEType -> String -> URI
158 binToURI pType base64Data
161 , uriPath = show pType ++ ";base64," ++ (stripWhiteSpace base64Data)
164 stripWhiteSpace :: String -> String
165 stripWhiteSpace [] = []
166 stripWhiteSpace (x:xs)
167 | x `elem` " \t\n" = stripWhiteSpace xs
168 | otherwise = x : stripWhiteSpace xs
171 makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
176 makeMainXHTML sto sysConf interpTable
178 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
179 wiki <- wikifyPage interpTable -< tree
180 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
181 interpreted <- interpretCommands sto sysConf interpTable
182 -< (pName, Just (tree, wiki), wiki)
183 formatWikiBlocks -< (baseURI, interpreted)
186 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
190 -> a (PageName, Maybe XmlTree, XmlTree) XmlTree
191 makeSubXHTML sto sysConf interpTable
192 = proc (mainPageName, mainPage, subPage)
193 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
194 mainWiki <- case mainPage of
196 -> do wiki <- wikifyPage interpTable -< page
197 returnA -< Just (page, wiki)
199 -> returnA -< Nothing
200 subWiki <- wikifyPage interpTable -< subPage
201 interpreted <- interpretCommands sto sysConf interpTable
202 -< (mainPageName, mainWiki, subWiki)
203 formatWikiBlocks -< (baseURI, interpreted)
206 interpretCommands :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
210 -> a (PageName, Maybe (XmlTree, WikiPage), WikiPage) WikiPage
211 interpretCommands sto sysConf interpTable
212 = proc (name, mainPageAndWiki, targetWiki)
213 -> let ctx = InterpreterContext {
215 , ctxMainPage = fmap fst mainPageAndWiki
216 , ctxMainWiki = fmap snd mainPageAndWiki
217 , ctxTargetWiki = targetWiki
219 , ctxSysConf = sysConf
222 ( arrIO (everywhereM' (mkM $ interpBlockCmd ctx))
224 arrIO (everywhereM' (mkM $ interpInlineCmd ctx))
227 interpBlockCmd :: InterpreterContext -> BlockElement -> IO BlockElement
228 interpBlockCmd ctx (BlockCmd cmd) = interpBlockCmd' ctx cmd
229 interpBlockCmd _ others = return others
231 interpBlockCmd' :: InterpreterContext -> BlockCommand -> IO BlockElement
232 interpBlockCmd' ctx cmd
233 = case M.lookup (bCmdName cmd) interpTable of
235 -> fail ("no such interpreter: " ++ bCmdName cmd)
238 -> bciInterpret interp ctx cmd
241 interpInlineCmd :: InterpreterContext -> InlineElement -> IO InlineElement
242 interpInlineCmd ctx (InlineCmd cmd) = interpInlineCmd' ctx cmd
243 interpInlineCmd _ others = return others
245 interpInlineCmd' :: InterpreterContext -> InlineCommand -> IO InlineElement
246 interpInlineCmd' ctx cmd
247 = case M.lookup (iCmdName cmd) interpTable of
249 -> fail ("no such interpreter: " ++ iCmdName cmd)
252 -> iciInterpret interp ctx cmd
255 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
256 makeDraft interpTable
258 do doc <- arrIO0 newDocument -< ()
260 pName <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
261 pType <- getXPathTreesInDoc "/page/@type/text()" >>> getText -< tree
262 pLastMod <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
263 pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()" >>> getText -< tree
264 pIsBoring <- getXPathTreesInDoc "/page/@isBoring/text()" >>> getText -< tree
265 pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()" >>> getText -< tree
266 pRevision <- getXPathTreesInDoc "/page/@revision/text()" >>> getText -< tree
267 pLang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree
268 pFileName <- maybeA (getXPathTreesInDoc "/page/@fileName/text()" >>> getText) -< tree
269 pIsTheme <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) -< tree
270 pIsFeed <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) -< tree
271 pSummary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< tree
273 arrIO2 setURI -< (doc, Just $ mkRakkaURI pName)
274 arrIO2 (flip setAttribute "@title" ) -< (doc, Just pName)
275 arrIO2 (flip setAttribute "@type" ) -< (doc, Just pType)
276 arrIO2 (flip setAttribute "@mdate" ) -< (doc, Just pLastMod)
277 arrIO2 (flip setAttribute "@lang" ) -< (doc, pLang)
278 arrIO2 (flip setAttribute "rakka:fileName") -< (doc, pFileName)
279 arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
280 arrIO2 (flip setAttribute "rakka:isBoring") -< (doc, Just pIsBoring)
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 wikiPage <- wikifyPage interpTable -< tree
308 arrIO0 (everywhereM' (mkM (addBlockText doc)) wikiPage) -<< ()
309 arrIO0 (everywhereM' (mkM (addInlineText doc)) wikiPage) -<< ()
317 addBlockText :: Document -> BlockElement -> IO BlockElement
325 addInlineText :: Document -> InlineElement -> IO InlineElement
330 ObjectLink page Nothing
332 ObjectLink page (Just text)
333 -> do addHiddenText doc page
335 PageLink page fragment Nothing
336 -> addText doc (fromMaybe "" page ++
337 fromMaybe "" fragment)
338 PageLink page fragment (Just text)
339 -> do addHiddenText doc (fromMaybe "" page ++
340 fromMaybe "" fragment)
342 ExternalLink uri Nothing
343 -> addText doc (uriToString id uri "")
344 ExternalLink uri (Just text)
345 -> do addHiddenText doc (uriToString id uri "")
350 -- Perform monadic transformation in top-down order.
351 everywhereM' :: Monad m => GenericM m -> GenericM m
352 everywhereM' f x = f x >>= gmapM (everywhereM' f)
355 wikifyParseError :: Arrow a => a ParseError WikiPage
356 wikifyParseError = proc err
357 -> returnA -< [Div [("class", "error")]
358 [ Block (Preformatted [Text (show err)]) ]]