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 -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
107 , (MIMEType "application" "rss+xml" [], entityToRSS env)
111 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
114 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
115 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
116 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
117 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
119 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
120 isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
122 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
123 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
125 feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
127 pageTitle <- listA (readSubPage env) -< (Just name, Just page, "PageTitle")
128 leftSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Left")
129 rightSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Right")
130 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
134 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
135 += ( getXPathTreesInDoc "/page/@lang"
137 qattr (QN "xml" "lang" "")
138 ( getXPathTreesInDoc "/page/@lang/text()" )
144 += getXPathTreesInDoc "/page/@name/text()"
149 += sattr "rel" "stylesheet"
150 += sattr "type" "text/css"
151 += attr "href" (arr id >>> mkText)
156 += sattr "rel" "alternate"
157 += sattr "type" "application/rss+xml"
158 += attr "title" (txt siteName <+> txt " - " <+> mkText)
159 += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText)
161 += ( constL scriptSrc
164 += sattr "type" "text/javascript"
165 += attr "src" (arr id >>> mkText)
168 += sattr "type" "text/javascript"
169 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
170 += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
171 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
176 += sattr "class" "header"
179 += sattr "class" "center"
181 += sattr "class" "title"
185 += sattr "class" "body"
190 += sattr "class" "footer"
193 += sattr "class" "left sideBar"
195 += sattr "class" "content"
196 += constL leftSideBar
200 += sattr "class" "right sideBar"
202 += sattr "class" "content"
203 += constL rightSideBar
208 uniqueNamespacesFromDeclAndQNames
212 entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
215 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
216 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
218 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
219 summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
220 pages <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
224 += sattr "xmlns" "http://purl.org/rss/1.0/"
225 += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
226 += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/"
227 += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
229 += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
233 += getXPathTreesInDoc "/page/@name/text()"
236 += txt (uriToString id baseURI "")
238 += ( eelem "description"
239 += txt (case summary of
240 Nothing -> "RSS Feed for " ++ siteName
248 += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
255 arr (\ n -> (n, Nothing))
257 getPageA (envStorage env)
262 += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
264 += (arr entityName >>> mkText)
267 += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
269 += ( arrL (\ p -> case entitySummary p of
277 += ( arrIO (utcToLocalZonedTime . entityLastMod)
279 arr formatW3CDateTime
284 += ( eelem "trackback:ping"
285 += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
289 uniqueNamespacesFromDeclAndQNames
292 mkPageURIStr :: URI -> PageName -> String
293 mkPageURIStr baseURI name
294 = uriToString id (mkPageURI baseURI name) ""
296 mkTrackbackURIStr :: URI -> PageName -> String
297 mkTrackbackURIStr baseURI name
298 = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
301 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
303 -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
305 = proc (mainPageName, mainPage, subPageName) ->
306 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
307 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
308 -< (mainPageName, mainPage, subPage)
313 <pageListing path="Foo">
314 <page name="Foo/Bar" />
315 <page name="Foo/Baz" />
318 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
319 handleGetPageListing env
321 -> do tree <- ( eelem "/"
322 += ( eelem "pageListing"
323 += attr "path" (arr fst >>> mkText)
327 += attr "name" (arr id >>> mkText)
332 returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
335 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
336 pageListingToXHTML env
338 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
339 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
340 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
341 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
343 name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
345 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
346 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
348 pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
349 leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
350 rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
354 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
359 += getXPathTreesInDoc "/pageListing/@path/text()"
364 += sattr "rel" "stylesheet"
365 += sattr "type" "text/css"
366 += attr "href" (arr id >>> mkText)
368 += ( constL scriptSrc
371 += sattr "type" "text/javascript"
372 += attr "src" (arr id >>> mkText)
375 += sattr "type" "text/javascript"
376 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
377 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
382 += sattr "class" "header"
385 += sattr "class" "center"
387 += sattr "class" "title"
391 += sattr "class" "body"
393 += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
397 += attr "href" ( getText
399 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
410 += sattr "class" "footer"
413 += sattr "class" "left sideBar"
415 += sattr "class" "content"
416 += constL leftSideBar
420 += sattr "class" "right sideBar"
422 += sattr "class" "content"
423 += constL rightSideBar
428 uniqueNamespacesFromDeclAndQNames
433 <pageNotFound name="Foo/Bar" />
435 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
436 handlePageNotFound env
438 -> do tree <- ( eelem "/"
439 += ( eelem "pageNotFound"
440 += attr "name" (arr id >>> mkText)
443 returnA -< do setStatus NotFound
444 outputXmlPage' tree (notFoundToXHTML env)
447 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
450 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
451 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
452 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
453 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
455 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
457 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
458 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
460 pageTitle <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
461 leftSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
462 rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
466 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
471 += getXPathTreesInDoc "/pageNotFound/@name/text()"
476 += sattr "rel" "stylesheet"
477 += sattr "type" "text/css"
478 += attr "href" (arr id >>> mkText)
480 += ( constL scriptSrc
483 += sattr "type" "text/javascript"
484 += attr "src" (arr id >>> mkText)
487 += sattr "type" "text/javascript"
488 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
489 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
494 += sattr "class" "header"
497 += sattr "class" "center"
499 += sattr "class" "title"
503 += sattr "class" "body"
504 += txt "404 Not Found (FIXME)" -- FIXME
508 += sattr "class" "footer"
511 += sattr "class" "left sideBar"
513 += sattr "class" "content"
514 += constL leftSideBar
518 += sattr "class" "right sideBar"
520 += sattr "class" "content"
521 += constL rightSideBar
526 uniqueNamespacesFromDeclAndQNames
530 handlePut :: Environment -> PageName -> Resource ()
532 = do userID <- getUserID env
533 runXmlA env "rakka-page-1.0.rng" $ proc tree
534 -> do page <- parseXmlizedPage -< (name, tree)
535 status <- putPageA (envStorage env) -< (userID, page)
536 returnA -< setStatus status
539 handleDelete :: Environment -> PageName -> Resource ()
540 handleDelete env name
541 = do userID <- getUserID env
542 status <- deletePage (envStorage env) userID name
546 findFeeds :: Storage -> IO [PageName]
548 = do cond <- newCondition
549 setPhrase cond "[UVSET]"
550 addAttrCond cond "rakka:isFeed STREQ yes"
551 setOrder cond "@uri STRA"
552 result <- searchPages sto cond
553 return (map hpPageName $ srPages result)
556 mkFeedURIStr :: URI -> PageName -> String
557 mkFeedURIStr baseURI name
558 = uriToString id (mkFeedURI baseURI name) ""