1 module Rakka.Resource.Render
7 import Control.Arrow.ArrowIO
8 import Control.Arrow.ArrowIf
9 import Control.Arrow.ArrowList
11 import qualified Data.Map as M
12 import Network.HTTP.Lucu
13 import Network.HTTP.Lucu.Utils
15 import Rakka.Environment
19 import Rakka.SystemConfig
21 import Rakka.Wiki.Engine
22 import System.FilePath
24 import Text.XML.HXT.Arrow.Namespace
25 import Text.XML.HXT.Arrow.XmlArrow
26 import Text.XML.HXT.Arrow.XmlNodeSet
27 import Text.XML.HXT.DOM.TypeDefs
30 fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
31 fallbackRender env path
32 | null path = return Nothing
33 | null $ head path = return Nothing
34 | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
36 = return $ Just $ ResourceDef {
37 resUsesNativeThread = False
39 , resGet = Just $ handleGet env (toPageName path)
46 toPageName :: [String] -> PageName
47 toPageName = decodePageName . dropExtension . joinWith "/"
50 handleGet :: Environment -> PageName -> Resource ()
52 = runIdempotentA $ proc ()
53 -> do pageM <- getPageA (envStorage env) -< name
56 -> handlePageNotFound env -< name
58 Just redir@(Redirection _ _ _ _)
59 -> handleRedirect env -< redir
61 Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _)
62 -> handleGetEntity env -< entity
66 Location: http://example.org/Destination?from=Source
68 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
71 -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
72 returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
76 <page site="CieloNegro"
77 styleSheet="http://example.org/object/StyleSheet/Default"
80 lang="ja" -- 存在しない場合もある
81 isTheme="no" -- text/css の場合のみ存在
82 isFeed="no" -- text/x-rakka の場合のみ存在
84 revision="112"> -- デフォルトでない場合のみ存在
85 lastModified="2000-01-01T00:00:00">
89 </summary> -- 存在しない場合もある
91 <otherLang> -- 存在しない場合もある
92 <link lang="ja" page="Bar/Baz" />
113 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
116 -> do SiteName siteName <- getSysConfA sysConf -< ()
117 BaseURI baseURI <- getSysConfA sysConf -< ()
118 StyleSheet cssName <- getSysConfA sysConf -< ()
120 Just pageTitle <- getPageA (envStorage env) -< "PageTitle"
121 Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left"
122 Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
126 += sattr "site" siteName
127 += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
128 += sattr "name" (pageName page)
129 += sattr "type" (show $ pageType page)
130 += ( case pageLanguage page of
131 Just x -> sattr "lang" x
134 += ( case pageType page of
135 MIMEType "text" "css" _
136 -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
139 += ( case pageType page of
140 MIMEType "text" "x-rakka" _
141 -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
144 += sattr "isLocked" (yesOrNo $ pageIsLocked page)
145 += ( case pageRevision page of
147 Just rev -> sattr "revision" (show rev)
149 += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
151 += ( case pageSummary page of
153 Just s -> eelem "summary" += txt s
156 += ( if M.null (pageOtherLang page) then
163 | (lang, page) <- M.toList (pageOtherLang page) ]
165 += ( eelem "pageTitle"
166 += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
173 += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
179 += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
186 += (constA page >>> formatPage env)
189 uniqueNamespacesFromDeclAndQNames
193 returnA -< do let lastMod = toClockTime $ pageLastMod page
195 -- text/x-rakka の場合は、内容が動的に生成され
196 -- てゐる可能性があるので、ETag も
197 -- Last-Modified も返す事が出來ない。
198 case pageType page of
199 MIMEType "text" "x-rakka" _
201 _ -> case pageRevision page of
202 Nothing -> foundTimeStamp lastMod
203 Just rev -> foundEntity (strongETag $ show rev) lastMod
205 outputXmlPage tree entityToXHTML
207 sysConf :: SystemConfig
208 sysConf = envSysConf env
211 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
215 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
216 += ( getXPathTreesInDoc "/page/@lang"
218 qattr (QN "xml" "lang" "")
219 ( getXPathTreesInDoc "/page/@lang/text()" )
223 += getXPathTreesInDoc "/page/@site/text()"
225 += getXPathTreesInDoc "/page/@name/text()"
228 += sattr "rel" "stylesheet"
229 += sattr "type" "text/css"
231 ( getXPathTreesInDoc "/page/@styleSheet/text()" )
236 += sattr "class" "header"
239 += sattr "class" "center"
241 += sattr "class" "title"
242 += getXPathTreesInDoc "/page/pageTitle/*"
245 += sattr "class" "body"
246 += getXPathTreesInDoc "/page/body/*"
250 += sattr "class" "footer"
253 += sattr "class" "left sideBar"
255 += sattr "class" "content"
256 += getXPathTreesInDoc "/page/sideBar/left/*"
260 += sattr "class" "right sideBar"
262 += sattr "class" "content"
263 += getXPathTreesInDoc "/page/sideBar/right/*"
268 uniqueNamespacesFromDeclAndQNames
273 <pageNotFound site="CieloNegro"
274 styleSheet="http://example.org/object/StyleSheet/Default"
291 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
292 handlePageNotFound env
294 -> do SiteName siteName <- getSysConfA sysConf -< ()
295 BaseURI baseURI <- getSysConfA sysConf -< ()
296 StyleSheet cssName <- getSysConfA sysConf -< ()
298 Just pageTitle <- getPageA (envStorage env) -< "PageTitle"
299 Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left"
300 Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
303 += ( eelem "pageNotFound"
304 += sattr "site" siteName
305 += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
308 += ( eelem "pageTitle"
309 += ( (constA name &&& constA Nothing &&& constA pageTitle)
316 += ( (constA name &&& constA Nothing &&& constA leftSideBar)
322 += ( (constA name &&& constA Nothing &&& constA rightSideBar)
329 uniqueNamespacesFromDeclAndQNames
333 returnA -< do setStatus NotFound
334 outputXmlPage tree notFoundToXHTML
336 sysConf :: SystemConfig
337 sysConf = envSysConf env
340 notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree
344 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
347 += getXPathTreesInDoc "/pageNotFound/@site/text()"
349 += getXPathTreesInDoc "/pageNotFound/@name/text()"
352 += sattr "rel" "stylesheet"
353 += sattr "type" "text/css"
355 ( getXPathTreesInDoc "/pageNotFound/@styleSheet/text()" )
360 += sattr "class" "header"
363 += sattr "class" "center"
365 += sattr "class" "title"
366 += getXPathTreesInDoc "/pageNotFound/pageTitle/*"
369 += sattr "class" "body"
370 += txt "404 Not Found (FIXME)" -- FIXME
374 += sattr "class" "footer"
377 += sattr "class" "left sideBar"
379 += sattr "class" "content"
380 += getXPathTreesInDoc "/pageNotFound/sideBar/left/*"
384 += sattr "class" "right sideBar"
386 += sattr "class" "content"
387 += getXPathTreesInDoc "/pageNotFound/sideBar/right/*"
392 uniqueNamespacesFromDeclAndQNames