X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FRender.hs;h=3c0bd7a6a1ab4ae1dd4740d08fc672c01c10d34c;hb=98e508613bb7a50a1f65998ce87f065df957b736;hp=6aee49f684dbe0f63f5122aa5f85049439bc5e72;hpb=7c3065043cdfbd96539a9bf6bff9b1d4281c0b2a;p=Rakka.git diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index 6aee49f..3c0bd7a 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 @@ -51,12 +49,12 @@ handleGet env name -> do pageM <- getPageA (envStorage env) -< name 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,7 +64,7 @@ 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 @@ -75,11 +73,13 @@ handleRedirect env styleSheet="http://example.org/object/StyleSheet/Default" name="Foo/Bar" type="text/x-rakka" + lang="ja" -- 存在しない場合もある isTheme="no" -- text/css の場合のみ存在 isFeed="no" -- text/x-rakka の場合のみ存在 isLocked="no" + isBinary="no" revision="112"> -- デフォルトでない場合のみ存在 - lastModified="2000-01-01T00:00:00" /> + lastModified="2000-01-01T00:00:00"> blah blah... @@ -89,77 +89,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,6 +131,11 @@ 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()" @@ -188,10 +157,94 @@ entityToXHTML += 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 "/pageNotFound/@styleSheet/text()" ) + ) + ) + += ( eelem "body" + += ( eelem "div" + += sattr "class" "header" + ) + += ( eelem "div" + += 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" @@ -201,12 +254,14 @@ entityToXHTML += sattr "class" "left sideBar" += ( eelem "div" += sattr "class" "content" + += getXPathTreesInDoc "/pageNotFound/sideBar/left/*" ) ) += ( eelem "div" += sattr "class" "right sideBar" += ( eelem "div" += sattr "class" "content" + += getXPathTreesInDoc "/pageNotFound/sideBar/right/*" ) ) )