1 module Rakka.Resource.PageEntity
7 import Control.Arrow.ArrowIO
8 import Control.Arrow.ArrowIf
9 import Control.Arrow.ArrowList
10 import Control.Monad.Trans
13 import Network.HTTP.Lucu
14 import Network.HTTP.Lucu.Utils
15 import Network.URI hiding (path)
16 import Rakka.Environment
20 import Rakka.SystemConfig
21 import Rakka.Wiki.Engine
22 import System.FilePath
23 import Text.XML.HXT.Arrow.WriteDocument
24 import Text.XML.HXT.Arrow.XmlArrow
25 import Text.XML.HXT.Arrow.XmlIOStateArrow
26 import Text.XML.HXT.Arrow.XmlNodeSet
27 import Text.XML.HXT.DOM.TypeDefs
28 import Text.XML.HXT.DOM.XmlKeywords
31 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
32 fallbackPageEntity env path
33 | null path = return Nothing
34 | null $ head path = return Nothing
35 | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
37 = return $ Just $ ResourceDef {
38 resUsesNativeThread = False
40 , resGet = Just $ handleGet env (toPageName path)
43 , resPut = Just $ handlePut env (toPageName path)
47 toPageName :: [String] -> PageName
48 toPageName = decodePageName . dropExtension . joinWith "/"
51 handleGet :: Environment -> PageName -> Resource ()
53 = runIdempotentA $ proc ()
54 -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
57 -> handlePageNotFound env -< name
59 Just redir@(Redirection _ _ _ _ _)
60 -> handleRedirect env -< redir
62 Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
63 -> handleGetEntity env -< entity
67 Location: http://example.org/Destination.html#Redirect:Source
69 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
72 -> returnA -< do mType <- getEntityType
74 MIMEType "application" "xhtml+xml" _
75 -> do BaseURI baseURI <- getSysConf (envSysConf env)
76 let uri = mkPageFragmentURI
79 ("Redirect:" ++ redirName redir)
82 MIMEType "text" "xml" _
83 -> do setContentType mType
84 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
90 writeDocumentToString [ (a_indent, v_1) ]
94 _ -> fail ("internal error: getEntityType returned " ++ show mType)
97 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
100 -> do tree <- xmlizePage -< page
101 returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
102 -- てゐる可能性があるので、ETag も
103 -- Last-Modified も返す事が出來ない。
104 case entityType page of
105 MIMEType "text" "x-rakka" _
107 _ -> case entityRevision page of
108 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
109 rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
111 outputXmlPage tree (entityToXHTML env)
114 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
117 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
118 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
119 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
121 name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
123 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
124 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
126 pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle")
127 leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
128 rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
129 pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
133 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
134 += ( getXPathTreesInDoc "/page/@lang"
136 qattr (QN "xml" "lang" "")
137 ( getXPathTreesInDoc "/page/@lang/text()" )
143 += getXPathTreesInDoc "/page/@name/text()"
148 += sattr "rel" "stylesheet"
149 += sattr "type" "text/css"
150 += attr "href" (arr id >>> mkText)
152 += ( constL scriptSrc
155 += sattr "type" "text/javascript"
156 += attr "src" (arr id >>> mkText)
159 += sattr "type" "text/javascript"
160 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
165 += sattr "class" "header"
168 += sattr "class" "center"
170 += sattr "class" "title"
174 += sattr "class" "body"
179 += sattr "class" "footer"
182 += sattr "class" "left sideBar"
184 += sattr "class" "content"
185 += constL leftSideBar
189 += sattr "class" "right sideBar"
191 += sattr "class" "content"
192 += constL rightSideBar
199 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
201 -> a (PageName, Maybe XmlTree, PageName) XmlTree
203 = proc (mainPageName, mainPage, subPageName) ->
204 do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
205 subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
206 -< (mainPageName, mainPage, subPage)
211 <pageNotFound name="Foo/Bar" />
213 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
214 handlePageNotFound env
216 -> do tree <- ( eelem "/"
217 += ( eelem "pageNotFound"
218 += attr "name" (arr id >>> mkText)
221 returnA -< do setStatus NotFound
222 outputXmlPage tree (notFoundToXHTML env)
225 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
228 -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
229 BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
230 StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
232 name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
234 let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
235 scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
237 pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
238 leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
239 rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
243 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
248 += getXPathTreesInDoc "/pageNotFound/@name/text()"
253 += sattr "rel" "stylesheet"
254 += sattr "type" "text/css"
255 += attr "href" (arr id >>> mkText)
257 += ( constL scriptSrc
260 += sattr "type" "text/javascript"
261 += attr "src" (arr id >>> mkText)
264 += sattr "type" "text/javascript"
265 += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
270 += sattr "class" "header"
273 += sattr "class" "center"
275 += sattr "class" "title"
279 += sattr "class" "body"
280 += txt "404 Not Found (FIXME)" -- FIXME
284 += sattr "class" "footer"
287 += sattr "class" "left sideBar"
289 += sattr "class" "content"
290 += constL leftSideBar
294 += sattr "class" "right sideBar"
296 += sattr "class" "content"
297 += constL rightSideBar
304 handlePut :: Environment -> PageName -> Resource ()
306 = runXmlA env "rakka-page-1.0.rng" $ proc tree
307 -> do page <- parseXmlizedPage -< (name, tree)
308 status <- putPageA (envStorage env) -< page
309 returnA -< setStatus status