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"
50 Just leftSideBar <- getPageA sto -< "SideBar/Left"
51 Just rightSideBar <- getPageA sto -< "SideBar/Right"
55 += sattr "site" siteName
56 += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
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 += ( case pageSummary page of
85 Just s -> eelem "summary" += txt s
88 += ( if M.null (pageOtherLang page) then
95 | (lang, page) <- M.toList (pageOtherLang page) ]
97 += ( eelem "pageTitle"
98 += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
100 formatSubPage sto sysConf interpTable
105 += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
107 formatSubPage sto sysConf interpTable
111 += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
113 formatSubPage sto sysConf interpTable
118 += (constA page >>> formatMainPage sto sysConf interpTable)
121 uniqueNamespacesFromDeclAndQNames
127 formatUnexistentPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
131 -> a PageName XmlTree
132 formatUnexistentPage sto sysConf interpTable
134 -> do SiteName siteName <- getSysConfA sysConf -< ()
135 BaseURI baseURI <- getSysConfA sysConf -< ()
136 StyleSheet cssName <- getSysConfA sysConf -< ()
138 Just pageTitle <- getPageA sto -< "PageTitle"
139 Just leftSideBar <- getPageA sto -< "SideBar/Left"
140 Just rightSideBar <- getPageA sto -< "SideBar/Right"
143 += ( eelem "pageNotFound"
144 += sattr "site" siteName
145 += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
148 += ( eelem "pageTitle"
149 += ( (constA name &&& constA Nothing &&& constA pageTitle)
151 formatSubPage sto sysConf interpTable
156 += ( (constA name &&& constA Nothing &&& constA leftSideBar)
158 formatSubPage sto sysConf interpTable
162 += ( (constA name &&& constA Nothing &&& constA rightSideBar)
164 formatSubPage sto sysConf interpTable
169 uniqueNamespacesFromDeclAndQNames
175 formatMainPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
180 formatMainPage sto sysConf interpTable
182 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
183 wiki <- arr2 wikifyPage -< (interpTable, page)
184 xs <- interpretCommandsA sto sysConf interpTable
185 -< (pageName page, Just (page, wiki), wiki)
186 formatWikiBlocks -< (baseURI, xs)
189 formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
193 -> a (PageName, (Maybe Page, Page)) XmlTree
194 formatSubPage sto sysConf interpTable
195 = proc (mainPageName, (mainPage, subPage))
196 -> do BaseURI baseURI <- getSysConfA sysConf -< ()
197 mainWiki <- case mainPage of
199 -> do wiki <- arr2 wikifyPage -< (interpTable, page)
200 returnA -< Just (page, wiki)
202 -> returnA -< Nothing
203 subWiki <- arr2 wikifyPage -< (interpTable, subPage)
204 xs <- interpretCommandsA sto sysConf interpTable
205 -< (mainPageName, mainWiki, subWiki)
206 formatWikiBlocks -< (baseURI, xs)
209 wikifyPage :: InterpTable -> Page -> WikiPage
210 wikifyPage interpTable page
211 = case pageType page of
212 MIMEType "text" "x-rakka" _
213 -> let source = decodeLazy UTF8 (pageContent page)
214 parser = wikiPage tableToFunc
216 case parse parser "" source of
217 Left err -> wikifyParseError err
221 -> [ Paragraph [ Image (pageName page) Nothing ] ]
223 _ -> if pageIsBinary page then
225 [ Paragraph [ ObjectLink (pageName page) (Just $ pageFileName' page) ] ]
228 let text = decodeLazy UTF8 (pageContent page)
230 [ Preformatted [ Text text ] ]
232 tableToFunc :: String -> Maybe CommandType
234 = fmap commandType (M.lookup name interpTable)
237 interpretCommandsA :: (ArrowIO a, ArrowApply a) =>
241 -> a (PageName, Maybe (Page, WikiPage), WikiPage) WikiPage
242 interpretCommandsA sto sysConf interpTable
243 = proc (name, mainPageAndTree, targetTree)
244 -> arrIO0 (interpretCommands sto sysConf interpTable name mainPageAndTree targetTree)
248 interpretCommands :: Storage
252 -> Maybe (Page, WikiPage)
255 interpretCommands sto sysConf interpTable name mainPageAndTree targetTree
256 = everywhereM' (mkM interpBlockCmd) targetTree
258 everywhereM' (mkM interpInlineCmd)
260 ctx :: InterpreterContext
261 ctx = InterpreterContext {
263 , ctxMainPage = fmap fst mainPageAndTree
264 , ctxMainTree = fmap snd mainPageAndTree
265 , ctxTargetTree = targetTree
267 , ctxSysConf = sysConf
270 interpBlockCmd :: BlockElement -> IO BlockElement
271 interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
272 interpBlockCmd others = return others
274 interpBlockCmd' :: BlockCommand -> IO BlockElement
276 = case M.lookup (bCmdName cmd) interpTable of
278 -> fail ("no such interpreter: " ++ bCmdName cmd)
281 -> bciInterpret interp ctx cmd
284 interpInlineCmd :: InlineElement -> IO InlineElement
285 interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
286 interpInlineCmd others = return others
288 interpInlineCmd' :: InlineCommand -> IO InlineElement
290 = case M.lookup (iCmdName cmd) interpTable of
292 -> fail ("no such interpreter: " ++ iCmdName cmd)
295 -> iciInterpret interp ctx cmd
298 makeDraft :: InterpTable -> Page -> IO Document
299 makeDraft interpTable page
300 = do doc <- newDocument
302 setURI doc $ Just $ mkRakkaURI $ pageName page
303 setAttribute doc "@title" $ Just $ pageName page
304 setAttribute doc "@lang" $ pageLanguage page
305 setAttribute doc "@type" $ Just $ show $ pageType page
306 setAttribute doc "@mdate" $ Just $ formatW3CDateTime $ pageLastMod page
307 setAttribute doc "rakka:fileName" $ pageFileName page
308 setAttribute doc "rakka:isLocked" $ Just $ yesOrNo $ pageIsLocked page
309 setAttribute doc "rakka:isBoring" $ Just $ yesOrNo $ pageIsBoring page
310 setAttribute doc "rakka:isBinary" $ Just $ yesOrNo $ pageIsBinary page
311 setAttribute doc "rakka:revision" $ Just $ show $ pageRevision page
313 case pageType page of
314 MIMEType "text" "css" _
315 -> setAttribute doc "rakka:isTheme" $ Just $ yesOrNo $ pageIsTheme page
316 MIMEType "text" "x-rakka" _
317 -> setAttribute doc "rakka:isFeed" $ Just $ yesOrNo $ pageIsFeed page
320 case pageSummary page of
322 Just s -> addHiddenText doc s
324 -- otherLang はリンク先ページ名を hidden text で入れる。
325 sequence_ [ addHiddenText doc x
326 | (_, x) <- M.toList (pageOtherLang page) ]
328 -- wikify して興味のある部分を addText する。
329 let wikiPage = wikifyPage interpTable page
330 everywhereM' (mkM (addBlockText doc)) wikiPage
331 everywhereM' (mkM (addInlineText doc)) wikiPage
335 addBlockText :: Document -> BlockElement -> IO BlockElement
343 addInlineText :: Document -> InlineElement -> IO InlineElement
348 ObjectLink page Nothing
350 ObjectLink page (Just text)
351 -> do addHiddenText doc page
353 PageLink page fragment Nothing
354 -> addText doc (fromMaybe "" page ++
355 fromMaybe "" fragment)
356 PageLink page fragment (Just text)
357 -> do addHiddenText doc (fromMaybe "" page ++
358 fromMaybe "" fragment)
360 ExternalLink uri Nothing
361 -> addText doc (uriToString id uri "")
362 ExternalLink uri (Just text)
363 -> do addHiddenText doc (uriToString id uri "")
369 -- Perform monadic transformation in top-down order.
370 everywhereM' :: Monad m => GenericM m -> GenericM m
371 everywhereM' f x = f x >>= gmapM (everywhereM' f)
374 wikifyParseError :: ParseError -> WikiPage
376 = [Div [("class", "error")]
377 [ Preformatted [Text (show err)] ]]