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
21 import Rakka.Wiki.Engine
22 import System.FilePath
23 import Text.XML.HXT.Arrow.Namespace
24 import Text.XML.HXT.Arrow.WriteDocument
25 import Text.XML.HXT.Arrow.XmlArrow
26 import Text.XML.HXT.Arrow.XmlIOStateArrow
27 import Text.XML.HXT.Arrow.XmlNodeSet
28 import Text.XML.HXT.DOM.TypeDefs
29 import Text.XML.HXT.DOM.XmlKeywords
32 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
33 fallbackPageEntity env path
34 | null path = return Nothing
35 | null $ head path = return Nothing
36 | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
38 = return $ Just $ ResourceDef {
39 resUsesNativeThread = False
41 , resGet = Just $ handleGet env (toPageName path)
44 , resPut = Just $ handlePut env (toPageName path)
45 , resDelete = Just $ handleDelete env (toPageName path)
48 toPageName :: [String] -> PageName
49 toPageName = decodePageName . dropExtension . joinWith "/"
52 handleGet :: Environment -> PageName -> Resource ()
54 = runIdempotentA $ proc ()
55 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
57 Nothing -> handlePageNotFound env -< name
58 Just page -> if isEntity page then
59 handleGetEntity env -< page
61 handleRedirect env -< page
66 Location: http://example.org/Destination.html#Redirect:Source
68 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
71 -> returnA -< do mType <- getEntityType
73 MIMEType "application" "xhtml+xml" _
74 -> do BaseURI baseURI <- getSysConf (envSysConf env)
75 let uri = mkPageFragmentURI
78 ("Redirect:" ++ redirName redir)
81 MIMEType "text" "xml" _
82 -> do setContentType mType
83 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
89 writeDocumentToString [ (a_indent, v_1) ]
93 _ -> fail ("internal error: getEntityType returned " ++ show mType)
96 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
99 -> do tree <- xmlizePage -< page
100 returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
101 -- てゐる可能性があるので、ETag も
102 -- Last-Modified も返す事が出來ない。
103 case entityType page of
104 MIMEType "text" "x-rakka" _
106 _ -> case entityRevision page of
107 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
108 rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
110 outputXmlPage tree (entityToXHTML 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) -< ()
120 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
122 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
123 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
125 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
126 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
127 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
128 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
132 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
133 += ( getXPathTreesInDoc "/page/@lang"
135 qattr (QN "xml" "lang" "")
136 ( getXPathTreesInDoc "/page/@lang/text()" )
142 += getXPathTreesInDoc "/page/@name/text()"
147 += sattr "rel" "stylesheet"
148 += sattr "type" "text/css"
149 += attr "href" (arr id >>> mkText)
151 += ( constL scriptSrc
154 += sattr "type" "text/javascript"
155 += attr "src" (arr id >>> mkText)
158 += sattr "type" "text/javascript"
159 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
164 += sattr "class" "header"
167 += sattr "class" "center"
169 += sattr "class" "title"
173 += sattr "class" "body"
178 += sattr "class" "footer"
181 += sattr "class" "left sideBar"
183 += sattr "class" "content"
184 += constL leftSideBar
188 += sattr "class" "right sideBar"
190 += sattr "class" "content"
191 += constL rightSideBar
196 uniqueNamespacesFromDeclAndQNames
200 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
202 -> a (PageName, Maybe XmlTree, PageName) XmlTree
204 = proc (mainPageName, mainPage, subPageName) ->
205 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
206 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
207 -< (mainPageName, mainPage, subPage)
212 <pageNotFound name="Foo/Bar" />
214 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
215 handlePageNotFound env
217 -> do tree <- ( eelem "/"
218 += ( eelem "pageNotFound"
219 += attr "name" (arr id >>> mkText)
222 returnA -< do setStatus NotFound
223 outputXmlPage tree (notFoundToXHTML env)
226 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
229 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
230 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
231 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
233 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
235 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
236 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
238 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
239 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
240 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
244 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
249 += getXPathTreesInDoc "/pageNotFound/@name/text()"
254 += sattr "rel" "stylesheet"
255 += sattr "type" "text/css"
256 += attr "href" (arr id >>> mkText)
258 += ( constL scriptSrc
261 += sattr "type" "text/javascript"
262 += attr "src" (arr id >>> mkText)
265 += sattr "type" "text/javascript"
266 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
271 += sattr "class" "header"
274 += sattr "class" "center"
276 += sattr "class" "title"
280 += sattr "class" "body"
281 += txt "404 Not Found (FIXME)" -- FIXME
285 += sattr "class" "footer"
288 += sattr "class" "left sideBar"
290 += sattr "class" "content"
291 += constL leftSideBar
295 += sattr "class" "right sideBar"
297 += sattr "class" "content"
298 += constL rightSideBar
303 uniqueNamespacesFromDeclAndQNames
307 handlePut :: Environment -> PageName -> Resource ()
309 = do userID <- getUserID env
310 runXmlA env "rakka-page-1.0.rng" $ proc tree
311 -> do page <- parseXmlizedPage -< (name, tree)
312 status <- putPageA (envStorage env) -< (userID, page)
313 returnA -< setStatus status
316 handleDelete :: Environment -> PageName -> Resource ()
317 handleDelete env name
318 = do userID <- getUserID env
319 status <- deletePage (envStorage env) userID name