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)
58 Nothing -> handlePageNotFound env -< name
59 Just page -> if isEntity page then
60 handleGetEntity env -< page
62 handleRedirect env -< page
67 Location: http://example.org/Destination.html#Redirect:Source
69 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
72 -> returnA -< do mType <- getEntityType
74 MIMEType "application" "xhtml+xml" _
75 -> do BaseURI baseURI <- getSysConf (envSysConf env)
76 let uri = mkPageFragmentURI
79 ("Redirect:" ++ redirName redir)
82 MIMEType "text" "xml" _
83 -> do setContentType mType
84 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
90 writeDocumentToString [ (a_indent, v_1) ]
94 _ -> fail ("internal error: getEntityType returned " ++ show mType)
97 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
100 -> do tree <- xmlizePage -< page
101 returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
102 -- てゐる可能性があるので、ETag も
103 -- Last-Modified も返す事が出來ない。
104 case entityType page of
105 MIMEType "text" "x-rakka" _
107 _ -> case entityRevision page of
108 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
109 rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
111 outputXmlPage tree (entityToXHTML env)
114 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
117 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
118 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
119 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
120 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
122 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
123 isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
125 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
126 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
128 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
129 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
130 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
131 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
135 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
136 += ( getXPathTreesInDoc "/page/@lang"
138 qattr (QN "xml" "lang" "")
139 ( getXPathTreesInDoc "/page/@lang/text()" )
145 += getXPathTreesInDoc "/page/@name/text()"
150 += sattr "rel" "stylesheet"
151 += sattr "type" "text/css"
152 += attr "href" (arr id >>> mkText)
154 += ( constL scriptSrc
157 += sattr "type" "text/javascript"
158 += attr "src" (arr id >>> mkText)
161 += sattr "type" "text/javascript"
162 += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
163 += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
164 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
169 += sattr "class" "header"
172 += sattr "class" "center"
174 += sattr "class" "title"
178 += sattr "class" "body"
183 += sattr "class" "footer"
186 += sattr "class" "left sideBar"
188 += sattr "class" "content"
189 += constL leftSideBar
193 += sattr "class" "right sideBar"
195 += sattr "class" "content"
196 += constL rightSideBar
201 uniqueNamespacesFromDeclAndQNames
205 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
207 -> a (PageName, Maybe XmlTree, PageName) XmlTree
209 = proc (mainPageName, mainPage, subPageName) ->
210 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
211 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
212 -< (mainPageName, mainPage, subPage)
217 <pageNotFound name="Foo/Bar" />
219 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
220 handlePageNotFound env
222 -> do tree <- ( eelem "/"
223 += ( eelem "pageNotFound"
224 += attr "name" (arr id >>> mkText)
227 returnA -< do setStatus NotFound
228 outputXmlPage tree (notFoundToXHTML env)
231 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
234 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
235 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
236 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
237 GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
239 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
241 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
242 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
244 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
245 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
246 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
250 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
255 += getXPathTreesInDoc "/pageNotFound/@name/text()"
260 += sattr "rel" "stylesheet"
261 += sattr "type" "text/css"
262 += attr "href" (arr id >>> mkText)
264 += ( constL scriptSrc
267 += sattr "type" "text/javascript"
268 += attr "src" (arr id >>> mkText)
271 += sattr "type" "text/javascript"
272 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
273 += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
278 += sattr "class" "header"
281 += sattr "class" "center"
283 += sattr "class" "title"
287 += sattr "class" "body"
288 += txt "404 Not Found (FIXME)" -- FIXME
292 += sattr "class" "footer"
295 += sattr "class" "left sideBar"
297 += sattr "class" "content"
298 += constL leftSideBar
302 += sattr "class" "right sideBar"
304 += sattr "class" "content"
305 += constL rightSideBar
310 uniqueNamespacesFromDeclAndQNames
314 handlePut :: Environment -> PageName -> Resource ()
316 = do userID <- getUserID env
317 runXmlA env "rakka-page-1.0.rng" $ proc tree
318 -> do page <- parseXmlizedPage -< (name, tree)
319 status <- putPageA (envStorage env) -< (userID, page)
320 returnA -< setStatus status
323 handleDelete :: Environment -> PageName -> Resource ()
324 handleDelete env name
325 = do userID <- getUserID env
326 status <- deletePage (envStorage env) userID name