X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;h=dbef4d5b1a16615a26cd4271be67afe4084a270c;hb=354a3b69406608a2570060bdbdbc65e83260c8ff;hp=3c00612809ce2910e22abf421b3247d9c372fbe9;hpb=656fdb2772ab4de5cd083cbe9e7c1610cccef73b;p=Rakka.git diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index 3c00612..dbef4d5 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -7,22 +7,27 @@ import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowIf import Control.Arrow.ArrowList +import Control.Monad.Trans import Data.Char import Data.Maybe import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils -import Network.URI +import Network.URI hiding (path) 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 +import Text.XML.HXT.Arrow.Namespace +import Text.XML.HXT.Arrow.WriteDocument import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlIOStateArrow import Text.XML.HXT.Arrow.XmlNodeSet import Text.XML.HXT.DOM.TypeDefs +import Text.XML.HXT.DOM.XmlKeywords fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef) @@ -34,11 +39,11 @@ fallbackPageEntity env path = return $ Just $ ResourceDef { resUsesNativeThread = False , resIsGreedy = True - , resGet = Just $ handleGet env (toPageName path) + , resGet = Just $ handleGet env (toPageName path) , resHead = Nothing , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing + , resPut = Just $ handlePut env (toPageName path) + , resDelete = Just $ handleDelete env (toPageName path) } where toPageName :: [String] -> PageName @@ -50,41 +55,58 @@ handleGet env name = runIdempotentA $ proc () -> do pageM <- getPageA (envStorage env) -< (name, Nothing) case pageM of - Nothing - -> handlePageNotFound env -< name + Nothing -> handlePageNotFound env -< name + Just page -> if isEntity page then + handleGetEntity env -< page + else + handleRedirect env -< page - Just redir@(Redirection _ _ _ _) - -> handleRedirect env -< redir - - Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _) - -> handleGetEntity env -< entity {- HTTP/1.1 302 Found - Location: http://example.org/Destination?from=Source + Location: http://example.org/Destination.html#Redirect: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 + -> returnA -< do mType <- getEntityType + case mType of + MIMEType "application" "xhtml+xml" _ + -> do BaseURI baseURI <- getSysConf (envSysConf env) + let uri = mkPageFragmentURI + baseURI + (redirDest redir) + ("Redirect:" ++ redirName redir) + redirect Found uri + + MIMEType "text" "xml" _ + -> do setContentType mType + [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail + >>> + constA redir + >>> + xmlizePage + >>> + writeDocumentToString [ (a_indent, v_1) ] + ) + output resultStr + + _ -> fail ("internal error: getEntityType returned " ++ show mType) 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 の場合は、内容が動的に生成され + returnA -< do -- text/x-rakka の場合は、内容が動的に生成され -- てゐる可能性があるので、ETag も -- Last-Modified も返す事が出來ない。 - case pageType page of + case entityType page of MIMEType "text" "x-rakka" _ -> return () - _ -> case pageRevision page of - 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ - rev -> foundEntity (strongETag $ show rev) lastMod + _ -> case entityRevision page of + 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ + rev -> foundEntity (strongETag $ show rev) (entityLastMod page) outputXmlPage tree (entityToXHTML env) @@ -95,15 +117,17 @@ entityToXHTML env -> do SiteName siteName <- getSysConfA (envSysConf env) -< () BaseURI baseURI <- getSysConfA (envSysConf env) -< () StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () + GlobalLock isGLocked <- getSysConfA (envSysConf env) -< () - pageName <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page + name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page + isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< 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") + pageTitle <- listA (readSubPage env) -< (name, Just page, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right") pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page ( eelem "/" @@ -133,6 +157,12 @@ entityToXHTML env += sattr "type" "text/javascript" += attr "src" (arr id >>> mkText) ) + += ( eelem "script" + += sattr "type" "text/javascript" + += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";") + += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";") + += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") + ) ) += ( eelem "body" += ( eelem "div" @@ -167,6 +197,8 @@ entityToXHTML env ) ) ) + >>> + uniqueNamespacesFromDeclAndQNames ) ) -<< page @@ -202,15 +234,16 @@ notFoundToXHTML env -> do SiteName siteName <- getSysConfA (envSysConf env) -< () BaseURI baseURI <- getSysConfA (envSysConf env) -< () StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () + GlobalLock isGLocked <- getSysConfA (envSysConf env) -< () - pageName <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound + name <- (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") + pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right") ( eelem "/" += ( eelem "html" @@ -234,6 +267,11 @@ notFoundToXHTML env += sattr "type" "text/javascript" += attr "src" (arr id >>> mkText) ) + += ( eelem "script" + += sattr "type" "text/javascript" + += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") + += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") + ) ) += ( eelem "body" += ( eelem "div" @@ -268,4 +306,22 @@ notFoundToXHTML env ) ) ) + >>> + uniqueNamespacesFromDeclAndQNames ) ) -<< pageNotFound + + +handlePut :: Environment -> PageName -> Resource () +handlePut env name + = do userID <- getUserID env + runXmlA env "rakka-page-1.0.rng" $ proc tree + -> do page <- parseXmlizedPage -< (name, tree) + status <- putPageA (envStorage env) -< (userID, page) + returnA -< setStatus status + + +handleDelete :: Environment -> PageName -> Resource () +handleDelete env name + = do userID <- getUserID env + status <- deletePage (envStorage env) userID name + setStatus status