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
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.Wiki.Engine
23 import System.FilePath
24 import Text.XML.HXT.Arrow.Namespace
25 import Text.XML.HXT.Arrow.WriteDocument
26 import Text.XML.HXT.Arrow.XmlArrow
27 import Text.XML.HXT.Arrow.XmlIOStateArrow
28 import Text.XML.HXT.Arrow.XmlNodeSet
29 import Text.XML.HXT.DOM.TypeDefs
30 import Text.XML.HXT.DOM.XmlKeywords
33 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
34 fallbackPageEntity env path
35 | null path = return Nothing
36 | null $ head path = return Nothing
37 | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
39 = return $ Just $ ResourceDef {
40 resUsesNativeThread = False
42 , resGet = Just $ handleGet env (toPageName path)
45 , resPut = Just $ handlePut env (toPageName path)
46 , resDelete = Just $ handleDelete env (toPageName path)
49 toPageName :: [String] -> PageName
50 toPageName = decodePageName . dropExtension . joinWith "/"
53 handleGet :: Environment -> PageName -> Resource ()
55 = runIdempotentA $ proc ()
56 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
59 -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
61 [] -> handlePageNotFound env -< name
62 _ -> handleGetPageListing env -< (name, items)
64 -> if isEntity page then
65 handleGetEntity env -< page
67 handleRedirect env -< page
72 Location: http://example.org/Destination.html#Redirect:Source
74 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
77 -> returnA -< do mType <- getEntityType
79 MIMEType "application" "xhtml+xml" _
80 -> do BaseURI baseURI <- getSysConf (envSysConf env)
81 let uri = mkPageFragmentURI
84 ("Redirect:" ++ redirName redir)
87 MIMEType "text" "xml" _
88 -> do setContentType mType
89 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
95 writeDocumentToString [ (a_indent, v_1) ]
99 _ -> fail ("internal error: getEntityType returned " ++ show mType)
102 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
105 -> do tree <- xmlizePage -< page
106 returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
107 -- てゐる可能性があるので、ETag も
108 -- Last-Modified も返す事が出來ない。
109 case entityType page of
110 MIMEType "text" "x-rakka" _
112 _ -> case entityRevision page of
113 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
114 rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
116 outputXmlPage tree (entityToXHTML env)
119 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
122 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
123 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
124 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
125 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
127 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
128 isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
130 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
131 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
133 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
134 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
135 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
136 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
140 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
141 += ( getXPathTreesInDoc "/page/@lang"
143 qattr (QN "xml" "lang" "")
144 ( getXPathTreesInDoc "/page/@lang/text()" )
150 += getXPathTreesInDoc "/page/@name/text()"
155 += sattr "rel" "stylesheet"
156 += sattr "type" "text/css"
157 += attr "href" (arr id >>> mkText)
159 += ( constL scriptSrc
162 += sattr "type" "text/javascript"
163 += attr "src" (arr id >>> mkText)
166 += sattr "type" "text/javascript"
167 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
168 += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
169 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
174 += sattr "class" "header"
177 += sattr "class" "center"
179 += sattr "class" "title"
183 += sattr "class" "body"
188 += sattr "class" "footer"
191 += sattr "class" "left sideBar"
193 += sattr "class" "content"
194 += constL leftSideBar
198 += sattr "class" "right sideBar"
200 += sattr "class" "content"
201 += constL rightSideBar
206 uniqueNamespacesFromDeclAndQNames
210 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
212 -> a (PageName, Maybe XmlTree, PageName) XmlTree
214 = proc (mainPageName, mainPage, subPageName) ->
215 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
216 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
217 -< (mainPageName, mainPage, subPage)
222 <pageListing path="Foo">
223 <page name="Foo/Bar" />
224 <page name="Foo/Baz" />
227 handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
228 handleGetPageListing env
230 -> do tree <- ( eelem "/"
231 += ( eelem "pageListing"
232 += attr "path" (arr fst >>> mkText)
236 += attr "name" (arr id >>> mkText)
241 returnA -< outputXmlPage tree (pageListingToXHTML env)
244 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
245 pageListingToXHTML env
247 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
248 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
249 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
250 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
252 name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
254 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
255 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
257 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
258 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
259 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
263 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
268 += getXPathTreesInDoc "/pageListing/@path/text()"
273 += sattr "rel" "stylesheet"
274 += sattr "type" "text/css"
275 += attr "href" (arr id >>> mkText)
277 += ( constL scriptSrc
280 += sattr "type" "text/javascript"
281 += attr "src" (arr id >>> mkText)
284 += sattr "type" "text/javascript"
285 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
286 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
291 += sattr "class" "header"
294 += sattr "class" "center"
296 += sattr "class" "title"
300 += sattr "class" "body"
302 += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
306 += attr "href" ( getText
308 arr (\ x -> uriToString id (mkPageURI baseURI x) "")
319 += sattr "class" "footer"
322 += sattr "class" "left sideBar"
324 += sattr "class" "content"
325 += constL leftSideBar
329 += sattr "class" "right sideBar"
331 += sattr "class" "content"
332 += constL rightSideBar
337 uniqueNamespacesFromDeclAndQNames
342 <pageNotFound name="Foo/Bar" />
344 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
345 handlePageNotFound env
347 -> do tree <- ( eelem "/"
348 += ( eelem "pageNotFound"
349 += attr "name" (arr id >>> mkText)
352 returnA -< do setStatus NotFound
353 outputXmlPage tree (notFoundToXHTML env)
356 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
359 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
360 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
361 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
362 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
364 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
366 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
367 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
369 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
370 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
371 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
375 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
380 += getXPathTreesInDoc "/pageNotFound/@name/text()"
385 += sattr "rel" "stylesheet"
386 += sattr "type" "text/css"
387 += attr "href" (arr id >>> mkText)
389 += ( constL scriptSrc
392 += sattr "type" "text/javascript"
393 += attr "src" (arr id >>> mkText)
396 += sattr "type" "text/javascript"
397 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
398 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
403 += sattr "class" "header"
406 += sattr "class" "center"
408 += sattr "class" "title"
412 += sattr "class" "body"
413 += txt "404 Not Found (FIXME)" -- FIXME
417 += sattr "class" "footer"
420 += sattr "class" "left sideBar"
422 += sattr "class" "content"
423 += constL leftSideBar
427 += sattr "class" "right sideBar"
429 += sattr "class" "content"
430 += constL rightSideBar
435 uniqueNamespacesFromDeclAndQNames
439 handlePut :: Environment -> PageName -> Resource ()
441 = do userID <- getUserID env
442 runXmlA env "rakka-page-1.0.rng" $ proc tree
443 -> do page <- parseXmlizedPage -< (name, tree)
444 status <- putPageA (envStorage env) -< (userID, page)
445 returnA -< setStatus status
448 handleDelete :: Environment -> PageName -> Resource ()
449 handleDelete env name
450 = do userID <- getUserID env
451 status <- deletePage (envStorage env) userID name