1 module Rakka.Resource.PageEntity
7 import Control.Arrow.ArrowIO
8 import Control.Arrow.ArrowIf
9 import Control.Arrow.ArrowList
10 import Control.Monad.Trans
14 import Network.HTTP.Lucu
15 import Network.HTTP.Lucu.Utils
16 import Network.URI hiding (path)
17 import Rakka.Environment
21 import Rakka.SystemConfig
23 import Rakka.W3CDateTime
24 import Rakka.Wiki.Engine
25 import System.FilePath
26 import Text.XML.HXT.Arrow.Namespace
27 import Text.XML.HXT.Arrow.WriteDocument
28 import Text.XML.HXT.Arrow.XmlArrow
29 import Text.XML.HXT.Arrow.XmlIOStateArrow
30 import Text.XML.HXT.Arrow.XmlNodeSet
31 import Text.XML.HXT.DOM.TypeDefs
32 import Text.XML.HXT.DOM.XmlKeywords
35 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
36 fallbackPageEntity env path
37 | null path = return Nothing
38 | null $ head path = return Nothing
39 | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
41 = return $ Just $ ResourceDef {
42 resUsesNativeThread = False
44 , resGet = Just $ handleGet env (toPageName path)
47 , resPut = Just $ handlePut env (toPageName path)
48 , resDelete = Just $ handleDelete env (toPageName path)
51 toPageName :: [String] -> PageName
52 toPageName = decodePageName . dropExtension . joinWith "/"
55 handleGet :: Environment -> PageName -> Resource ()
57 = runIdempotentA $ proc ()
58 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
61 -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
63 [] -> handlePageNotFound env -< name
64 _ -> handleGetPageListing env -< (name, items)
66 -> if isEntity page then
67 handleGetEntity env -< page
69 handleRedirect env -< page
74 Location: http://example.org/Destination.html#Redirect:Source
76 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
79 -> returnA -< do mType <- getEntityType
81 MIMEType "text" "xml" _
82 -> do setContentType mType
83 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
89 writeDocumentToString [ (a_indent, v_1) ]
93 _ -> do BaseURI baseURI <- getSysConf (envSysConf env)
94 let uri = mkPageFragmentURI
97 ("Redirect:" ++ redirName redir)
101 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
104 -> do tree <- xmlizePage -< page
105 returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
106 -- てゐる可能性があるので、ETag も
107 -- Last-Modified も返す事が出來ない。
108 case entityType page of
109 MIMEType "text" "x-rakka" _
111 _ -> case entityRevision page of
112 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
113 rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
115 outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
116 , (MIMEType "application" "rdf+xml" [], entityToRSS env)
120 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
123 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
124 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
125 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
126 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
128 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
129 isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
131 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
132 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
134 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
135 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
136 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
137 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
141 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
142 += ( getXPathTreesInDoc "/page/@lang"
144 qattr (QN "xml" "lang" "")
145 ( getXPathTreesInDoc "/page/@lang/text()" )
151 += getXPathTreesInDoc "/page/@name/text()"
156 += sattr "rel" "stylesheet"
157 += sattr "type" "text/css"
158 += attr "href" (arr id >>> mkText)
160 += ( constL scriptSrc
163 += sattr "type" "text/javascript"
164 += attr "src" (arr id >>> mkText)
167 += sattr "type" "text/javascript"
168 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
169 += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
170 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
175 += sattr "class" "header"
178 += sattr "class" "center"
180 += sattr "class" "title"
184 += sattr "class" "body"
189 += sattr "class" "footer"
192 += sattr "class" "left sideBar"
194 += sattr "class" "content"
195 += constL leftSideBar
199 += sattr "class" "right sideBar"
201 += sattr "class" "content"
202 += constL rightSideBar
207 uniqueNamespacesFromDeclAndQNames
211 entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
214 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
215 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
217 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
218 summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
219 pages <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
223 += sattr "xmlns" "http://purl.org/rss/1.0/"
224 += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
225 += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/"
226 += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
228 += sattr "rdf:about" (uriToString id (mkRDFURI baseURI name) "")
232 += getXPathTreesInDoc "/page/@name/text()"
235 += txt (uriToString id baseURI "")
237 += ( eelem "description"
238 += txt (case summary of
239 Nothing -> "RSS Feed for " ++ siteName
247 += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
254 arr (\ n -> (n, Nothing))
256 getPageA (envStorage env)
261 += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
263 += (arr entityName >>> mkText)
266 += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
268 += ( arrL (\ p -> case entitySummary p of
276 += ( arrIO (utcToLocalZonedTime . entityLastMod)
278 arr formatW3CDateTime
283 += ( eelem "trackback:ping"
284 += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
288 uniqueNamespacesFromDeclAndQNames
291 mkPageURIStr :: URI -> PageName -> String
292 mkPageURIStr baseURI name
293 = uriToString id (mkPageURI baseURI name) ""
295 mkTrackbackURIStr :: URI -> PageName -> String
296 mkTrackbackURIStr baseURI name
297 = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
300 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
302 -> a (PageName, Maybe XmlTree, PageName) XmlTree
304 = proc (mainPageName, mainPage, subPageName) ->
305 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
306 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
307 -< (mainPageName, mainPage, subPage)
312 <pageListing path="Foo">
313 <page name="Foo/Bar" />
314 <page name="Foo/Baz" />
317 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
318 handleGetPageListing env
320 -> do tree <- ( eelem "/"
321 += ( eelem "pageListing"
322 += attr "path" (arr fst >>> mkText)
326 += attr "name" (arr id >>> mkText)
331 returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
334 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
335 pageListingToXHTML env
337 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
338 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
339 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
340 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
342 name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
344 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
345 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
347 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
348 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
349 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
353 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
358 += getXPathTreesInDoc "/pageListing/@path/text()"
363 += sattr "rel" "stylesheet"
364 += sattr "type" "text/css"
365 += attr "href" (arr id >>> mkText)
367 += ( constL scriptSrc
370 += sattr "type" "text/javascript"
371 += attr "src" (arr id >>> mkText)
374 += sattr "type" "text/javascript"
375 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
376 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
381 += sattr "class" "header"
384 += sattr "class" "center"
386 += sattr "class" "title"
390 += sattr "class" "body"
392 += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
396 += attr "href" ( getText
398 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
409 += sattr "class" "footer"
412 += sattr "class" "left sideBar"
414 += sattr "class" "content"
415 += constL leftSideBar
419 += sattr "class" "right sideBar"
421 += sattr "class" "content"
422 += constL rightSideBar
427 uniqueNamespacesFromDeclAndQNames
432 <pageNotFound name="Foo/Bar" />
434 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
435 handlePageNotFound env
437 -> do tree <- ( eelem "/"
438 += ( eelem "pageNotFound"
439 += attr "name" (arr id >>> mkText)
442 returnA -< do setStatus NotFound
443 outputXmlPage' tree (notFoundToXHTML env)
446 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
449 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
450 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
451 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
452 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
454 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
456 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
457 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
459 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
460 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
461 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
465 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
470 += getXPathTreesInDoc "/pageNotFound/@name/text()"
475 += sattr "rel" "stylesheet"
476 += sattr "type" "text/css"
477 += attr "href" (arr id >>> mkText)
479 += ( constL scriptSrc
482 += sattr "type" "text/javascript"
483 += attr "src" (arr id >>> mkText)
486 += sattr "type" "text/javascript"
487 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
488 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
493 += sattr "class" "header"
496 += sattr "class" "center"
498 += sattr "class" "title"
502 += sattr "class" "body"
503 += txt "404 Not Found (FIXME)" -- FIXME
507 += sattr "class" "footer"
510 += sattr "class" "left sideBar"
512 += sattr "class" "content"
513 += constL leftSideBar
517 += sattr "class" "right sideBar"
519 += sattr "class" "content"
520 += constL rightSideBar
525 uniqueNamespacesFromDeclAndQNames
529 handlePut :: Environment -> PageName -> Resource ()
531 = do userID <- getUserID env
532 runXmlA env "rakka-page-1.0.rng" $ proc tree
533 -> do page <- parseXmlizedPage -< (name, tree)
534 status <- putPageA (envStorage env) -< (userID, page)
535 returnA -< setStatus status
538 handleDelete :: Environment -> PageName -> Resource ()
539 handleDelete env name
540 = do userID <- getUserID env
541 status <- deletePage (envStorage env) userID name