1 module Rakka.Resource.PageEntity
5 import Control.Monad.Trans
6 import qualified Data.ByteString.Lazy as L hiding (ByteString)
8 import qualified Data.Map as M
11 import qualified Data.Time.W3C as W3C
12 import Network.HTTP.Lucu
13 import Network.URI hiding (path)
14 import Rakka.Environment
18 import Rakka.SystemConfig
20 import Rakka.Wiki.Engine
21 import System.FilePath.Posix
22 import Text.HyperEstraier hiding (getText)
23 import Text.XML.HXT.XPath
26 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
27 fallbackPageEntity env path
28 | null name = return Nothing
29 | isLower $ head name = return Nothing -- 先頭の文字が小文字であってはならない
31 = return $ Just $ ResourceDef {
32 resUsesNativeThread = False
34 , resGet = Just $ handleGet env name
37 , resPut = Just $ handlePut env name
38 , resDelete = Just $ handleDelete env name
42 name = (dropExtension . UTF8.decodeString . joinPath) path
45 handleGet :: Environment -> PageName -> Resource ()
47 = do BaseURI baseURI <- getSysConf (envSysConf env)
48 runIdempotentA baseURI $ proc ()
49 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
52 -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
54 [] -> handlePageNotFound env -< name
55 _ -> handleGetPageListing env -< (name, items)
57 -> if isEntity page then
58 handleGetEntity env -< page
60 handleRedirect env -< page
65 Location: http://example.org/Destination.html#Redirect:Source
67 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
70 -> returnA -< do mType <- getEntityType
72 MIMEType "text" "xml" _
73 -> do setContentType mType
74 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
80 writeDocumentToString [ (a_indent , v_1 )
81 , (a_output_encoding, utf8)
82 , (a_no_xml_pi , v_0 ) ]
86 _ -> do BaseURI baseURI <- getSysConf (envSysConf env)
87 let uri = mkPageFragmentURI
90 ("Redirect:" ++ redirName redir)
94 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
97 -> do tree <- xmlizePage -< page
98 returnA -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
99 , (MIMEType "application" "rss+xml" [], entityToRSS env)
103 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
106 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
107 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
108 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
109 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
111 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
112 isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
114 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
115 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
117 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
118 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
119 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
120 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
124 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
125 += ( getXPathTreesInDoc "/page/@lang"
127 qattr (mkQName "xml" "lang" "")
128 ( getXPathTreesInDoc "/page/@lang/text()" )
134 += getXPathTreesInDoc "/page/@name/text()"
139 += sattr "rel" "stylesheet"
140 += sattr "type" "text/css"
141 += attr "href" (arr id >>> mkText)
144 += ( constL scriptSrc
147 += sattr "type" "text/javascript"
148 += attr "src" (arr id >>> mkText)
151 += sattr "type" "text/javascript"
152 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
153 += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
154 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
156 += mkGlobalJSList env
160 += sattr "class" "header"
163 += sattr "class" "center"
165 += sattr "class" "title"
169 += sattr "class" "body"
174 += sattr "class" "footer"
177 += sattr "class" "left sideBar"
179 += sattr "class" "content"
180 += constL leftSideBar
184 += sattr "class" "right sideBar"
186 += sattr "class" "content"
187 += constL rightSideBar
192 uniqueNamespacesFromDeclAndQNames
196 entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
199 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
200 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
202 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
203 summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
204 pages <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
208 += sattr "xmlns" "http://purl.org/rss/1.0/"
209 += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
210 += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/"
211 += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
213 += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
217 += getXPathTreesInDoc "/page/@name/text()"
220 += txt (uriToString id baseURI "")
222 += ( eelem "description"
223 += txt (case summary of
224 Nothing -> "RSS Feed for " ++ siteName
232 += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
239 arr (\ n -> (n, Nothing))
241 getPageA (envStorage env)
246 += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
248 += (arr entityName >>> mkText)
251 += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
253 += ( arrL (\ p -> case entitySummary p of
261 += ( arrIO (utcToLocalZonedTime . entityLastMod)
268 += ( eelem "trackback:ping"
269 += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
273 uniqueNamespacesFromDeclAndQNames
276 mkPageURIStr :: URI -> PageName -> String
277 mkPageURIStr baseURI name
278 = uriToString id (mkPageURI baseURI name) ""
280 mkTrackbackURIStr :: URI -> PageName -> String
281 mkTrackbackURIStr baseURI name
282 = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
285 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
287 -> a (PageName, Maybe XmlTree, PageName) XmlTree
289 = proc (mainPageName, mainPage, subPageName) ->
290 do langM <- case mainPage of
292 -> returnA -< Nothing
294 -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p
295 subPage <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing)
296 localSubPage <- case langM of
298 -> returnA -< subPage
300 -> localize (envStorage env) -< (l, subPage)
301 subPageXml <- xmlizePage -< localSubPage
302 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
303 -< (Just mainPageName, mainPage, subPageXml)
306 localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page
308 = proc (lang, origPage)
309 -> do let otherLang = entityOtherLang origPage
310 localName = M.lookup lang otherLang
313 -> returnA -< origPage
315 -> do localPage <- getPageA sto -< (ln, Nothing)
316 returnA -< case localPage of
322 <pageListing path="Foo">
323 <page name="Foo/Bar" />
324 <page name="Foo/Baz" />
327 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
328 handleGetPageListing env
330 -> do tree <- ( eelem "/"
331 += ( eelem "pageListing"
332 += attr "path" (arr fst >>> mkText)
336 += attr "name" (arr id >>> mkText)
341 returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
344 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
345 pageListingToXHTML env
347 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
348 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
349 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
350 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
352 name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
354 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
355 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
357 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
358 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
359 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
363 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
368 += getXPathTreesInDoc "/pageListing/@path/text()"
373 += sattr "rel" "stylesheet"
374 += sattr "type" "text/css"
375 += 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 ++ ";")
389 += mkGlobalJSList env
393 += sattr "class" "header"
396 += sattr "class" "center"
398 += sattr "class" "title"
402 += sattr "class" "body"
404 += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
408 += attr "href" ( getText
410 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
421 += sattr "class" "footer"
424 += sattr "class" "left sideBar"
426 += sattr "class" "content"
427 += constL leftSideBar
431 += sattr "class" "right sideBar"
433 += sattr "class" "content"
434 += constL rightSideBar
439 uniqueNamespacesFromDeclAndQNames
444 <pageNotFound name="Foo/Bar" />
446 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
447 handlePageNotFound env
449 -> do tree <- ( eelem "/"
450 += ( eelem "pageNotFound"
451 += attr "name" (arr id >>> mkText)
454 returnA -< do setStatus NotFound
455 outputXmlPage' tree (notFoundToXHTML env)
458 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
461 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
462 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
463 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
464 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
466 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
468 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
469 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
471 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
472 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
473 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
477 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
482 += getXPathTreesInDoc "/pageNotFound/@name/text()"
487 += sattr "rel" "stylesheet"
488 += sattr "type" "text/css"
489 += attr "href" (arr id >>> mkText)
492 += ( constL scriptSrc
495 += sattr "type" "text/javascript"
496 += attr "src" (arr id >>> mkText)
499 += sattr "type" "text/javascript"
500 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
501 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
503 += mkGlobalJSList env
507 += sattr "class" "header"
510 += sattr "class" "center"
512 += sattr "class" "title"
516 += sattr "class" "body"
517 += txt "404 Not Found (FIXME)" -- FIXME
521 += sattr "class" "footer"
524 += sattr "class" "left sideBar"
526 += sattr "class" "content"
527 += constL leftSideBar
531 += sattr "class" "right sideBar"
533 += sattr "class" "content"
534 += constL rightSideBar
539 uniqueNamespacesFromDeclAndQNames
543 handlePut :: Environment -> PageName -> Resource ()
545 = do userID <- getUserID env
546 runXmlA env "rakka-page-1.0.rng" $ proc tree
547 -> do page <- parseXmlizedPage -< (name, tree)
548 status <- putPageA (envStorage env) -< (userID, page)
549 returnA -< setStatus status
552 handleDelete :: Environment -> PageName -> Resource ()
553 handleDelete env name
554 = do userID <- getUserID env
555 status <- deletePage (envStorage env) userID name
559 mkFeedList :: (ArrowIO a, ArrowXml a) => Environment -> a b XmlTree
561 = proc _ -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
562 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
564 feed <- unlistA <<< arrIO0 (findFeeds $ envStorage env) -< ()
567 += sattr "rel" "alternate"
568 += sattr "type" "application/rss+xml"
569 += attr "title" (txt siteName <+> txt " - " <+> mkText)
570 += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText) ) -<< feed
573 findFeeds :: Storage -> IO [PageName]
575 = do cond <- newCondition
576 setPhrase cond "[UVSET]"
577 addAttrCond cond "rakka:isFeed STREQ yes"
578 setOrder cond "@uri STRA"
579 result <- searchPages sto cond
580 return (map hpPageName $ srPages result)
583 mkGlobalJSList :: (ArrowIO a, ArrowXml a, ArrowChoice a) => Environment -> a b XmlTree
585 = proc _ -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
587 scriptName <- unlistA <<< arrIO0 (findJavaScripts $ envStorage env) -< ()
588 pageM <- getPageA (envStorage env) -< (scriptName, Nothing)
591 Nothing -> none -< ()
594 -> ( if entityIsBinary page then
596 += sattr "type" "text/javascript"
597 += attr "src" (arr (mkObjectURIStr baseURI . pageName) >>> mkText) )
600 += sattr "type" "text/javascript"
601 += (arr (UTF8.decode . L.unpack . entityContent) >>> mkText) )
607 findJavaScripts :: Storage -> IO [PageName]
609 = do cond <- newCondition
610 setPhrase cond "[UVSET]"
611 addAttrCond cond "@title STRBW Global/"
612 addAttrCond cond "@type STRBW text/javascript"
613 setOrder cond "@uri STRA"
614 result <- searchPages sto cond
615 return (map hpPageName $ srPages result)
618 mkFeedURIStr :: URI -> PageName -> String
619 mkFeedURIStr baseURI name
620 = uriToString id (mkFeedURI baseURI name) ""
623 mkObjectURIStr :: URI -> PageName -> String
624 mkObjectURIStr baseURI name
625 = uriToString id (mkObjectURI baseURI name) ""