From: pho Date: Tue, 30 Oct 2007 10:26:56 +0000 (+0900) Subject: The big change X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=656fdb2772ab4de5cd083cbe9e7c1610cccef73b;p=Rakka.git The big change darcs-hash:20071030102656-62b54-449bda8a45c3e3ac65751704a133ea60a16cc4d0.gz --- diff --git a/Main.hs b/Main.hs index 8027c7e..6621f58 100644 --- a/Main.hs +++ b/Main.hs @@ -7,8 +7,8 @@ import Network.HTTP.Lucu import Rakka.Environment import Rakka.Resource.Index import Rakka.Resource.JavaScript +import Rakka.Resource.PageEntity import Rakka.Resource.Object -import Rakka.Resource.Render import Rakka.Storage import Subversion import System.Console.GetOpt @@ -128,7 +128,7 @@ main = withSubversion $ rebuildIndexIfRequested env opts infoM logger ("Listening to " ++ show portNum ++ "/tcp...") - runHttpd (envLucuConf env) (resTree env) [fallbackRender env] + runHttpd (envLucuConf env) (resTree env) [fallbackPageEntity env] resTree :: Environment -> ResTree diff --git a/Rakka.cabal b/Rakka.cabal index 737352f..47c87a1 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -51,7 +51,7 @@ Other-Modules: Rakka.Resource.Index Rakka.Resource.JavaScript Rakka.Resource.Object - Rakka.Resource.Render + Rakka.Resource.PageEntity Rakka.Storage Rakka.Storage.DefaultPage Rakka.Storage.Types diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs index 321ba7e..d40294a 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -5,9 +5,12 @@ module Rakka.Environment ) where +import Control.Arrow +import Control.Arrow.ArrowList import qualified Data.Map as M import Network import qualified Network.HTTP.Lucu.Config as LC +import Rakka.Page import Rakka.Storage import Rakka.SystemConfig import Rakka.Wiki.Engine @@ -22,6 +25,8 @@ import System.Directory import System.FilePath import System.IO import System.Log.Logger +import Text.HyperEstraier +import Text.XML.HXT.Arrow.XmlIOStateArrow logger = "Rakka.Environment" @@ -53,7 +58,7 @@ setupEnv lsdir portNum do noticeM logger ("Creating a subversion repository on " ++ reposPath) createRepository reposPath [] [] sysConf <- mkSystemConfig lucuConf repos - storage <- mkStorage lsdir repos (makeDraft interpTable) + storage <- mkStorage lsdir repos (makeDraft' interpTable) return $ Environment { envLocalStateDir = lsdir @@ -63,6 +68,18 @@ setupEnv lsdir portNum , envStorage = storage , envInterpTable = interpTable } + where + makeDraft' :: InterpTable -> Page -> IO Document + makeDraft' interpTable page + = do [doc] <- runX ( setErrorMsgHandler False fail + >>> + constA page + >>> + xmlizePage + >>> + makeDraft interpTable + ) + return doc mkInterpTable :: InterpTable diff --git a/Rakka/Page.hs b/Rakka/Page.hs index ec6ce80..9d84cf2 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -8,6 +8,7 @@ module Rakka.Page , decodePageName , pageFileName' + , defaultFileName , mkPageURI , mkPageFragmentURI @@ -89,14 +90,15 @@ encodeFragment = escapeURIString isSafeChar . C8.unpack . encode UTF8 pageFileName' :: Page -> String -pageFileName' page = fromMaybe (defaultFileName page) (pageFileName page) +pageFileName' page + = fromMaybe (defaultFileName (pageType page) (pageName page)) (pageFileName page) -defaultFileName :: Page -> String -defaultFileName page - = let baseName = takeFileName (pageName page) +defaultFileName :: MIMEType -> PageName -> String +defaultFileName pType pName + = let baseName = takeFileName pName in - case pageType page of + case pType of MIMEType "text" "x-rakka" _ -> baseName <.> "rakka" MIMEType "text" "css" _ -> baseName <.> "css" _ -> baseName diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs new file mode 100644 index 0000000..3c00612 --- /dev/null +++ b/Rakka/Resource/PageEntity.hs @@ -0,0 +1,271 @@ +module Rakka.Resource.PageEntity + ( fallbackPageEntity + ) + where + +import Control.Arrow +import Control.Arrow.ArrowIO +import Control.Arrow.ArrowIf +import Control.Arrow.ArrowList +import Data.Char +import Data.Maybe +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.Wiki.Engine +import System.FilePath +import System.Time +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlNodeSet +import Text.XML.HXT.DOM.TypeDefs + + +fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef) +fallbackPageEntity env path + | null path = return Nothing + | null $ head path = return Nothing + | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない + | otherwise + = return $ Just $ ResourceDef { + resUsesNativeThread = False + , resIsGreedy = True + , resGet = Just $ handleGet env (toPageName path) + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } + where + toPageName :: [String] -> PageName + toPageName = decodePageName . dropExtension . joinWith "/" + + +handleGet :: Environment -> PageName -> Resource () +handleGet env name + = runIdempotentA $ proc () + -> do pageM <- getPageA (envStorage env) -< (name, Nothing) + case pageM of + Nothing + -> handlePageNotFound env -< name + + Just redir@(Redirection _ _ _ _) + -> handleRedirect env -< redir + + Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _) + -> handleGetEntity env -< entity + +{- + HTTP/1.1 302 Found + Location: http://example.org/Destination?from=Source +-} +handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ()) +handleRedirect env + = proc redir + -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< () + returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME + + +handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ()) +handleGetEntity env + = proc page + -> do tree <- xmlizePage -< 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 + 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ + rev -> foundEntity (strongETag $ show rev) lastMod + + outputXmlPage tree (entityToXHTML env) + + +entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree +entityToXHTML env + = proc page + -> do SiteName siteName <- getSysConfA (envSysConf env) -< () + BaseURI baseURI <- getSysConfA (envSysConf env) -< () + StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () + + pageName <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page + + let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] + scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] + + pageTitle <- listA (readSubPage env) -< (pageName, Just page, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (pageName, Just page, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (pageName, Just page, "SideBar/Right") + pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page + + ( 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" + += txt siteName + += txt " - " + += getXPathTreesInDoc "/page/@name/text()" + ) + += ( constL cssHref + >>> + eelem "link" + += sattr "rel" "stylesheet" + += sattr "type" "text/css" + += attr "href" (arr id >>> mkText) + ) + += ( constL scriptSrc + >>> + eelem "script" + += sattr "type" "text/javascript" + += attr "src" (arr id >>> mkText) + ) + ) + += ( eelem "body" + += ( eelem "div" + += sattr "class" "header" + ) + += ( eelem "div" + += sattr "class" "center" + += ( eelem "div" + += sattr "class" "title" + += constL pageTitle + ) + += ( eelem "div" + += sattr "class" "body" + += constL pageBody + ) + ) + += ( eelem "div" + += sattr "class" "footer" + ) + += ( eelem "div" + += sattr "class" "left sideBar" + += ( eelem "div" + += sattr "class" "content" + += constL leftSideBar + ) + ) + += ( eelem "div" + += sattr "class" "right sideBar" + += ( eelem "div" + += sattr "class" "content" + += constL rightSideBar + ) + ) + ) + ) ) -<< page + + +readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => + Environment + -> a (PageName, Maybe XmlTree, PageName) XmlTree +readSubPage env + = proc (mainPageName, mainPage, subPageName) -> + do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing) + subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) + -< (mainPageName, mainPage, subPage) + returnA -< subXHTML + + +{- + +-} +handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ()) +handlePageNotFound env + = proc name + -> do tree <- ( eelem "/" + += ( eelem "pageNotFound" + += attr "name" (arr id >>> mkText) + ) + ) -< name + returnA -< do setStatus NotFound + outputXmlPage tree (notFoundToXHTML env) + + +notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree +notFoundToXHTML env + = proc pageNotFound + -> do SiteName siteName <- getSysConfA (envSysConf env) -< () + BaseURI baseURI <- getSysConfA (envSysConf env) -< () + StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () + + pageName <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound + + let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] + scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] + + pageTitle <- listA (readSubPage env) -< (pageName, Nothing, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (pageName, Nothing, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (pageName, Nothing, "SideBar/Right") + + ( eelem "/" + += ( eelem "html" + += sattr "xmlns" "http://www.w3.org/1999/xhtml" + += ( eelem "head" + += ( eelem "title" + += txt siteName + += txt " - " + += getXPathTreesInDoc "/pageNotFound/@name/text()" + ) + += ( constL cssHref + >>> + eelem "link" + += sattr "rel" "stylesheet" + += sattr "type" "text/css" + += attr "href" (arr id >>> mkText) + ) + += ( constL scriptSrc + >>> + eelem "script" + += sattr "type" "text/javascript" + += attr "src" (arr id >>> mkText) + ) + ) + += ( eelem "body" + += ( eelem "div" + += sattr "class" "header" + ) + += ( eelem "div" + += sattr "class" "center" + += ( eelem "div" + += sattr "class" "title" + += constL pageTitle + ) + += ( eelem "div" + += sattr "class" "body" + += txt "404 Not Found (FIXME)" -- FIXME + ) + ) + += ( eelem "div" + += sattr "class" "footer" + ) + += ( eelem "div" + += sattr "class" "left sideBar" + += ( eelem "div" + += sattr "class" "content" + += constL leftSideBar + ) + ) + += ( eelem "div" + += sattr "class" "right sideBar" + += ( eelem "div" + += sattr "class" "content" + += constL rightSideBar + ) + ) + ) + ) ) -<< pageNotFound diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs deleted file mode 100644 index bcfd17f..0000000 --- a/Rakka/Resource/Render.hs +++ /dev/null @@ -1,309 +0,0 @@ -module Rakka.Resource.Render - ( fallbackRender - ) - where - -import Control.Arrow -import Control.Arrow.ArrowIO -import Control.Arrow.ArrowIf -import Data.Char -import Network.HTTP.Lucu -import Network.HTTP.Lucu.Utils -import Rakka.Environment -import Rakka.Page -import Rakka.Resource -import Rakka.Storage -import Rakka.SystemConfig -import Rakka.Wiki.Engine -import System.FilePath -import System.Time -import Text.XML.HXT.Arrow.Namespace -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlNodeSet -import Text.XML.HXT.DOM.TypeDefs - - -fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef) -fallbackRender env path - | null path = return Nothing - | null $ head path = return Nothing - | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない - | otherwise - = return $ Just $ ResourceDef { - resUsesNativeThread = False - , resIsGreedy = True - , resGet = Just $ handleGet env (toPageName path) - , resHead = Nothing - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing - } - where - toPageName :: [String] -> PageName - toPageName = decodePageName . dropExtension . joinWith "/" - - -handleGet :: Environment -> PageName -> Resource () -handleGet env name - = runIdempotentA $ proc () - -> do pageM <- getPageA (envStorage env) -< (name, Nothing) - case pageM of - Nothing - -> handlePageNotFound env -< name - - Just redir@(Redirection _ _ _ _) - -> handleRedirect env -< redir - - Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _) - -> handleGetEntity env -< entity - -{- - HTTP/1.1 302 Found - Location: http://example.org/Destination?from=Source --} -handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ()) -handleRedirect env - = proc redir - -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< () - returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME - - -{- - -- デフォルトでない場合のみ存在 - lastModified="2000-01-01T00:00:00"> - - - - - - -