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 -> returnA -< foundNoEntity Nothing
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" />
97 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
99 = let sysConf = envSysConf env
102 -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< ()
103 BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< ()
104 StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< ()
108 += sattr "site" siteName
109 += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
110 += sattr "name" (pageName page)
111 += sattr "type" (show $ pageType page)
112 += ( case pageType page of
113 MIMEType "text" "css" _
114 -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
117 += ( case pageType page of
118 MIMEType "text" "x-rakka" _
119 -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
122 += sattr "isLocked" (yesOrNo $ pageIsLocked page)
123 += ( case pageRevision page of
125 Just rev -> sattr "revision" (show rev)
127 += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
129 += ( case pageSummary page of
131 Just s -> eelem "summary" += txt s
134 += ( case pageOtherLang page of
136 xs -> selem "otherLang"
140 | (lang, page) <- xs ]
143 += (constA page >>> formatPage env )
146 uniqueNamespacesFromDeclAndQNames
150 returnA -< do let lastMod = toClockTime $ pageLastMod page
152 case pageRevision page of
153 Nothing -> foundTimeStamp lastMod
154 Just rev -> foundEntity (strongETag $ show rev) lastMod
156 outputXmlPage tree entityToXHTML
159 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
163 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
166 += getXPathTreesInDoc "/page/@site/text()"
168 += getXPathTreesInDoc "/page/@name/text()"
171 += sattr "rel" "stylesheet"
172 += sattr "type" "text/css"
174 ( getXPathTreesInDoc "/page/@styleSheet/text()" )
179 += sattr "class" "header"
182 += sattr "class" "center"
184 += sattr "class" "title"
187 += sattr "class" "body"
188 += getXPathTreesInDoc "/page/content/*"
192 += sattr "class" "footer"
195 += sattr "class" "left side-bar"
197 += sattr "class" "content"
201 += sattr "class" "right side-bar"
203 += sattr "class" "content"
208 uniqueNamespacesFromDeclAndQNames