1 module Rakka.Resource.Render
7 import Control.Arrow.ArrowIf
8 import Control.Arrow.ArrowIO
9 import Control.Arrow.ArrowList
11 import Network.HTTP.Lucu
12 import Network.HTTP.Lucu.Utils
14 import Rakka.Environment
18 import Rakka.SystemConfig
20 import Rakka.Wiki.Engine
21 import System.FilePath
23 import Text.XML.HXT.Arrow.Namespace
24 import Text.XML.HXT.Arrow.XmlArrow
25 import Text.XML.HXT.Arrow.XmlNodeSet
26 import Text.XML.HXT.DOM.TypeDefs
29 fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
30 fallbackRender env path
31 | null path = return Nothing
32 | null $ head path = return Nothing
33 | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
35 = return $ Just $ ResourceDef {
36 resUsesNativeThread = False
38 , resGet = Just $ handleGet env (toPageName path)
45 toPageName :: [String] -> PageName
46 toPageName = decodePageName . dropExtension . joinWith "/"
49 handleGet :: Environment -> PageName -> Resource ()
51 = runIdempotentA $ proc ()
52 -> do pageM <- getPageA (envStorage env) -< name
55 -> returnA -< foundNoEntity Nothing
57 Just redir@(Redirection _ _ _ _)
58 -> handleRedirect env -< redir
60 Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _)
61 -> handleGetEntity env -< entity
65 Location: http://example.org/Destination?from=Source
67 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
70 -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
71 returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
75 [pageIsBinary が False の場合]
77 <page site="CieloNegro"
78 baseURI="http://example.org/"
79 styleSheet="StyleSheet/Default"
82 isTheme="no" -- text/css の場合のみ存在
83 isFeed="no" -- text/x-rakka の場合のみ存在
85 revision="112"> -- デフォルトでない場合のみ存在
86 lastModified="2000-01-01T00:00:00" />
90 </summary> -- 存在しない場合もある
92 <otherLang> -- 存在しない場合もある
93 <link lang="ja" page="Bar/Baz" />
102 [pageIsBinary が True の場合: content 要素の代はりに object 要素]
104 <object data="/object/Foo/Bar" /> -- data 屬性に URI
106 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
108 = let sysConf = envSysConf env
111 -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< ()
112 BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< ()
113 StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< ()
117 += sattr "site" siteName
118 += sattr "baseURI" (uriToString id baseURI "")
119 += sattr "styleSheet" cssName
120 += sattr "name" (pageName page)
121 += sattr "type" (show $ pageType page)
122 += ( case pageType page of
123 MIMEType "text" "css" _
124 -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
127 += ( case pageType page of
128 MIMEType "text" "x-rakka" _
129 -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
132 += sattr "isLocked" (yesOrNo $ pageIsLocked page)
133 += ( case pageRevision page of
135 Just rev -> sattr "revision" (show rev)
137 += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
139 += ( case pageSummary page of
141 Just s -> eelem "summary" += txt s
144 += ( case pageOtherLang page of
146 xs -> selem "otherLang"
150 | (lang, page) <- xs ]
153 += ( case pageIsBinary page of
154 False -> eelem "content"
155 += (constA page >>> formatPage)
157 True -> eelem "object"
158 += sattr "data" (uriToString id (mkObjectURI baseURI $ pageName page) "")
161 uniqueNamespacesFromDeclAndQNames
165 returnA -< do let lastMod = toClockTime $ pageLastMod page
167 case pageRevision page of
168 Nothing -> foundTimeStamp lastMod
169 Just rev -> foundEntity (strongETag $ show rev) lastMod
171 outputXmlPage tree entityToXHTML
174 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
178 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
181 += getXPathTreesInDoc "/page/@site/text()"
183 += getXPathTreesInDoc "/page/@name/text()"
187 ( getXPathTreesInDoc "/page/@baseURI/text()" )
190 += sattr "rel" "stylesheet"
191 += sattr "type" "text/css"
195 getXPathTreesInDoc "/page/@styleSheet/text()"
207 += sattr "class" "header"
210 += sattr "class" "center"
212 += sattr "class" "title"
215 += sattr "class" "body"
216 += getXPathTreesInDoc "/page/content/*"
217 += ( getXPathTreesInDoc "/page/object"
221 ( getXPathTreesInDoc "/page/object/@data/text()" )
226 += sattr "class" "footer"
229 += sattr "class" "left side-bar"
231 += sattr "class" "content"
235 += sattr "class" "right side-bar"
237 += sattr "class" "content"
242 uniqueNamespacesFromDeclAndQNames