1 module Rakka.Resource.PageEntity
6 import qualified Codec.Binary.UTF8.String as UTF8
7 import Control.Monad.Trans
8 import qualified Data.ByteString.Lazy as L hiding (ByteString)
10 import qualified Data.Map as M
13 import Network.HTTP.Lucu
14 import Network.HTTP.Lucu.Utils
15 import Network.URI hiding (path)
16 import Rakka.Environment
20 import Rakka.SystemConfig
22 import Rakka.W3CDateTime
23 import Rakka.Wiki.Engine
24 import System.FilePath
25 import Text.HyperEstraier hiding (getText)
26 import Text.XML.HXT.Arrow
27 import Text.XML.HXT.DOM.TypeDefs
28 import Text.XML.HXT.DOM.XmlKeywords
31 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
32 fallbackPageEntity env path
33 | null path = return Nothing
34 | null $ head path = return Nothing
35 | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
37 = return $ Just $ ResourceDef {
38 resUsesNativeThread = False
40 , resGet = Just $ handleGet env (toPageName path)
43 , resPut = Just $ handlePut env (toPageName path)
44 , resDelete = Just $ handleDelete env (toPageName path)
47 toPageName :: [String] -> PageName
48 toPageName = decodePageName . dropExtension . joinWith "/"
51 handleGet :: Environment -> PageName -> Resource ()
53 = do BaseURI baseURI <- getSysConf (envSysConf env)
54 runIdempotentA baseURI $ proc ()
55 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
58 -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
60 [] -> handlePageNotFound env -< name
61 _ -> handleGetPageListing env -< (name, items)
63 -> if isEntity page then
64 handleGetEntity env -< page
66 handleRedirect env -< page
71 Location: http://example.org/Destination.html#Redirect:Source
73 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
76 -> returnA -< do mType <- getEntityType
78 MIMEType "text" "xml" _
79 -> do setContentType mType
80 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
86 writeDocumentToString [ (a_indent , v_1 )
87 , (a_output_encoding, utf8)
88 , (a_no_xml_pi , v_0 ) ]
92 _ -> do BaseURI baseURI <- getSysConf (envSysConf env)
93 let uri = mkPageFragmentURI
96 ("Redirect:" ++ redirName redir)
100 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
103 -> do tree <- xmlizePage -< page
104 returnA -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
105 , (MIMEType "application" "rss+xml" [], entityToRSS env)
109 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
112 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
113 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
114 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
115 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
117 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
118 isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
120 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
121 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
123 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
124 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
125 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
126 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
130 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
131 += ( getXPathTreesInDoc "/page/@lang"
133 qattr (mkQName "xml" "lang" "")
134 ( getXPathTreesInDoc "/page/@lang/text()" )
140 += getXPathTreesInDoc "/page/@name/text()"
145 += sattr "rel" "stylesheet"
146 += sattr "type" "text/css"
147 += attr "href" (arr id >>> mkText)
150 += ( constL scriptSrc
153 += sattr "type" "text/javascript"
154 += attr "src" (arr id >>> mkText)
157 += sattr "type" "text/javascript"
158 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
159 += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
160 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
162 += mkGlobalJSList env
166 += sattr "class" "header"
169 += sattr "class" "center"
171 += sattr "class" "title"
175 += sattr "class" "body"
180 += sattr "class" "footer"
183 += sattr "class" "left sideBar"
185 += sattr "class" "content"
186 += constL leftSideBar
190 += sattr "class" "right sideBar"
192 += sattr "class" "content"
193 += constL rightSideBar
198 uniqueNamespacesFromDeclAndQNames
202 entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
205 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
206 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
208 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
209 summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
210 pages <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
214 += sattr "xmlns" "http://purl.org/rss/1.0/"
215 += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
216 += sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/"
217 += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
219 += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
223 += getXPathTreesInDoc "/page/@name/text()"
226 += txt (uriToString id baseURI "")
228 += ( eelem "description"
229 += txt (case summary of
230 Nothing -> "RSS Feed for " ++ siteName
238 += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
245 arr (\ n -> (n, Nothing))
247 getPageA (envStorage env)
252 += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
254 += (arr entityName >>> mkText)
257 += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
259 += ( arrL (\ p -> case entitySummary p of
267 += ( arrIO (utcToLocalZonedTime . entityLastMod)
269 arr formatW3CDateTime
274 += ( eelem "trackback:ping"
275 += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
279 uniqueNamespacesFromDeclAndQNames
282 mkPageURIStr :: URI -> PageName -> String
283 mkPageURIStr baseURI name
284 = uriToString id (mkPageURI baseURI name) ""
286 mkTrackbackURIStr :: URI -> PageName -> String
287 mkTrackbackURIStr baseURI name
288 = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
291 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
293 -> a (PageName, Maybe XmlTree, PageName) XmlTree
295 = proc (mainPageName, mainPage, subPageName) ->
296 do langM <- case mainPage of
298 -> returnA -< Nothing
300 -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p
301 subPage <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing)
302 localSubPage <- case langM of
304 -> returnA -< subPage
306 -> localize (envStorage env) -< (l, subPage)
307 subPageXml <- xmlizePage -< localSubPage
308 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
309 -< (Just mainPageName, mainPage, subPageXml)
312 localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page
314 = proc (lang, origPage)
315 -> do let otherLang = entityOtherLang origPage
316 localName = M.lookup lang otherLang
319 -> returnA -< origPage
321 -> do localPage <- getPageA sto -< (ln, Nothing)
322 returnA -< case localPage of
328 <pageListing path="Foo">
329 <page name="Foo/Bar" />
330 <page name="Foo/Baz" />
333 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
334 handleGetPageListing env
336 -> do tree <- ( eelem "/"
337 += ( eelem "pageListing"
338 += attr "path" (arr fst >>> mkText)
342 += attr "name" (arr id >>> mkText)
347 returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
350 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
351 pageListingToXHTML env
353 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
354 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
355 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
356 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
358 name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
360 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
361 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
363 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
364 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
365 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
369 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
374 += getXPathTreesInDoc "/pageListing/@path/text()"
379 += sattr "rel" "stylesheet"
380 += sattr "type" "text/css"
381 += attr "href" (arr id >>> mkText)
384 += ( constL scriptSrc
387 += sattr "type" "text/javascript"
388 += attr "src" (arr id >>> mkText)
391 += sattr "type" "text/javascript"
392 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
393 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
395 += mkGlobalJSList env
399 += sattr "class" "header"
402 += sattr "class" "center"
404 += sattr "class" "title"
408 += sattr "class" "body"
410 += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
414 += attr "href" ( getText
416 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
427 += sattr "class" "footer"
430 += sattr "class" "left sideBar"
432 += sattr "class" "content"
433 += constL leftSideBar
437 += sattr "class" "right sideBar"
439 += sattr "class" "content"
440 += constL rightSideBar
445 uniqueNamespacesFromDeclAndQNames
450 <pageNotFound name="Foo/Bar" />
452 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
453 handlePageNotFound env
455 -> do tree <- ( eelem "/"
456 += ( eelem "pageNotFound"
457 += attr "name" (arr id >>> mkText)
460 returnA -< do setStatus NotFound
461 outputXmlPage' tree (notFoundToXHTML env)
464 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
467 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
468 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
469 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
470 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
472 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
474 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
475 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
477 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
478 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
479 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
483 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
488 += getXPathTreesInDoc "/pageNotFound/@name/text()"
493 += sattr "rel" "stylesheet"
494 += sattr "type" "text/css"
495 += attr "href" (arr id >>> mkText)
498 += ( constL scriptSrc
501 += sattr "type" "text/javascript"
502 += attr "src" (arr id >>> mkText)
505 += sattr "type" "text/javascript"
506 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
507 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
509 += mkGlobalJSList env
513 += sattr "class" "header"
516 += sattr "class" "center"
518 += sattr "class" "title"
522 += sattr "class" "body"
523 += txt "404 Not Found (FIXME)" -- FIXME
527 += sattr "class" "footer"
530 += sattr "class" "left sideBar"
532 += sattr "class" "content"
533 += constL leftSideBar
537 += sattr "class" "right sideBar"
539 += sattr "class" "content"
540 += constL rightSideBar
545 uniqueNamespacesFromDeclAndQNames
549 handlePut :: Environment -> PageName -> Resource ()
551 = do userID <- getUserID env
552 runXmlA env "rakka-page-1.0.rng" $ proc tree
553 -> do page <- parseXmlizedPage -< (name, tree)
554 status <- putPageA (envStorage env) -< (userID, page)
555 returnA -< setStatus status
558 handleDelete :: Environment -> PageName -> Resource ()
559 handleDelete env name
560 = do userID <- getUserID env
561 status <- deletePage (envStorage env) userID name
565 mkFeedList :: (ArrowIO a, ArrowXml a) => Environment -> a b XmlTree
567 = proc _ -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
568 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
570 feed <- unlistA <<< arrIO0 (findFeeds $ envStorage env) -< ()
573 += sattr "rel" "alternate"
574 += sattr "type" "application/rss+xml"
575 += attr "title" (txt siteName <+> txt " - " <+> mkText)
576 += attr "href" (arr (mkFeedURIStr baseURI) >>> mkText) ) -<< feed
579 findFeeds :: Storage -> IO [PageName]
581 = do cond <- newCondition
582 setPhrase cond "[UVSET]"
583 addAttrCond cond "rakka:isFeed STREQ yes"
584 setOrder cond "@uri STRA"
585 result <- searchPages sto cond
586 return (map hpPageName $ srPages result)
589 mkGlobalJSList :: (ArrowIO a, ArrowXml a, ArrowChoice a) => Environment -> a b XmlTree
591 = proc _ -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
593 scriptName <- unlistA <<< arrIO0 (findJavaScripts $ envStorage env) -< ()
594 pageM <- getPageA (envStorage env) -< (scriptName, Nothing)
597 Nothing -> none -< ()
600 -> ( if entityIsBinary page then
602 += sattr "type" "text/javascript"
603 += attr "src" (arr (mkObjectURIStr baseURI . pageName) >>> mkText) )
606 += sattr "type" "text/javascript"
607 += (arr (UTF8.decode . L.unpack . entityContent) >>> mkText) )
613 findJavaScripts :: Storage -> IO [PageName]
615 = do cond <- newCondition
616 setPhrase cond "[UVSET]"
617 addAttrCond cond "@title STRBW Global/"
618 addAttrCond cond "@type STRBW text/javascript"
619 setOrder cond "@uri STRA"
620 result <- searchPages sto cond
621 return (map hpPageName $ srPages result)
624 mkFeedURIStr :: URI -> PageName -> String
625 mkFeedURIStr baseURI name
626 = uriToString id (mkFeedURI baseURI name) ""
629 mkObjectURIStr :: URI -> PageName -> String
630 mkObjectURIStr baseURI name
631 = uriToString id (mkObjectURI baseURI name) ""