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)
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)
58 -> handlePageNotFound env -< name
60 Just redir@(Redirection _ _ _ _ _)
61 -> handleRedirect env -< redir
63 Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
64 -> handleGetEntity env -< entity
68 Location: http://example.org/Destination.html#Redirect:Source
70 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
73 -> returnA -< do mType <- getEntityType
75 MIMEType "application" "xhtml+xml" _
76 -> do BaseURI baseURI <- getSysConf (envSysConf env)
77 let uri = mkPageFragmentURI
80 ("Redirect:" ++ redirName redir)
83 MIMEType "text" "xml" _
84 -> do setContentType mType
85 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
91 writeDocumentToString [ (a_indent, v_1) ]
95 _ -> fail ("internal error: getEntityType returned " ++ show mType)
98 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
101 -> do tree <- xmlizePage -< page
102 returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
103 -- てゐる可能性があるので、ETag も
104 -- Last-Modified も返す事が出來ない。
105 case entityType page of
106 MIMEType "text" "x-rakka" _
108 _ -> case entityRevision page of
109 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
110 rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
112 outputXmlPage tree (entityToXHTML env)
115 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
118 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
119 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
120 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
122 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
124 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
125 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
127 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
128 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
129 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
130 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
134 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
135 += ( getXPathTreesInDoc "/page/@lang"
137 qattr (QN "xml" "lang" "")
138 ( getXPathTreesInDoc "/page/@lang/text()" )
144 += getXPathTreesInDoc "/page/@name/text()"
149 += sattr "rel" "stylesheet"
150 += sattr "type" "text/css"
151 += attr "href" (arr id >>> mkText)
153 += ( constL scriptSrc
156 += sattr "type" "text/javascript"
157 += attr "src" (arr id >>> mkText)
160 += sattr "type" "text/javascript"
161 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
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 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
204 -> a (PageName, Maybe XmlTree, PageName) XmlTree
206 = proc (mainPageName, mainPage, subPageName) ->
207 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
208 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
209 -< (mainPageName, mainPage, subPage)
214 <pageNotFound name="Foo/Bar" />
216 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
217 handlePageNotFound env
219 -> do tree <- ( eelem "/"
220 += ( eelem "pageNotFound"
221 += attr "name" (arr id >>> mkText)
224 returnA -< do setStatus NotFound
225 outputXmlPage tree (notFoundToXHTML env)
228 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
231 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
232 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
233 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
235 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
237 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
238 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
240 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
241 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
242 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
246 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
251 += getXPathTreesInDoc "/pageNotFound/@name/text()"
256 += sattr "rel" "stylesheet"
257 += sattr "type" "text/css"
258 += attr "href" (arr id >>> mkText)
260 += ( constL scriptSrc
263 += sattr "type" "text/javascript"
264 += attr "src" (arr id >>> mkText)
267 += sattr "type" "text/javascript"
268 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
273 += sattr "class" "header"
276 += sattr "class" "center"
278 += sattr "class" "title"
282 += sattr "class" "body"
283 += txt "404 Not Found (FIXME)" -- FIXME
287 += sattr "class" "footer"
290 += sattr "class" "left sideBar"
292 += sattr "class" "content"
293 += constL leftSideBar
297 += sattr "class" "right sideBar"
299 += sattr "class" "content"
300 += constL rightSideBar
305 uniqueNamespacesFromDeclAndQNames
309 handlePut :: Environment -> PageName -> Resource ()
311 = runXmlA env "rakka-page-1.0.rng" $ proc tree
312 -> do page <- parseXmlizedPage -< (name, tree)
313 status <- putPageA (envStorage env) -< page
314 returnA -< setStatus status