1 module Rakka.Resource.Render
7 import Control.Arrow.ArrowIO
8 import Control.Arrow.ArrowIf
10 import Network.HTTP.Lucu
11 import Network.HTTP.Lucu.Utils
12 import Rakka.Environment
16 import Rakka.SystemConfig
17 import Rakka.Wiki.Engine
18 import System.FilePath
20 import Text.XML.HXT.Arrow.Namespace
21 import Text.XML.HXT.Arrow.XmlArrow
22 import Text.XML.HXT.Arrow.XmlNodeSet
23 import Text.XML.HXT.DOM.TypeDefs
26 fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
27 fallbackRender env path
28 | null path = return Nothing
29 | null $ head path = return Nothing
30 | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
32 = return $ Just $ ResourceDef {
33 resUsesNativeThread = False
35 , resGet = Just $ handleGet env (toPageName path)
42 toPageName :: [String] -> PageName
43 toPageName = decodePageName . dropExtension . joinWith "/"
46 handleGet :: Environment -> PageName -> Resource ()
48 = runIdempotentA $ proc ()
49 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
52 -> handlePageNotFound env -< name
54 Just redir@(Redirection _ _ _ _)
55 -> handleRedirect env -< redir
57 Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
58 -> handleGetEntity env -< entity
62 Location: http://example.org/Destination?from=Source
64 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
67 -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
68 returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
72 <page site="CieloNegro"
73 baseURI="http://example.org"
76 lang="ja" -- 存在しない場合もある
77 fileName="bar.rakka" -- 存在しない場合もある
78 isTheme="no" -- text/css の場合のみ存在
79 isFeed="no" -- text/x-rakka の場合のみ存在
82 revision="112"> -- デフォルトでない場合のみ存在
83 lastModified="2000-01-01T00:00:00">
86 <styleSheet src="http://example.org/object/StyleSheet/Default" />
90 <script src="http://example.org/js" />
95 </summary> -- 存在しない場合もある
97 <otherLang> -- 存在しない場合もある
98 <link lang="ja" page="Bar/Baz" />
118 <source><!-- isBinary="no" の場合にのみ存在 -->
123 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
126 -> do tree <- formatEntirePage (envStorage env) (envSysConf env) (envInterpTable env) -< page
127 returnA -< do let lastMod = toClockTime $ pageLastMod page
129 -- text/x-rakka の場合は、内容が動的に生成され
130 -- てゐる可能性があるので、ETag も
131 -- Last-Modified も返す事が出來ない。
132 case pageType page of
133 MIMEType "text" "x-rakka" _
135 _ -> case pageRevision page of
136 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ
137 rev -> foundEntity (strongETag $ show rev) lastMod
139 outputXmlPage tree entityToXHTML
142 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
146 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
147 += ( getXPathTreesInDoc "/page/@lang"
149 qattr (QN "xml" "lang" "")
150 ( getXPathTreesInDoc "/page/@lang/text()" )
154 += getXPathTreesInDoc "/page/@site/text()"
156 += getXPathTreesInDoc "/page/@name/text()"
158 += ( getXPathTreesInDoc "/page/styleSheets/styleSheet"
161 += sattr "rel" "stylesheet"
162 += sattr "type" "text/css"
164 ( getXPathTrees "/styleSheet/@src/text()" )
166 += ( getXPathTreesInDoc "/page/scripts/script"
169 += sattr "type" "text/javascript"
171 ( getXPathTrees "/script/@src/text()" )
176 += sattr "class" "header"
179 += sattr "class" "center"
181 += sattr "class" "title"
182 += getXPathTreesInDoc "/page/pageTitle/*"
185 += sattr "class" "body"
186 += getXPathTreesInDoc "/page/body/*"
190 += sattr "class" "footer"
193 += sattr "class" "left sideBar"
195 += sattr "class" "content"
196 += getXPathTreesInDoc "/page/sideBar/left/*"
200 += sattr "class" "right sideBar"
202 += sattr "class" "content"
203 += getXPathTreesInDoc "/page/sideBar/right/*"
208 uniqueNamespacesFromDeclAndQNames
213 <pageNotFound site="CieloNegro"
214 baseURI="http://example.org"
218 <styleSheet src="http://example.org/object/StyleSheet/Default" />
222 <script src="http://example.org/js" />
239 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
240 handlePageNotFound env
242 -> do tree <- formatUnexistentPage (envStorage env) (envSysConf env) (envInterpTable env) -< name
243 returnA -< do setStatus NotFound
244 outputXmlPage tree notFoundToXHTML
247 notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree
251 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
254 += getXPathTreesInDoc "/pageNotFound/@site/text()"
256 += getXPathTreesInDoc "/pageNotFound/@name/text()"
258 += ( getXPathTreesInDoc "/pageNotFound/styleSheets/styleSheet"
261 += sattr "rel" "stylesheet"
262 += sattr "type" "text/css"
264 ( getXPathTrees "/styleSheet/@src/text()" )
266 += ( getXPathTreesInDoc "/pageNotFound/scripts/script"
269 += sattr "type" "text/javascript"
271 ( getXPathTrees "/script/@src/text()" )
276 += sattr "class" "header"
279 += sattr "class" "center"
281 += sattr "class" "title"
282 += getXPathTreesInDoc "/pageNotFound/pageTitle/*"
285 += sattr "class" "body"
286 += txt "404 Not Found (FIXME)" -- FIXME
290 += sattr "class" "footer"
293 += sattr "class" "left sideBar"
295 += sattr "class" "content"
296 += getXPathTreesInDoc "/pageNotFound/sideBar/left/*"
300 += sattr "class" "right sideBar"
302 += sattr "class" "content"
303 += getXPathTreesInDoc "/pageNotFound/sideBar/right/*"
308 uniqueNamespacesFromDeclAndQNames