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
14 import Network.URI hiding (path)
15 import Rakka.Environment
19 import Rakka.SystemConfig
20 import Rakka.Wiki.Engine
21 import System.FilePath
22 import Text.XML.HXT.Arrow.XmlArrow
23 import Text.XML.HXT.Arrow.XmlNodeSet
24 import Text.XML.HXT.DOM.TypeDefs
27 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
28 fallbackPageEntity env path
29 | null path = return Nothing
30 | null $ head path = return Nothing
31 | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
33 = return $ Just $ ResourceDef {
34 resUsesNativeThread = False
36 , resGet = Just $ handleGet env (toPageName path)
39 , resPut = Just $ handlePut env (toPageName path)
43 toPageName :: [String] -> PageName
44 toPageName = decodePageName . dropExtension . joinWith "/"
47 handleGet :: Environment -> PageName -> Resource ()
49 = runIdempotentA $ proc ()
50 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
53 -> handlePageNotFound env -< name
55 Just redir@(Redirection _ _ _ _ _)
56 -> handleRedirect env -< redir
58 Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
59 -> handleGetEntity env -< entity
63 Location: http://example.org/Destination?from=Source
65 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
68 -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
69 returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
72 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
75 -> do tree <- xmlizePage -< page
76 returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
78 -- Last-Modified も返す事が出來ない。
79 case entityType page of
80 MIMEType "text" "x-rakka" _
82 _ -> case entityRevision page of
83 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
84 rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
86 outputXmlPage tree (entityToXHTML env)
89 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
92 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
93 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
94 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
96 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
98 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
99 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
101 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
102 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
103 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
104 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
108 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
109 += ( getXPathTreesInDoc "/page/@lang"
111 qattr (QN "xml" "lang" "")
112 ( getXPathTreesInDoc "/page/@lang/text()" )
118 += getXPathTreesInDoc "/page/@name/text()"
123 += sattr "rel" "stylesheet"
124 += sattr "type" "text/css"
125 += attr "href" (arr id >>> mkText)
127 += ( constL scriptSrc
130 += sattr "type" "text/javascript"
131 += attr "src" (arr id >>> mkText)
136 += sattr "class" "header"
139 += sattr "class" "center"
141 += sattr "class" "title"
145 += sattr "class" "body"
150 += sattr "class" "footer"
153 += sattr "class" "left sideBar"
155 += sattr "class" "content"
156 += constL leftSideBar
160 += sattr "class" "right sideBar"
162 += sattr "class" "content"
163 += constL rightSideBar
170 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
172 -> a (PageName, Maybe XmlTree, PageName) XmlTree
174 = proc (mainPageName, mainPage, subPageName) ->
175 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
176 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
177 -< (mainPageName, mainPage, subPage)
182 <pageNotFound name="Foo/Bar" />
184 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
185 handlePageNotFound env
187 -> do tree <- ( eelem "/"
188 += ( eelem "pageNotFound"
189 += attr "name" (arr id >>> mkText)
192 returnA -< do setStatus NotFound
193 outputXmlPage tree (notFoundToXHTML env)
196 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
199 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
200 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
201 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
203 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
205 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
206 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
208 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
209 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
210 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
214 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
219 += getXPathTreesInDoc "/pageNotFound/@name/text()"
224 += sattr "rel" "stylesheet"
225 += sattr "type" "text/css"
226 += attr "href" (arr id >>> mkText)
228 += ( constL scriptSrc
231 += sattr "type" "text/javascript"
232 += attr "src" (arr id >>> mkText)
237 += sattr "class" "header"
240 += sattr "class" "center"
242 += sattr "class" "title"
246 += sattr "class" "body"
247 += txt "404 Not Found (FIXME)" -- FIXME
251 += sattr "class" "footer"
254 += sattr "class" "left sideBar"
256 += sattr "class" "content"
257 += constL leftSideBar
261 += sattr "class" "right sideBar"
263 += sattr "class" "content"
264 += constL rightSideBar
271 handlePut :: Environment -> PageName -> Resource ()
273 = runXmlA env "rakka-page-1.0.rng" $ proc tree
274 -> do page <- parseXmlizedPage -< (name, tree)
275 status <- putPageA (envStorage env) -< page
276 returnA -< setStatus status