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)) -< ()
120 javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< ()
122 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
123 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
124 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
125 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
129 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
130 += ( getXPathTreesInDoc "/page/@lang"
132 qattr (mkQName "xml" "lang" "")
133 ( getXPathTreesInDoc "/page/@lang/text()" )
139 += getXPathTreesInDoc "/page/@name/text()"
144 += sattr "rel" "stylesheet"
145 += sattr "type" "text/css"
146 += attr "href" (arr id >>> mkText)
151 += sattr "rel" "alternate"
152 += sattr "type" "application/rss+xml"
153 += attr "title" (txt siteName <+> txt " - " <+> mkText)
154 += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText)
156 += ( constL scriptSrc
159 += sattr "type" "text/javascript"
160 += attr "src" (arr id >>> mkText)
163 += sattr "type" "text/javascript"
164 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
165 += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
166 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
168 += ( constL javaScripts
171 += sattr "type" "text/javascript"
172 += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText)
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 (PageName, Maybe XmlTree, PageName) XmlTree
306 = proc (mainPageName, mainPage, subPageName) ->
307 do langM <- case mainPage of
309 -> returnA -< Nothing
311 -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p
312 subPage <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing)
313 localSubPage <- case langM of
315 -> returnA -< subPage
317 -> localize (envStorage env) -< (l, subPage)
318 subPageXml <- xmlizePage -< localSubPage
319 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
320 -< (Just mainPageName, mainPage, subPageXml)
323 localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page
325 = proc (lang, origPage)
326 -> do let otherLang = entityOtherLang origPage
327 localName = M.lookup lang otherLang
330 -> returnA -< origPage
332 -> do localPage <- getPageA sto -< (ln, Nothing)
333 returnA -< case localPage of
339 <pageListing path="Foo">
340 <page name="Foo/Bar" />
341 <page name="Foo/Baz" />
344 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
345 handleGetPageListing env
347 -> do tree <- ( eelem "/"
348 += ( eelem "pageListing"
349 += attr "path" (arr fst >>> mkText)
353 += attr "name" (arr id >>> mkText)
358 returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
361 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
362 pageListingToXHTML env
364 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
365 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
366 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
367 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
369 name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
371 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
372 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
374 feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
375 javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< ()
377 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
378 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
379 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
383 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
388 += getXPathTreesInDoc "/pageListing/@path/text()"
393 += sattr "rel" "stylesheet"
394 += sattr "type" "text/css"
395 += attr "href" (arr id >>> mkText)
400 += sattr "rel" "alternate"
401 += sattr "type" "application/rss+xml"
402 += attr "title" (txt siteName <+> txt " - " <+> mkText)
403 += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText)
405 += ( constL scriptSrc
408 += sattr "type" "text/javascript"
409 += attr "src" (arr id >>> mkText)
412 += sattr "type" "text/javascript"
413 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
414 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
416 += ( constL javaScripts
419 += sattr "type" "text/javascript"
420 += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText)
425 += sattr "class" "header"
428 += sattr "class" "center"
430 += sattr "class" "title"
434 += sattr "class" "body"
436 += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
440 += attr "href" ( getText
442 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
453 += sattr "class" "footer"
456 += sattr "class" "left sideBar"
458 += sattr "class" "content"
459 += constL leftSideBar
463 += sattr "class" "right sideBar"
465 += sattr "class" "content"
466 += constL rightSideBar
471 uniqueNamespacesFromDeclAndQNames
476 <pageNotFound name="Foo/Bar" />
478 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
479 handlePageNotFound env
481 -> do tree <- ( eelem "/"
482 += ( eelem "pageNotFound"
483 += attr "name" (arr id >>> mkText)
486 returnA -< do setStatus NotFound
487 outputXmlPage' tree (notFoundToXHTML env)
490 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
493 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
494 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
495 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
496 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
498 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
500 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
501 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
503 feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
504 javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< ()
506 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
507 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
508 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
512 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
517 += getXPathTreesInDoc "/pageNotFound/@name/text()"
522 += sattr "rel" "stylesheet"
523 += sattr "type" "text/css"
524 += attr "href" (arr id >>> mkText)
529 += sattr "rel" "alternate"
530 += sattr "type" "application/rss+xml"
531 += attr "title" (txt siteName <+> txt " - " <+> mkText)
532 += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText)
534 += ( constL scriptSrc
537 += sattr "type" "text/javascript"
538 += attr "src" (arr id >>> mkText)
541 += sattr "type" "text/javascript"
542 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
543 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
545 += ( constL javaScripts
548 += sattr "type" "text/javascript"
549 += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText)
554 += sattr "class" "header"
557 += sattr "class" "center"
559 += sattr "class" "title"
563 += sattr "class" "body"
564 += txt "404 Not Found (FIXME)" -- FIXME
568 += sattr "class" "footer"
571 += sattr "class" "left sideBar"
573 += sattr "class" "content"
574 += constL leftSideBar
578 += sattr "class" "right sideBar"
580 += sattr "class" "content"
581 += constL rightSideBar
586 uniqueNamespacesFromDeclAndQNames
590 handlePut :: Environment -> PageName -> Resource ()
592 = do userID <- getUserID env
593 runXmlA env "rakka-page-1.0.rng" $ proc tree
594 -> do page <- parseXmlizedPage -< (name, tree)
595 status <- putPageA (envStorage env) -< (userID, page)
596 returnA -< setStatus status
599 handleDelete :: Environment -> PageName -> Resource ()
600 handleDelete env name
601 = do userID <- getUserID env
602 status <- deletePage (envStorage env) userID name
606 findFeeds :: Storage -> IO [PageName]
608 = do cond <- newCondition
609 setPhrase cond "[UVSET]"
610 addAttrCond cond "rakka:isFeed STREQ yes"
611 setOrder cond "@uri STRA"
612 result <- searchPages sto cond
613 return (map hpPageName $ srPages result)
616 findJavaScripts :: Storage -> IO [PageName]
618 = do cond <- newCondition
619 setPhrase cond "[UVSET]"
620 addAttrCond cond "@title STRBW Global/"
621 addAttrCond cond "@type STRBW text/javascript"
622 setOrder cond "@uri STRA"
623 result <- searchPages sto cond
624 return (map hpPageName $ srPages result)
627 mkFeedURIStr :: URI -> PageName -> String
628 mkFeedURIStr baseURI name
629 = uriToString id (mkFeedURI baseURI name) ""
632 mkObjectURIStr :: URI -> PageName -> String
633 mkObjectURIStr baseURI name
634 = uriToString id (mkObjectURI baseURI name) ""