1 module Rakka.Resource.PageEntity
7 import Control.Arrow.ArrowIO
8 import Control.Arrow.ArrowIf
9 import Control.Arrow.ArrowList
12 import Network.HTTP.Lucu
13 import Network.HTTP.Lucu.Utils
15 import Rakka.Environment
19 import Rakka.SystemConfig
20 import Rakka.Wiki.Engine
21 import System.FilePath
23 import Text.XML.HXT.Arrow.XmlArrow
24 import Text.XML.HXT.Arrow.XmlNodeSet
25 import Text.XML.HXT.DOM.TypeDefs
28 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
29 fallbackPageEntity env path
30 | null path = return Nothing
31 | null $ head path = return Nothing
32 | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
34 = return $ Just $ ResourceDef {
35 resUsesNativeThread = False
37 , resGet = Just $ handleGet env (toPageName path)
44 toPageName :: [String] -> PageName
45 toPageName = decodePageName . dropExtension . joinWith "/"
48 handleGet :: Environment -> PageName -> Resource ()
50 = runIdempotentA $ proc ()
51 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
54 -> handlePageNotFound env -< name
56 Just redir@(Redirection _ _ _ _)
57 -> handleRedirect env -< redir
59 Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
60 -> handleGetEntity env -< entity
64 Location: http://example.org/Destination?from=Source
66 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
69 -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
70 returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
73 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
76 -> do tree <- xmlizePage -< page
77 returnA -< do let lastMod = toClockTime $ pageLastMod page
79 -- text/x-rakka の場合は、内容が動的に生成され
81 -- Last-Modified も返す事が出來ない。
83 MIMEType "text" "x-rakka" _
85 _ -> case pageRevision page of
86 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ
87 rev -> foundEntity (strongETag $ show rev) lastMod
89 outputXmlPage tree (entityToXHTML env)
92 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
95 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
96 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
97 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
99 pageName <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
101 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
102 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
104 pageTitle <- listA (readSubPage env) -< (pageName, Just page, "PageTitle")
105 leftSideBar <- listA (readSubPage env) -< (pageName, Just page, "SideBar/Left")
106 rightSideBar <- listA (readSubPage env) -< (pageName, Just page, "SideBar/Right")
107 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
111 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
112 += ( getXPathTreesInDoc "/page/@lang"
114 qattr (QN "xml" "lang" "")
115 ( getXPathTreesInDoc "/page/@lang/text()" )
121 += getXPathTreesInDoc "/page/@name/text()"
126 += sattr "rel" "stylesheet"
127 += sattr "type" "text/css"
128 += attr "href" (arr id >>> mkText)
130 += ( constL scriptSrc
133 += sattr "type" "text/javascript"
134 += attr "src" (arr id >>> mkText)
139 += sattr "class" "header"
142 += sattr "class" "center"
144 += sattr "class" "title"
148 += sattr "class" "body"
153 += sattr "class" "footer"
156 += sattr "class" "left sideBar"
158 += sattr "class" "content"
159 += constL leftSideBar
163 += sattr "class" "right sideBar"
165 += sattr "class" "content"
166 += constL rightSideBar
173 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
175 -> a (PageName, Maybe XmlTree, PageName) XmlTree
177 = proc (mainPageName, mainPage, subPageName) ->
178 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
179 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
180 -< (mainPageName, mainPage, subPage)
185 <pageNotFound name="Foo/Bar" />
187 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
188 handlePageNotFound env
190 -> do tree <- ( eelem "/"
191 += ( eelem "pageNotFound"
192 += attr "name" (arr id >>> mkText)
195 returnA -< do setStatus NotFound
196 outputXmlPage tree (notFoundToXHTML env)
199 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
202 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
203 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
204 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
206 pageName <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
208 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
209 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
211 pageTitle <- listA (readSubPage env) -< (pageName, Nothing, "PageTitle")
212 leftSideBar <- listA (readSubPage env) -< (pageName, Nothing, "SideBar/Left")
213 rightSideBar <- listA (readSubPage env) -< (pageName, Nothing, "SideBar/Right")
217 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
222 += getXPathTreesInDoc "/pageNotFound/@name/text()"
227 += sattr "rel" "stylesheet"
228 += sattr "type" "text/css"
229 += attr "href" (arr id >>> mkText)
231 += ( constL scriptSrc
234 += sattr "type" "text/javascript"
235 += attr "src" (arr id >>> mkText)
240 += sattr "class" "header"
243 += sattr "class" "center"
245 += sattr "class" "title"
249 += sattr "class" "body"
250 += txt "404 Not Found (FIXME)" -- FIXME
254 += sattr "class" "footer"
257 += sattr "class" "left sideBar"
259 += sattr "class" "content"
260 += constL leftSideBar
264 += sattr "class" "right sideBar"
266 += sattr "class" "content"
267 += constL rightSideBar