1 module Rakka.Resource.Render
7 import Control.Arrow.ArrowIO
8 import Control.Arrow.ArrowList
10 import Network.HTTP.Lucu
11 import Network.HTTP.Lucu.Utils
13 import Rakka.Environment
17 import Rakka.SystemConfig
19 import Rakka.Wiki.Engine
20 import System.FilePath
22 import Text.XML.HXT.Arrow.Namespace
23 import Text.XML.HXT.Arrow.XmlArrow
24 import Text.XML.HXT.Arrow.XmlNodeSet
25 import Text.XML.HXT.DOM.TypeDefs
28 fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
29 fallbackRender env path
30 | null path = return Nothing
31 | null $ head path = return Nothing
32 | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
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
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) (BaseURI undefined) -< ()
70 returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
74 <page site="CieloNegro"
75 styleSheet="http://example.org/object/StyleSheet/Default"
78 isTheme="no" -- text/css の場合のみ存在
79 isFeed="no" -- text/x-rakka の場合のみ存在
81 revision="112"> -- デフォルトでない場合のみ存在
82 lastModified="2000-01-01T00:00:00">
86 </summary> -- 存在しない場合もある
88 <otherLang> -- 存在しない場合もある
89 <link lang="ja" page="Bar/Baz" />
110 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
113 -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< ()
114 BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< ()
115 StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< ()
117 Just pageTitle <- getPageA (envStorage env) -< "PageTitle"
118 Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left"
119 Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
123 += sattr "site" siteName
124 += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
125 += sattr "name" (pageName page)
126 += sattr "type" (show $ pageType page)
127 += ( case pageType page of
128 MIMEType "text" "css" _
129 -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
132 += ( case pageType page of
133 MIMEType "text" "x-rakka" _
134 -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
137 += sattr "isLocked" (yesOrNo $ pageIsLocked page)
138 += ( case pageRevision page of
140 Just rev -> sattr "revision" (show rev)
142 += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
144 += ( case pageSummary page of
146 Just s -> eelem "summary" += txt s
149 += ( case pageOtherLang page of
151 xs -> selem "otherLang"
155 | (lang, page) <- xs ]
157 += ( eelem "pageTitle"
158 += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
165 += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
171 += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
178 += (constA page >>> formatPage env)
181 uniqueNamespacesFromDeclAndQNames
185 returnA -< do let lastMod = toClockTime $ pageLastMod page
187 -- text/x-rakka の場合は、内容が動的に生成され
188 -- てゐる可能性があるので、ETag も
189 -- Last-Modified も返す事が出來ない。
190 case pageType page of
191 MIMEType "text" "x-rakka" _
193 _ -> case pageRevision page of
194 Nothing -> foundTimeStamp lastMod
195 Just rev -> foundEntity (strongETag $ show rev) lastMod
197 outputXmlPage tree entityToXHTML
199 sysConf :: SystemConfig
200 sysConf = envSysConf env
203 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
207 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
210 += getXPathTreesInDoc "/page/@site/text()"
212 += getXPathTreesInDoc "/page/@name/text()"
215 += sattr "rel" "stylesheet"
216 += sattr "type" "text/css"
218 ( getXPathTreesInDoc "/page/@styleSheet/text()" )
223 += sattr "class" "header"
226 += sattr "class" "center"
228 += sattr "class" "title"
229 += getXPathTreesInDoc "/page/pageTitle/*"
232 += sattr "class" "body"
233 += getXPathTreesInDoc "/page/body/*"
237 += sattr "class" "footer"
240 += sattr "class" "left sideBar"
242 += sattr "class" "content"
243 += getXPathTreesInDoc "/page/sideBar/left/*"
247 += sattr "class" "right sideBar"
249 += sattr "class" "content"
250 += getXPathTreesInDoc "/page/sideBar/right/*"
255 uniqueNamespacesFromDeclAndQNames
260 <pageNotFound site="CieloNegro"
261 styleSheet="http://example.org/object/StyleSheet/Default"
278 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
279 handlePageNotFound env
281 -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< ()
282 BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< ()
283 StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< ()
285 Just pageTitle <- getPageA (envStorage env) -< "PageTitle"
286 Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left"
287 Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
290 += ( eelem "pageNotFound"
291 += sattr "site" siteName
292 += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
295 += ( eelem "pageTitle"
296 += ( (constA name &&& constA Nothing &&& constA pageTitle)
303 += ( (constA name &&& constA Nothing &&& constA leftSideBar)
309 += ( (constA name &&& constA Nothing &&& constA rightSideBar)
316 uniqueNamespacesFromDeclAndQNames
320 returnA -< do setStatus NotFound
321 outputXmlPage tree notFoundToXHTML
323 sysConf :: SystemConfig
324 sysConf = envSysConf env
327 notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree
331 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
334 += getXPathTreesInDoc "/pageNotFound/@site/text()"
336 += getXPathTreesInDoc "/pageNotFound/@name/text()"
339 += sattr "rel" "stylesheet"
340 += sattr "type" "text/css"
342 ( getXPathTreesInDoc "/pageNotFound/@styleSheet/text()" )
347 += sattr "class" "header"
350 += sattr "class" "center"
352 += sattr "class" "title"
353 += getXPathTreesInDoc "/pageNotFound/pageTitle/*"
356 += sattr "class" "body"
357 += txt "404 Not Found (FIXME)" -- FIXME
361 += sattr "class" "footer"
364 += sattr "class" "left sideBar"
366 += sattr "class" "content"
367 += getXPathTreesInDoc "/pageNotFound/sideBar/left/*"
371 += sattr "class" "right sideBar"
373 += sattr "class" "content"
374 += getXPathTreesInDoc "/pageNotFound/sideBar/right/*"
379 uniqueNamespacesFromDeclAndQNames