1 module Rakka.Wiki.Engine
10 import Control.Arrow.ArrowIO
11 import Control.Arrow.ArrowList
13 import Data.Encoding.UTF8
16 import qualified Data.Map as M
18 import Network.HTTP.Lucu
22 import Rakka.SystemConfig
25 import Rakka.Wiki.Parser
26 import Rakka.Wiki.Formatter
27 import Rakka.Wiki.Interpreter
28 import Text.HyperEstraier hiding (getText)
29 import Text.ParserCombinators.Parsec
30 import Text.XML.HXT.Arrow.Namespace
31 import Text.XML.HXT.Arrow.XmlArrow
32 import Text.XML.HXT.DOM.TypeDefs
35 type InterpTable = Map String Interpreter
38 formatEntirePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
43 formatEntirePage sto sysConf interpTable
45 -> do SiteName siteName <- getSysConfA sysConf -< ()
46 BaseURI baseURI <- getSysConfA sysConf -< ()
47 StyleSheet cssName <- getSysConfA sysConf -< ()
49 Just pageTitle <- getPageA sto -< ("PageTitle" , Nothing)
50 Just leftSideBar <- getPageA sto -< ("SideBar/Left" , Nothing)
51 Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing)
55 += sattr "site" siteName
56 += sattr "baseURI" (uriToString id baseURI "")
57 += sattr "name" (pageName page)
58 += sattr "type" (show $ pageType page)
59 += ( case pageLanguage page of
60 Just x -> sattr "lang" x
63 += ( case pageFileName page of
64 Just x -> sattr "fileName" x
67 += ( case pageType page of
68 MIMEType "text" "css" _
69 -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
72 += ( case pageType page of
73 MIMEType "text" "x-rakka" _
74 -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
77 += sattr "isLocked" (yesOrNo $ pageIsLocked page)
78 += sattr "isBoring" (yesOrNo $ pageIsBoring page)
79 += sattr "isBinary" (yesOrNo $ pageIsBinary page)
80 += sattr "revision" (show $ pageRevision page)
81 += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
83 += ( eelem "styleSheets"
84 += ( eelem "styleSheet"
85 += sattr "src" (uriToString id (mkObjectURI baseURI cssName) "")
91 += sattr "src" (uriToString id (baseURI { uriPath = "/js" }) "")
95 += ( case pageSummary page of
97 Just s -> eelem "summary" += txt s
100 += ( if M.null (pageOtherLang page) then
107 | (lang, page) <- M.toList (pageOtherLang page) ]
109 += ( eelem "pageTitle"
110 += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
112 formatSubPage sto sysConf interpTable
117 += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
119 formatSubPage sto sysConf interpTable
123 += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
125 formatSubPage sto sysConf interpTable
130 += (constA page >>> formatMainPage sto sysConf interpTable)
132 += (constA page >>> formatSource)
134 uniqueNamespacesFromDeclAndQNames
140 formatSource :: (ArrowXml a, ArrowChoice a) => a Page XmlTree
141 formatSource = proc page
142 -> if pageIsBinary page then
145 let source = decodeLazy UTF8 (pageContent page)
147 ( eelem "source" += mkText ) -< source
150 formatUnexistentPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
154 -> a PageName XmlTree
155 formatUnexistentPage sto sysConf interpTable
157 -> do SiteName siteName <- getSysConfA sysConf -< ()
158 BaseURI baseURI <- getSysConfA sysConf -< ()
159 StyleSheet cssName <- getSysConfA sysConf -< ()
161 Just pageTitle <- getPageA sto -< ("PageTitle" , Nothing)
162 Just leftSideBar <- getPageA sto -< ("SideBar/Left" , Nothing)
163 Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing)
166 += ( eelem "pageNotFound"
167 += sattr "site" siteName
168 += sattr "baseURI" (uriToString id baseURI "")
171 += ( eelem "styleSheets"
172 += ( eelem "styleSheet"
173 += sattr "src" (uriToString id (mkObjectURI baseURI cssName) "")
179 += sattr "src" (uriToString id (baseURI { uriPath = "/js" }) "")
183 += ( eelem "pageTitle"
184 += ( (constA name &&& constA Nothing &&& constA pageTitle)
186 formatSubPage sto sysConf interpTable
191 += ( (constA name &&& constA Nothing &&& constA leftSideBar)
193 formatSubPage sto sysConf interpTable
197 += ( (constA name &&& constA Nothing &&& constA rightSideBar)
199 formatSubPage sto sysConf interpTable
204 uniqueNamespacesFromDeclAndQNames
210 formatMainPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
215 formatMainPage sto sysConf interpTable
217 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
218 wiki <- arr2 wikifyPage -< (interpTable, page)
219 xs <- interpretCommandsA sto sysConf interpTable
220 -< (pageName page, Just (page, wiki), wiki)
221 formatWikiBlocks -< (baseURI, xs)
224 formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
228 -> a (PageName, (Maybe Page, Page)) XmlTree
229 formatSubPage sto sysConf interpTable
230 = proc (mainPageName, (mainPage, subPage))
231 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
232 mainWiki <- case mainPage of
234 -> do wiki <- arr2 wikifyPage -< (interpTable, page)
235 returnA -< Just (page, wiki)
237 -> returnA -< Nothing
238 subWiki <- arr2 wikifyPage -< (interpTable, subPage)
239 xs <- interpretCommandsA sto sysConf interpTable
240 -< (mainPageName, mainWiki, subWiki)
241 formatWikiBlocks -< (baseURI, xs)
244 wikifyPage :: InterpTable -> Page -> WikiPage
245 wikifyPage interpTable page
246 = case pageType page of
247 MIMEType "text" "x-rakka" _
248 -> let source = decodeLazy UTF8 (pageContent page)
249 parser = wikiPage tableToFunc
251 case parse parser "" source of
252 Left err -> wikifyParseError err
256 -> [ Paragraph [ Image (pageName page) Nothing ] ]
258 _ -> if pageIsBinary page then
260 [ Paragraph [ ObjectLink (pageName page) (Just $ pageFileName' page) ] ]
263 let text = decodeLazy UTF8 (pageContent page)
265 [ Preformatted [ Text text ] ]
267 tableToFunc :: String -> Maybe CommandType
269 = fmap commandType (M.lookup name interpTable)
272 interpretCommandsA :: (ArrowIO a, ArrowApply a) =>
276 -> a (PageName, Maybe (Page, WikiPage), WikiPage) WikiPage
277 interpretCommandsA sto sysConf interpTable
278 = proc (name, mainPageAndTree, targetTree)
279 -> arrIO0 (interpretCommands sto sysConf interpTable name mainPageAndTree targetTree)
283 interpretCommands :: Storage
287 -> Maybe (Page, WikiPage)
290 interpretCommands sto sysConf interpTable name mainPageAndTree targetTree
291 = everywhereM' (mkM interpBlockCmd) targetTree
293 everywhereM' (mkM interpInlineCmd)
295 ctx :: InterpreterContext
296 ctx = InterpreterContext {
298 , ctxMainPage = fmap fst mainPageAndTree
299 , ctxMainTree = fmap snd mainPageAndTree
300 , ctxTargetTree = targetTree
302 , ctxSysConf = sysConf
305 interpBlockCmd :: BlockElement -> IO BlockElement
306 interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
307 interpBlockCmd others = return others
309 interpBlockCmd' :: BlockCommand -> IO BlockElement
311 = case M.lookup (bCmdName cmd) interpTable of
313 -> fail ("no such interpreter: " ++ bCmdName cmd)
316 -> bciInterpret interp ctx cmd
319 interpInlineCmd :: InlineElement -> IO InlineElement
320 interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
321 interpInlineCmd others = return others
323 interpInlineCmd' :: InlineCommand -> IO InlineElement
325 = case M.lookup (iCmdName cmd) interpTable of
327 -> fail ("no such interpreter: " ++ iCmdName cmd)
330 -> iciInterpret interp ctx cmd
333 makeDraft :: InterpTable -> Page -> IO Document
334 makeDraft interpTable page
335 = do doc <- newDocument
337 setURI doc $ Just $ mkRakkaURI $ pageName page
338 setAttribute doc "@title" $ Just $ pageName page
339 setAttribute doc "@lang" $ pageLanguage page
340 setAttribute doc "@type" $ Just $ show $ pageType page
341 setAttribute doc "@mdate" $ Just $ formatW3CDateTime $ pageLastMod page
342 setAttribute doc "rakka:fileName" $ pageFileName page
343 setAttribute doc "rakka:isLocked" $ Just $ yesOrNo $ pageIsLocked page
344 setAttribute doc "rakka:isBoring" $ Just $ yesOrNo $ pageIsBoring page
345 setAttribute doc "rakka:isBinary" $ Just $ yesOrNo $ pageIsBinary page
346 setAttribute doc "rakka:revision" $ Just $ show $ pageRevision page
347 setAttribute doc "rakka:summary" $ pageSummary page
349 addHiddenText doc (pageName page)
351 case pageType page of
352 MIMEType "text" "css" _
353 -> setAttribute doc "rakka:isTheme" $ Just $ yesOrNo $ pageIsTheme page
354 MIMEType "text" "x-rakka" _
355 -> setAttribute doc "rakka:isFeed" $ Just $ yesOrNo $ pageIsFeed page
358 case pageSummary page of
360 Just s -> addHiddenText doc s
362 -- otherLang はリンク先ページ名を hidden text で入れる。
363 sequence_ [ addHiddenText doc x
364 | (_, x) <- M.toList (pageOtherLang page) ]
366 -- wikify して興味のある部分を addText する。
367 let wikiPage = wikifyPage interpTable page
368 everywhereM' (mkM (addBlockText doc)) wikiPage
369 everywhereM' (mkM (addInlineText doc)) wikiPage
373 addBlockText :: Document -> BlockElement -> IO BlockElement
381 addInlineText :: Document -> InlineElement -> IO InlineElement
386 ObjectLink page Nothing
388 ObjectLink page (Just text)
389 -> do addHiddenText doc page
391 PageLink page fragment Nothing
392 -> addText doc (fromMaybe "" page ++
393 fromMaybe "" fragment)
394 PageLink page fragment (Just text)
395 -> do addHiddenText doc (fromMaybe "" page ++
396 fromMaybe "" fragment)
398 ExternalLink uri Nothing
399 -> addText doc (uriToString id uri "")
400 ExternalLink uri (Just text)
401 -> do addHiddenText doc (uriToString id uri "")
407 -- Perform monadic transformation in top-down order.
408 everywhereM' :: Monad m => GenericM m -> GenericM m
409 everywhereM' f x = f x >>= gmapM (everywhereM' f)
412 wikifyParseError :: ParseError -> WikiPage
414 = [Div [("class", "error")]
415 [ Block (Preformatted [Text (show err)]) ]]