1 module Rakka.Resource.PageEntity
6 import Control.Monad.Trans
8 import qualified Data.Map as M
11 import Network.HTTP.Lucu
12 import Network.HTTP.Lucu.Utils
13 import Network.URI hiding (path)
14 import Rakka.Environment
18 import Rakka.SystemConfig
20 import Rakka.W3CDateTime
21 import Rakka.Wiki.Engine
22 import System.FilePath
23 import Text.HyperEstraier hiding (getText)
24 import Text.XML.HXT.Arrow
25 import Text.XML.HXT.DOM.TypeDefs
26 import Text.XML.HXT.DOM.XmlKeywords
29 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
30 fallbackPageEntity env path
31 | null path = return Nothing
32 | null $ head path = return Nothing
33 | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
35 = return $ Just $ ResourceDef {
36 resUsesNativeThread = False
38 , resGet = Just $ handleGet env (toPageName path)
41 , resPut = Just $ handlePut env (toPageName path)
42 , resDelete = Just $ handleDelete env (toPageName path)
45 toPageName :: [String] -> PageName
46 toPageName = decodePageName . dropExtension . joinWith "/"
49 handleGet :: Environment -> PageName -> Resource ()
51 = do BaseURI baseURI <- getSysConf (envSysConf env)
52 runIdempotentA baseURI $ proc ()
53 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
56 -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
58 [] -> handlePageNotFound env -< name
59 _ -> handleGetPageListing env -< (name, items)
61 -> if isEntity page then
62 handleGetEntity env -< page
64 handleRedirect env -< page
69 Location: http://example.org/Destination.html#Redirect:Source
71 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
74 -> returnA -< do mType <- getEntityType
76 MIMEType "text" "xml" _
77 -> do setContentType mType
78 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
84 writeDocumentToString [ (a_indent, v_1) ]
88 _ -> do BaseURI baseURI <- getSysConf (envSysConf env)
89 let uri = mkPageFragmentURI
92 ("Redirect:" ++ redirName redir)
96 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
99 -> do tree <- xmlizePage -< page
100 returnA -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
101 , (MIMEType "application" "rss+xml" [], entityToRSS env)
105 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
108 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
109 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
110 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
111 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
113 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
114 isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
116 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
117 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
119 feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
121 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
122 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
123 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
124 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
128 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
129 += ( getXPathTreesInDoc "/page/@lang"
131 qattr (mkQName "xml" "lang" "")
132 ( getXPathTreesInDoc "/page/@lang/text()" )
138 += getXPathTreesInDoc "/page/@name/text()"
143 += sattr "rel" "stylesheet"
144 += sattr "type" "text/css"
145 += attr "href" (arr id >>> mkText)
150 += sattr "rel" "alternate"
151 += sattr "type" "application/rss+xml"
152 += attr "title" (txt siteName <+> txt " - " <+> mkText)
153 += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText)
155 += ( constL scriptSrc
158 += sattr "type" "text/javascript"
159 += attr "src" (arr id >>> mkText)
162 += sattr "type" "text/javascript"
163 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
164 += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
165 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
170 += sattr "class" "header"
173 += sattr "class" "center"
175 += sattr "class" "title"
179 += sattr "class" "body"
184 += sattr "class" "footer"
187 += sattr "class" "left sideBar"
189 += sattr "class" "content"
190 += constL leftSideBar
194 += sattr "class" "right sideBar"
196 += sattr "class" "content"
197 += constL rightSideBar
202 uniqueNamespacesFromDeclAndQNames
206 entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
209 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
210 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
212 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
213 summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
214 pages <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
218 += sattr "xmlns" "http://purl.org/rss/1.0/"
219 += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
220 += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/"
221 += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
223 += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
227 += getXPathTreesInDoc "/page/@name/text()"
230 += txt (uriToString id baseURI "")
232 += ( eelem "description"
233 += txt (case summary of
234 Nothing -> "RSS Feed for " ++ siteName
242 += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
249 arr (\ n -> (n, Nothing))
251 getPageA (envStorage env)
256 += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
258 += (arr entityName >>> mkText)
261 += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
263 += ( arrL (\ p -> case entitySummary p of
271 += ( arrIO (utcToLocalZonedTime . entityLastMod)
273 arr formatW3CDateTime
278 += ( eelem "trackback:ping"
279 += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
283 uniqueNamespacesFromDeclAndQNames
286 mkPageURIStr :: URI -> PageName -> String
287 mkPageURIStr baseURI name
288 = uriToString id (mkPageURI baseURI name) ""
290 mkTrackbackURIStr :: URI -> PageName -> String
291 mkTrackbackURIStr baseURI name
292 = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
295 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
297 -> a (PageName, Maybe XmlTree, PageName) XmlTree
299 = proc (mainPageName, mainPage, subPageName) ->
300 do langM <- case mainPage of
302 -> returnA -< Nothing
304 -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p
305 subPage <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing)
306 localSubPage <- case langM of
308 -> returnA -< subPage
310 -> localize (envStorage env) -< (l, subPage)
311 subPageXml <- xmlizePage -< localSubPage
312 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
313 -< (Just mainPageName, mainPage, subPageXml)
316 localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page
318 = proc (lang, origPage)
319 -> do let otherLang = entityOtherLang origPage
320 localName = M.lookup lang otherLang
323 -> returnA -< origPage
325 -> do localPage <- getPageA sto -< (ln, Nothing)
326 returnA -< case localPage of
332 <pageListing path="Foo">
333 <page name="Foo/Bar" />
334 <page name="Foo/Baz" />
337 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
338 handleGetPageListing env
340 -> do tree <- ( eelem "/"
341 += ( eelem "pageListing"
342 += attr "path" (arr fst >>> mkText)
346 += attr "name" (arr id >>> mkText)
351 returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
354 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
355 pageListingToXHTML env
357 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
358 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
359 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
360 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
362 name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
364 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
365 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
367 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
368 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
369 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
373 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
378 += getXPathTreesInDoc "/pageListing/@path/text()"
383 += sattr "rel" "stylesheet"
384 += sattr "type" "text/css"
385 += attr "href" (arr id >>> mkText)
387 += ( constL scriptSrc
390 += sattr "type" "text/javascript"
391 += attr "src" (arr id >>> mkText)
394 += sattr "type" "text/javascript"
395 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
396 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
401 += sattr "class" "header"
404 += sattr "class" "center"
406 += sattr "class" "title"
410 += sattr "class" "body"
412 += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
416 += attr "href" ( getText
418 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
429 += sattr "class" "footer"
432 += sattr "class" "left sideBar"
434 += sattr "class" "content"
435 += constL leftSideBar
439 += sattr "class" "right sideBar"
441 += sattr "class" "content"
442 += constL rightSideBar
447 uniqueNamespacesFromDeclAndQNames
452 <pageNotFound name="Foo/Bar" />
454 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
455 handlePageNotFound env
457 -> do tree <- ( eelem "/"
458 += ( eelem "pageNotFound"
459 += attr "name" (arr id >>> mkText)
462 returnA -< do setStatus NotFound
463 outputXmlPage' tree (notFoundToXHTML env)
466 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
469 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
470 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
471 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
472 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
474 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
476 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
477 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
479 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
480 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
481 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
485 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
490 += getXPathTreesInDoc "/pageNotFound/@name/text()"
495 += sattr "rel" "stylesheet"
496 += sattr "type" "text/css"
497 += attr "href" (arr id >>> mkText)
499 += ( constL scriptSrc
502 += sattr "type" "text/javascript"
503 += attr "src" (arr id >>> mkText)
506 += sattr "type" "text/javascript"
507 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
508 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
513 += sattr "class" "header"
516 += sattr "class" "center"
518 += sattr "class" "title"
522 += sattr "class" "body"
523 += txt "404 Not Found (FIXME)" -- FIXME
527 += sattr "class" "footer"
530 += sattr "class" "left sideBar"
532 += sattr "class" "content"
533 += constL leftSideBar
537 += sattr "class" "right sideBar"
539 += sattr "class" "content"
540 += constL rightSideBar
545 uniqueNamespacesFromDeclAndQNames
549 handlePut :: Environment -> PageName -> Resource ()
551 = do userID <- getUserID env
552 runXmlA env "rakka-page-1.0.rng" $ proc tree
553 -> do page <- parseXmlizedPage -< (name, tree)
554 status <- putPageA (envStorage env) -< (userID, page)
555 returnA -< setStatus status
558 handleDelete :: Environment -> PageName -> Resource ()
559 handleDelete env name
560 = do userID <- getUserID env
561 status <- deletePage (envStorage env) userID name
565 findFeeds :: Storage -> IO [PageName]
567 = do cond <- newCondition
568 setPhrase cond "[UVSET]"
569 addAttrCond cond "rakka:isFeed STREQ yes"
570 setOrder cond "@uri STRA"
571 result <- searchPages sto cond
572 return (map hpPageName $ srPages result)
575 mkFeedURIStr :: URI -> PageName -> String
576 mkFeedURIStr baseURI name
577 = uriToString id (mkFeedURI baseURI name) ""