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
12 import qualified Data.Map as M
15 import Network.HTTP.Lucu
16 import Network.HTTP.Lucu.Utils
17 import Network.URI hiding (path)
18 import Rakka.Environment
22 import Rakka.SystemConfig
24 import Rakka.W3CDateTime
25 import Rakka.Wiki.Engine
26 import System.FilePath
27 import Text.HyperEstraier hiding (getText)
28 import Text.XML.HXT.Arrow.Namespace
29 import Text.XML.HXT.Arrow.WriteDocument
30 import Text.XML.HXT.Arrow.XmlArrow
31 import Text.XML.HXT.Arrow.XmlIOStateArrow
32 import Text.XML.HXT.Arrow.XmlNodeSet
33 import Text.XML.HXT.DOM.TypeDefs
34 import Text.XML.HXT.DOM.XmlKeywords
37 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
38 fallbackPageEntity env path
39 | null path = return Nothing
40 | null $ head path = return Nothing
41 | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
43 = return $ Just $ ResourceDef {
44 resUsesNativeThread = False
46 , resGet = Just $ handleGet env (toPageName path)
49 , resPut = Just $ handlePut env (toPageName path)
50 , resDelete = Just $ handleDelete env (toPageName path)
53 toPageName :: [String] -> PageName
54 toPageName = decodePageName . dropExtension . joinWith "/"
57 handleGet :: Environment -> PageName -> Resource ()
59 = do BaseURI baseURI <- getSysConf (envSysConf env)
60 runIdempotentA baseURI $ proc ()
61 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
64 -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
66 [] -> handlePageNotFound env -< name
67 _ -> handleGetPageListing env -< (name, items)
69 -> if isEntity page then
70 handleGetEntity env -< page
72 handleRedirect env -< page
77 Location: http://example.org/Destination.html#Redirect:Source
79 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
82 -> returnA -< do mType <- getEntityType
84 MIMEType "text" "xml" _
85 -> do setContentType mType
86 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
92 writeDocumentToString [ (a_indent, v_1) ]
96 _ -> do BaseURI baseURI <- getSysConf (envSysConf env)
97 let uri = mkPageFragmentURI
100 ("Redirect:" ++ redirName redir)
104 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
107 -> do tree <- xmlizePage -< page
108 returnA -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
109 , (MIMEType "application" "rss+xml" [], entityToRSS env)
113 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
116 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
117 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
118 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
119 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
121 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
122 isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
124 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
125 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
127 feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
129 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
130 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
131 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
132 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
136 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
137 += ( getXPathTreesInDoc "/page/@lang"
139 qattr (mkQName "xml" "lang" "")
140 ( getXPathTreesInDoc "/page/@lang/text()" )
146 += getXPathTreesInDoc "/page/@name/text()"
151 += sattr "rel" "stylesheet"
152 += sattr "type" "text/css"
153 += attr "href" (arr id >>> mkText)
158 += sattr "rel" "alternate"
159 += sattr "type" "application/rss+xml"
160 += attr "title" (txt siteName <+> txt " - " <+> mkText)
161 += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText)
163 += ( constL scriptSrc
166 += sattr "type" "text/javascript"
167 += attr "src" (arr id >>> mkText)
170 += sattr "type" "text/javascript"
171 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
172 += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
173 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
178 += sattr "class" "header"
181 += sattr "class" "center"
183 += sattr "class" "title"
187 += sattr "class" "body"
192 += sattr "class" "footer"
195 += sattr "class" "left sideBar"
197 += sattr "class" "content"
198 += constL leftSideBar
202 += sattr "class" "right sideBar"
204 += sattr "class" "content"
205 += constL rightSideBar
210 uniqueNamespacesFromDeclAndQNames
214 entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
217 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
218 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
220 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
221 summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
222 pages <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
226 += sattr "xmlns" "http://purl.org/rss/1.0/"
227 += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
228 += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/"
229 += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
231 += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
235 += getXPathTreesInDoc "/page/@name/text()"
238 += txt (uriToString id baseURI "")
240 += ( eelem "description"
241 += txt (case summary of
242 Nothing -> "RSS Feed for " ++ siteName
250 += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
257 arr (\ n -> (n, Nothing))
259 getPageA (envStorage env)
264 += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
266 += (arr entityName >>> mkText)
269 += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
271 += ( arrL (\ p -> case entitySummary p of
279 += ( arrIO (utcToLocalZonedTime . entityLastMod)
281 arr formatW3CDateTime
286 += ( eelem "trackback:ping"
287 += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
291 uniqueNamespacesFromDeclAndQNames
294 mkPageURIStr :: URI -> PageName -> String
295 mkPageURIStr baseURI name
296 = uriToString id (mkPageURI baseURI name) ""
298 mkTrackbackURIStr :: URI -> PageName -> String
299 mkTrackbackURIStr baseURI name
300 = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
303 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
305 -> a (PageName, Maybe XmlTree, PageName) XmlTree
307 = proc (mainPageName, mainPage, subPageName) ->
308 do langM <- case mainPage of
310 -> returnA -< Nothing
312 -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p
313 subPage <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing)
314 localSubPage <- case langM of
316 -> returnA -< subPage
318 -> localize (envStorage env) -< (l, subPage)
319 subPageXml <- xmlizePage -< localSubPage
320 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
321 -< (Just mainPageName, mainPage, subPageXml)
324 localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page
326 = proc (lang, origPage)
327 -> do let otherLang = entityOtherLang origPage
328 localName = M.lookup lang otherLang
331 -> returnA -< origPage
333 -> do localPage <- getPageA sto -< (ln, Nothing)
334 returnA -< case localPage of
340 <pageListing path="Foo">
341 <page name="Foo/Bar" />
342 <page name="Foo/Baz" />
345 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
346 handleGetPageListing env
348 -> do tree <- ( eelem "/"
349 += ( eelem "pageListing"
350 += attr "path" (arr fst >>> mkText)
354 += attr "name" (arr id >>> mkText)
359 returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
362 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
363 pageListingToXHTML env
365 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
366 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
367 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
368 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
370 name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
372 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
373 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
375 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
376 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
377 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
381 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
386 += getXPathTreesInDoc "/pageListing/@path/text()"
391 += sattr "rel" "stylesheet"
392 += sattr "type" "text/css"
393 += attr "href" (arr id >>> mkText)
395 += ( constL scriptSrc
398 += sattr "type" "text/javascript"
399 += attr "src" (arr id >>> mkText)
402 += sattr "type" "text/javascript"
403 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
404 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
409 += sattr "class" "header"
412 += sattr "class" "center"
414 += sattr "class" "title"
418 += sattr "class" "body"
420 += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
424 += attr "href" ( getText
426 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
437 += sattr "class" "footer"
440 += sattr "class" "left sideBar"
442 += sattr "class" "content"
443 += constL leftSideBar
447 += sattr "class" "right sideBar"
449 += sattr "class" "content"
450 += constL rightSideBar
455 uniqueNamespacesFromDeclAndQNames
460 <pageNotFound name="Foo/Bar" />
462 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
463 handlePageNotFound env
465 -> do tree <- ( eelem "/"
466 += ( eelem "pageNotFound"
467 += attr "name" (arr id >>> mkText)
470 returnA -< do setStatus NotFound
471 outputXmlPage' tree (notFoundToXHTML env)
474 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
477 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
478 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
479 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
480 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
482 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
484 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
485 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
487 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
488 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
489 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
493 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
498 += getXPathTreesInDoc "/pageNotFound/@name/text()"
503 += sattr "rel" "stylesheet"
504 += sattr "type" "text/css"
505 += attr "href" (arr id >>> mkText)
507 += ( constL scriptSrc
510 += sattr "type" "text/javascript"
511 += attr "src" (arr id >>> mkText)
514 += sattr "type" "text/javascript"
515 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
516 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
521 += sattr "class" "header"
524 += sattr "class" "center"
526 += sattr "class" "title"
530 += sattr "class" "body"
531 += txt "404 Not Found (FIXME)" -- FIXME
535 += sattr "class" "footer"
538 += sattr "class" "left sideBar"
540 += sattr "class" "content"
541 += constL leftSideBar
545 += sattr "class" "right sideBar"
547 += sattr "class" "content"
548 += constL rightSideBar
553 uniqueNamespacesFromDeclAndQNames
557 handlePut :: Environment -> PageName -> Resource ()
559 = do userID <- getUserID env
560 runXmlA env "rakka-page-1.0.rng" $ proc tree
561 -> do page <- parseXmlizedPage -< (name, tree)
562 status <- putPageA (envStorage env) -< (userID, page)
563 returnA -< setStatus status
566 handleDelete :: Environment -> PageName -> Resource ()
567 handleDelete env name
568 = do userID <- getUserID env
569 status <- deletePage (envStorage env) userID name
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 mkFeedURIStr :: URI -> PageName -> String
584 mkFeedURIStr baseURI name
585 = uriToString id (mkFeedURI baseURI name) ""