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 = do BaseURI baseURI <- getSysConf (envSysConf env)
59 runIdempotentA baseURI $ proc ()
60 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
63 -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
65 [] -> handlePageNotFound env -< name
66 _ -> handleGetPageListing env -< (name, items)
68 -> if isEntity page then
69 handleGetEntity env -< page
71 handleRedirect env -< page
76 Location: http://example.org/Destination.html#Redirect:Source
78 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
81 -> returnA -< do mType <- getEntityType
83 MIMEType "text" "xml" _
84 -> do setContentType mType
85 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
91 writeDocumentToString [ (a_indent, v_1) ]
95 _ -> do BaseURI baseURI <- getSysConf (envSysConf env)
96 let uri = mkPageFragmentURI
99 ("Redirect:" ++ redirName redir)
103 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
106 -> do tree <- xmlizePage -< page
107 returnA -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
108 , (MIMEType "application" "rss+xml" [], entityToRSS env)
112 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
115 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
116 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
117 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
118 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
120 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
121 isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
123 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
124 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
126 feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
128 pageTitle <- listA (readSubPage env) -< (Just name, Just page, "PageTitle")
129 leftSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Left")
130 rightSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Right")
131 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
135 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
136 += ( getXPathTreesInDoc "/page/@lang"
138 qattr (mkQName "xml" "lang" "")
139 ( getXPathTreesInDoc "/page/@lang/text()" )
145 += getXPathTreesInDoc "/page/@name/text()"
150 += sattr "rel" "stylesheet"
151 += sattr "type" "text/css"
152 += attr "href" (arr id >>> mkText)
157 += sattr "rel" "alternate"
158 += sattr "type" "application/rss+xml"
159 += attr "title" (txt siteName <+> txt " - " <+> mkText)
160 += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText)
162 += ( constL scriptSrc
165 += sattr "type" "text/javascript"
166 += attr "src" (arr id >>> mkText)
169 += sattr "type" "text/javascript"
170 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
171 += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
172 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
177 += sattr "class" "header"
180 += sattr "class" "center"
182 += sattr "class" "title"
186 += sattr "class" "body"
191 += sattr "class" "footer"
194 += sattr "class" "left sideBar"
196 += sattr "class" "content"
197 += constL leftSideBar
201 += sattr "class" "right sideBar"
203 += sattr "class" "content"
204 += constL rightSideBar
209 uniqueNamespacesFromDeclAndQNames
213 entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
216 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
217 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
219 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
220 summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
221 pages <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
225 += sattr "xmlns" "http://purl.org/rss/1.0/"
226 += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
227 += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/"
228 += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
230 += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
234 += getXPathTreesInDoc "/page/@name/text()"
237 += txt (uriToString id baseURI "")
239 += ( eelem "description"
240 += txt (case summary of
241 Nothing -> "RSS Feed for " ++ siteName
249 += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
256 arr (\ n -> (n, Nothing))
258 getPageA (envStorage env)
263 += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
265 += (arr entityName >>> mkText)
268 += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
270 += ( arrL (\ p -> case entitySummary p of
278 += ( arrIO (utcToLocalZonedTime . entityLastMod)
280 arr formatW3CDateTime
285 += ( eelem "trackback:ping"
286 += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
290 uniqueNamespacesFromDeclAndQNames
293 mkPageURIStr :: URI -> PageName -> String
294 mkPageURIStr baseURI name
295 = uriToString id (mkPageURI baseURI name) ""
297 mkTrackbackURIStr :: URI -> PageName -> String
298 mkTrackbackURIStr baseURI name
299 = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
302 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
304 -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
306 = proc (mainPageName, mainPage, subPageName) ->
307 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
308 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
309 -< (mainPageName, mainPage, subPage)
314 <pageListing path="Foo">
315 <page name="Foo/Bar" />
316 <page name="Foo/Baz" />
319 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
320 handleGetPageListing env
322 -> do tree <- ( eelem "/"
323 += ( eelem "pageListing"
324 += attr "path" (arr fst >>> mkText)
328 += attr "name" (arr id >>> mkText)
333 returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
336 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
337 pageListingToXHTML env
339 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
340 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
341 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
342 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
344 name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
346 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
347 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
349 pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
350 leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
351 rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
355 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
360 += getXPathTreesInDoc "/pageListing/@path/text()"
365 += sattr "rel" "stylesheet"
366 += sattr "type" "text/css"
367 += attr "href" (arr id >>> mkText)
369 += ( constL scriptSrc
372 += sattr "type" "text/javascript"
373 += attr "src" (arr id >>> mkText)
376 += sattr "type" "text/javascript"
377 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
378 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
383 += sattr "class" "header"
386 += sattr "class" "center"
388 += sattr "class" "title"
392 += sattr "class" "body"
394 += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
398 += attr "href" ( getText
400 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
411 += sattr "class" "footer"
414 += sattr "class" "left sideBar"
416 += sattr "class" "content"
417 += constL leftSideBar
421 += sattr "class" "right sideBar"
423 += sattr "class" "content"
424 += constL rightSideBar
429 uniqueNamespacesFromDeclAndQNames
434 <pageNotFound name="Foo/Bar" />
436 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
437 handlePageNotFound env
439 -> do tree <- ( eelem "/"
440 += ( eelem "pageNotFound"
441 += attr "name" (arr id >>> mkText)
444 returnA -< do setStatus NotFound
445 outputXmlPage' tree (notFoundToXHTML env)
448 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
451 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
452 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
453 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
454 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
456 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
458 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
459 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
461 pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
462 leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
463 rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
467 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
472 += getXPathTreesInDoc "/pageNotFound/@name/text()"
477 += sattr "rel" "stylesheet"
478 += sattr "type" "text/css"
479 += attr "href" (arr id >>> mkText)
481 += ( constL scriptSrc
484 += sattr "type" "text/javascript"
485 += attr "src" (arr id >>> mkText)
488 += sattr "type" "text/javascript"
489 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
490 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
495 += sattr "class" "header"
498 += sattr "class" "center"
500 += sattr "class" "title"
504 += sattr "class" "body"
505 += txt "404 Not Found (FIXME)" -- FIXME
509 += sattr "class" "footer"
512 += sattr "class" "left sideBar"
514 += sattr "class" "content"
515 += constL leftSideBar
519 += sattr "class" "right sideBar"
521 += sattr "class" "content"
522 += constL rightSideBar
527 uniqueNamespacesFromDeclAndQNames
531 handlePut :: Environment -> PageName -> Resource ()
533 = do userID <- getUserID env
534 runXmlA env "rakka-page-1.0.rng" $ proc tree
535 -> do page <- parseXmlizedPage -< (name, tree)
536 status <- putPageA (envStorage env) -< (userID, page)
537 returnA -< setStatus status
540 handleDelete :: Environment -> PageName -> Resource ()
541 handleDelete env name
542 = do userID <- getUserID env
543 status <- deletePage (envStorage env) userID name
547 findFeeds :: Storage -> IO [PageName]
549 = do cond <- newCondition
550 setPhrase cond "[UVSET]"
551 addAttrCond cond "rakka:isFeed STREQ yes"
552 setOrder cond "@uri STRA"
553 result <- searchPages sto cond
554 return (map hpPageName $ srPages result)
557 mkFeedURIStr :: URI -> PageName -> String
558 mkFeedURIStr baseURI name
559 = uriToString id (mkFeedURI baseURI name) ""