X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FRender.hs;h=cb01bcd35f3aa5abca2c7da7f97a9b6d47944261;hb=859d4378c2e2a1ccc8028821a37eeaa43aaa23fb;hp=7b72400cbecbf317590f05a4a159619fc4a42843;hpb=f832f12703d807f5fc3350dc71d8624ffc5b97a5;p=Rakka.git
diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs
index 7b72400..cb01bcd 100644
--- a/Rakka/Resource/Render.hs
+++ b/Rakka/Resource/Render.hs
@@ -5,17 +5,15 @@ module Rakka.Resource.Render
import Control.Arrow
import Control.Arrow.ArrowIO
-import Control.Arrow.ArrowList
+import Control.Arrow.ArrowIf
import Data.Char
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
-import Network.URI
import Rakka.Environment
import Rakka.Page
import Rakka.Resource
import Rakka.Storage
import Rakka.SystemConfig
-import Rakka.Utils
import Rakka.Wiki.Engine
import System.FilePath
import System.Time
@@ -27,9 +25,9 @@ import Text.XML.HXT.DOM.TypeDefs
fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
fallbackRender env path
- | null path = return Nothing
- | null $ head path = return Nothing
- | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar ã®ãããªå½¢å¼ã§ãªãã
+ | null path = return Nothing
+ | null $ head path = return Nothing
+ | isLower $ head $ head path = return Nothing -- å
é ã®æåãå°æåã§ãã£ã¦ã¯ãªããªã
| otherwise
= return $ Just $ ResourceDef {
resUsesNativeThread = False
@@ -48,15 +46,15 @@ fallbackRender env path
handleGet :: Environment -> PageName -> Resource ()
handleGet env name
= runIdempotentA $ proc ()
- -> do pageM <- getPageA (envStorage env) -< name
+ -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
case pageM of
Nothing
- -> returnA -< foundNoEntity Nothing
+ -> handlePageNotFound env -< name
Just redir@(Redirection _ _ _ _)
-> handleRedirect env -< redir
- Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _)
+ Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
-> handleGetEntity env -< entity
{-
@@ -66,20 +64,30 @@ handleGet env name
handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
handleRedirect env
= proc redir
- -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+ -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
{-
-- ããã©ã«ãã§ãªãå ´åã®ã¿åå¨
- lastModified="2000-01-01T00:00:00" />
+ isBinary="no"
+ revision="112"> -- ããã©ã«ãã§ãªãå ´åã®ã¿åå¨
+ lastModified="2000-01-01T00:00:00">
+
+
+
+
+
+
+
+
blah blah...
@@ -89,77 +97,41 @@ handleRedirect env
-
+
+ blah blah...
+
+
+
+
+ blah blah...
+
+
+ blah blah...
+
+
+
+
blah blah...
-
+
-}
handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
handleGetEntity env
- = let sysConf = envSysConf env
- in
- proc page
- -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< ()
- BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< ()
- StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< ()
-
- tree <- ( eelem "/"
- += ( eelem "page"
- += sattr "site" siteName
- += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
- += sattr "name" (pageName page)
- += sattr "type" (show $ pageType page)
- += ( case pageType page of
- MIMEType "text" "css" _
- -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
- _ -> none
- )
- += ( case pageType page of
- MIMEType "text" "x-rakka" _
- -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
- _ -> none
- )
- += sattr "isLocked" (yesOrNo $ pageIsLocked page)
- += ( case pageRevision page of
- Nothing -> none
- Just rev -> sattr "revision" (show rev)
- )
- += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
-
- += ( case pageSummary page of
- Nothing -> none
- Just s -> eelem "summary" += txt s
- )
-
- += ( case pageOtherLang page of
- [] -> none
- xs -> selem "otherLang"
- [ eelem "link"
- += sattr "lang" lang
- += sattr "page" page
- | (lang, page) <- xs ]
- )
- += ( eelem "content"
- += (constA page >>> formatPage env )
- )
- >>>
- uniqueNamespacesFromDeclAndQNames
- )
- ) -<< ()
-
- returnA -< do let lastMod = toClockTime $ pageLastMod page
+ = proc page
+ -> do tree <- formatEntirePage (envStorage env) (envSysConf env) (envInterpTable env) -< page
+ returnA -< do let lastMod = toClockTime $ pageLastMod page
- -- text/x-rakka ã®å ´åã¯ãå
容ãåçã«ç
- -- æããã¦ããå¯è½æ§ãããã®ã§ãETag ã
- -- Last-Modified ãè¿ãäºãåºä¾ãªãã
- case pageType page of
- MIMEType "text" "x-rakka" _
- -> return ()
- _ -> case pageRevision page of
- Nothing -> foundTimeStamp lastMod
- Just rev -> foundEntity (strongETag $ show rev) lastMod
+ -- text/x-rakka ã®å ´åã¯ãå
容ãåçã«çæãã
+ -- ã¦ããå¯è½æ§ãããã®ã§ãETag ã
+ -- Last-Modified ãè¿ãäºãåºä¾ãªãã
+ case pageType page of
+ MIMEType "text" "x-rakka" _
+ -> return ()
+ _ -> case pageRevision page of
+ 0 -> foundTimeStamp lastMod -- 0 ã¯ããã©ã«ããã¼ã¸
+ rev -> foundEntity (strongETag $ show rev) lastMod
- outputXmlPage tree entityToXHTML
+ outputXmlPage tree entityToXHTML
entityToXHTML :: ArrowXml a => a XmlTree XmlTree
@@ -167,17 +139,114 @@ entityToXHTML
= eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+ += ( getXPathTreesInDoc "/page/@lang"
+ `guards`
+ qattr (QN "xml" "lang" "")
+ ( getXPathTreesInDoc "/page/@lang/text()" )
+ )
+= ( eelem "head"
+= ( eelem "title"
+= getXPathTreesInDoc "/page/@site/text()"
+= txt " - "
+= getXPathTreesInDoc "/page/@name/text()"
)
+ += ( getXPathTreesInDoc "/page/styleSheets/styleSheet"
+ >>>
+ eelem "link"
+ += sattr "rel" "stylesheet"
+ += sattr "type" "text/css"
+ += attr "href"
+ ( getXPathTrees "/styleSheet/@src/text()" )
+ )
+ += ( getXPathTreesInDoc "/page/scripts/script"
+ >>>
+ eelem "script"
+ += sattr "type" "text/javascript"
+ += attr "src"
+ ( getXPathTrees "/script/@src/text()" )
+ )
+ )
+ += ( eelem "body"
+ += ( eelem "div"
+ += sattr "class" "header"
+ )
+ += ( eelem "div"
+ += sattr "class" "center"
+ += ( eelem "div"
+ += sattr "class" "title"
+ += getXPathTreesInDoc "/page/pageTitle/*"
+ )
+ += ( eelem "div"
+ += sattr "class" "body"
+ += getXPathTreesInDoc "/page/body/*"
+ )
+ )
+ += ( eelem "div"
+ += sattr "class" "footer"
+ )
+ += ( eelem "div"
+ += sattr "class" "left sideBar"
+ += ( eelem "div"
+ += sattr "class" "content"
+ += getXPathTreesInDoc "/page/sideBar/left/*"
+ )
+ )
+ += ( eelem "div"
+ += sattr "class" "right sideBar"
+ += ( eelem "div"
+ += sattr "class" "content"
+ += getXPathTreesInDoc "/page/sideBar/right/*"
+ )
+ )
+ )
+ >>>
+ uniqueNamespacesFromDeclAndQNames
+ )
+
+
+{-
+
+
+
+ blah blah...
+
+
+
+
+ blah blah...
+
+
+ blah blah...
+
+
+
+-}
+handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
+handlePageNotFound env
+ = proc name
+ -> do tree <- formatUnexistentPage (envStorage env) (envSysConf env) (envInterpTable env) -< name
+ returnA -< do setStatus NotFound
+ outputXmlPage tree notFoundToXHTML
+
+
+notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree
+notFoundToXHTML
+ = eelem "/"
+ += ( eelem "html"
+ += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+ += ( eelem "head"
+ += ( eelem "title"
+ += getXPathTreesInDoc "/pageNotFound/@site/text()"
+ += txt " - "
+ += getXPathTreesInDoc "/pageNotFound/@name/text()"
+ )
+= ( eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= attr "href"
- ( getXPathTreesInDoc "/page/@styleSheet/text()" )
+ ( getXPathTreesInDoc "/pageNotFound/@styleSheet/text()" )
)
)
+= ( eelem "body"
@@ -188,25 +257,28 @@ entityToXHTML
+= sattr "class" "center"
+= ( eelem "div"
+= sattr "class" "title"
+ += getXPathTreesInDoc "/pageNotFound/pageTitle/*"
)
+= ( eelem "div"
+= sattr "class" "body"
- += getXPathTreesInDoc "/page/content/*"
+ += txt "404 Not Found (FIXME)" -- FIXME
)
)
+= ( eelem "div"
+= sattr "class" "footer"
)
+= ( eelem "div"
- += sattr "class" "left side-bar"
+ += sattr "class" "left sideBar"
+= ( eelem "div"
+= sattr "class" "content"
+ += getXPathTreesInDoc "/pageNotFound/sideBar/left/*"
)
)
+= ( eelem "div"
- += sattr "class" "right side-bar"
+ += sattr "class" "right sideBar"
+= ( eelem "div"
+= sattr "class" "content"
+ += getXPathTreesInDoc "/pageNotFound/sideBar/right/*"
)
)
)