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.HyperEstraier hiding (getText)
27 import Text.XML.HXT.Arrow.Namespace
28 import Text.XML.HXT.Arrow.WriteDocument
29 import Text.XML.HXT.Arrow.XmlArrow
30 import Text.XML.HXT.Arrow.XmlIOStateArrow
31 import Text.XML.HXT.Arrow.XmlNodeSet
32 import Text.XML.HXT.DOM.TypeDefs
33 import Text.XML.HXT.DOM.XmlKeywords
36 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
37 fallbackPageEntity env path
38 | null path = return Nothing
39 | null $ head path = return Nothing
40 | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
42 = return $ Just $ ResourceDef {
43 resUsesNativeThread = False
45 , resGet = Just $ handleGet env (toPageName path)
48 , resPut = Just $ handlePut env (toPageName path)
49 , resDelete = Just $ handleDelete env (toPageName path)
52 toPageName :: [String] -> PageName
53 toPageName = decodePageName . dropExtension . joinWith "/"
56 handleGet :: Environment -> PageName -> Resource ()
58 = runIdempotentA $ proc ()
59 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
62 -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
64 [] -> handlePageNotFound env -< name
65 _ -> handleGetPageListing env -< (name, items)
67 -> if isEntity page then
68 handleGetEntity env -< page
70 handleRedirect env -< page
75 Location: http://example.org/Destination.html#Redirect:Source
77 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
80 -> returnA -< do mType <- getEntityType
82 MIMEType "text" "xml" _
83 -> do setContentType mType
84 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
90 writeDocumentToString [ (a_indent, v_1) ]
94 _ -> do BaseURI baseURI <- getSysConf (envSysConf env)
95 let uri = mkPageFragmentURI
98 ("Redirect:" ++ redirName redir)
102 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
105 -> do tree <- xmlizePage -< page
106 returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
107 -- てゐる可能性があるので、ETag も
108 -- Last-Modified も返す事が出來ない。
109 case entityType page of
110 MIMEType "text" "x-rakka" _
112 _ -> case entityRevision page of
113 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
114 rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
116 outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
117 , (MIMEType "application" "rss+xml" [], entityToRSS env)
121 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
124 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
125 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
126 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
127 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
129 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
130 isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
132 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
133 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
135 feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
137 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
138 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
139 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
140 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
144 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
145 += ( getXPathTreesInDoc "/page/@lang"
147 qattr (QN "xml" "lang" "")
148 ( getXPathTreesInDoc "/page/@lang/text()" )
154 += getXPathTreesInDoc "/page/@name/text()"
159 += sattr "rel" "stylesheet"
160 += sattr "type" "text/css"
161 += attr "href" (arr id >>> mkText)
166 += sattr "rel" "alternate"
167 += sattr "type" "application/rss+xml"
168 += attr "title" (txt siteName <+> txt " - " <+> mkText)
169 += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText)
171 += ( constL scriptSrc
174 += sattr "type" "text/javascript"
175 += attr "src" (arr id >>> mkText)
178 += sattr "type" "text/javascript"
179 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
180 += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
181 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
186 += sattr "class" "header"
189 += sattr "class" "center"
191 += sattr "class" "title"
195 += sattr "class" "body"
200 += sattr "class" "footer"
203 += sattr "class" "left sideBar"
205 += sattr "class" "content"
206 += constL leftSideBar
210 += sattr "class" "right sideBar"
212 += sattr "class" "content"
213 += constL rightSideBar
218 uniqueNamespacesFromDeclAndQNames
222 entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
225 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
226 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
228 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
229 summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
230 pages <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
234 += sattr "xmlns" "http://purl.org/rss/1.0/"
235 += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
236 += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/"
237 += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
239 += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
243 += getXPathTreesInDoc "/page/@name/text()"
246 += txt (uriToString id baseURI "")
248 += ( eelem "description"
249 += txt (case summary of
250 Nothing -> "RSS Feed for " ++ siteName
258 += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
265 arr (\ n -> (n, Nothing))
267 getPageA (envStorage env)
272 += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
274 += (arr entityName >>> mkText)
277 += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
279 += ( arrL (\ p -> case entitySummary p of
287 += ( arrIO (utcToLocalZonedTime . entityLastMod)
289 arr formatW3CDateTime
294 += ( eelem "trackback:ping"
295 += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
299 uniqueNamespacesFromDeclAndQNames
302 mkPageURIStr :: URI -> PageName -> String
303 mkPageURIStr baseURI name
304 = uriToString id (mkPageURI baseURI name) ""
306 mkTrackbackURIStr :: URI -> PageName -> String
307 mkTrackbackURIStr baseURI name
308 = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
311 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
313 -> a (PageName, Maybe XmlTree, PageName) XmlTree
315 = proc (mainPageName, mainPage, subPageName) ->
316 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
317 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
318 -< (mainPageName, mainPage, subPage)
323 <pageListing path="Foo">
324 <page name="Foo/Bar" />
325 <page name="Foo/Baz" />
328 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
329 handleGetPageListing env
331 -> do tree <- ( eelem "/"
332 += ( eelem "pageListing"
333 += attr "path" (arr fst >>> mkText)
337 += attr "name" (arr id >>> mkText)
342 returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
345 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
346 pageListingToXHTML env
348 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
349 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
350 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
351 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
353 name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
355 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
356 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
358 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
359 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
360 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
364 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
369 += getXPathTreesInDoc "/pageListing/@path/text()"
374 += sattr "rel" "stylesheet"
375 += sattr "type" "text/css"
376 += attr "href" (arr id >>> mkText)
378 += ( constL scriptSrc
381 += sattr "type" "text/javascript"
382 += attr "src" (arr id >>> mkText)
385 += sattr "type" "text/javascript"
386 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
387 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
392 += sattr "class" "header"
395 += sattr "class" "center"
397 += sattr "class" "title"
401 += sattr "class" "body"
403 += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
407 += attr "href" ( getText
409 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
420 += sattr "class" "footer"
423 += sattr "class" "left sideBar"
425 += sattr "class" "content"
426 += constL leftSideBar
430 += sattr "class" "right sideBar"
432 += sattr "class" "content"
433 += constL rightSideBar
438 uniqueNamespacesFromDeclAndQNames
443 <pageNotFound name="Foo/Bar" />
445 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
446 handlePageNotFound env
448 -> do tree <- ( eelem "/"
449 += ( eelem "pageNotFound"
450 += attr "name" (arr id >>> mkText)
453 returnA -< do setStatus NotFound
454 outputXmlPage' tree (notFoundToXHTML env)
457 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
460 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
461 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
462 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
463 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
465 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
467 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
468 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
470 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
471 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
472 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
476 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
481 += getXPathTreesInDoc "/pageNotFound/@name/text()"
486 += sattr "rel" "stylesheet"
487 += sattr "type" "text/css"
488 += attr "href" (arr id >>> mkText)
490 += ( constL scriptSrc
493 += sattr "type" "text/javascript"
494 += attr "src" (arr id >>> mkText)
497 += sattr "type" "text/javascript"
498 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
499 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
504 += sattr "class" "header"
507 += sattr "class" "center"
509 += sattr "class" "title"
513 += sattr "class" "body"
514 += txt "404 Not Found (FIXME)" -- FIXME
518 += sattr "class" "footer"
521 += sattr "class" "left sideBar"
523 += sattr "class" "content"
524 += constL leftSideBar
528 += sattr "class" "right sideBar"
530 += sattr "class" "content"
531 += constL rightSideBar
536 uniqueNamespacesFromDeclAndQNames
540 handlePut :: Environment -> PageName -> Resource ()
542 = do userID <- getUserID env
543 runXmlA env "rakka-page-1.0.rng" $ proc tree
544 -> do page <- parseXmlizedPage -< (name, tree)
545 status <- putPageA (envStorage env) -< (userID, page)
546 returnA -< setStatus status
549 handleDelete :: Environment -> PageName -> Resource ()
550 handleDelete env name
551 = do userID <- getUserID env
552 status <- deletePage (envStorage env) userID name
556 findFeeds :: Storage -> IO [PageName]
558 = do cond <- newCondition
559 setPhrase cond "[UVSET]"
560 addAttrCond cond "rakka:isFeed STREQ yes"
561 setOrder cond "@uri STRA"
562 result <- searchPages sto cond
563 return (map fst result)
566 mkFeedURIStr :: URI -> PageName -> String
567 mkFeedURIStr baseURI name
568 = uriToString id (mkFeedURI baseURI name) ""