X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FRepos.hs;h=8664d2480d5b62252b5930e43dbee309a21fe204;hb=a4b849476ee3a204ea91dee8f3fd235b0b33a10a;hp=b74f48cb36bb862c92399bb595fd38557996813b;hpb=f1016753ef45a4c25745ccb6e81e5acbc085cc42;p=Rakka.git diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs index b74f48c..8664d24 100644 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@ -11,7 +11,6 @@ module Rakka.Storage.Repos where import Codec.Binary.UTF8.String -import Control.Exception import Control.Monad import Data.List import qualified Data.Map as M @@ -25,7 +24,6 @@ import Rakka.Page import Rakka.SystemConfig import Rakka.Utils import Rakka.W3CDateTime -import Subversion.Error import Subversion.FileSystem import Subversion.FileSystem.DirEntry import Subversion.FileSystem.Revision @@ -71,7 +69,7 @@ findAllPagesInRevision repos rev traverse :: FilePath -> Rev (Set PageName) traverse dir - = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions + = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir)) traverse' :: FilePath -> DirEntry -> Rev (Set PageName) traverse' dir entry @@ -104,7 +102,7 @@ getDirContentsInRevision repos dir rev path = mkDirPath dir getDir' :: Rev [PageName] - getDir' = getDirEntries path >>= return . map entToName + getDir' = liftM (map entToName) (getDirEntries path) entToName :: DirEntry -> PageName entToName = (dir ) . decodePageName . dropExtension . entName @@ -114,7 +112,7 @@ findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName) findChangedPagesAtRevision repos rev = do fs <- getRepositoryFS repos withRevision fs rev - $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst + $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged where accumulatePages :: Set PageName -> FilePath -> Set PageName accumulatePages s path @@ -136,23 +134,24 @@ loadPageInRepository repos name rev withRevision fs rev' $ do exists <- isFile path if exists then - return . Just =<< loadPage' + return . Just =<< loadPage' fs else return Nothing where path :: FilePath path = mkPagePath name - loadPage' :: Rev Page - loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type") - case mType of - Just (MIMEType "application" "x-rakka-redirection" _) - -> loadPageRedirect - _ - -> loadPageEntity - - loadPageEntity :: Rev Page - loadPageEntity + loadPage' :: FileSystem -> Rev Page + loadPage' fs + = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type") + case mType of + Just (MIMEType "application" "x-rakka-redirection" _) + -> loadPageRedirect fs + _ + -> loadPageEntity fs + + loadPageEntity :: FileSystem -> Rev Page + loadPageEntity fs = do props <- getNodePropList path hist <- getNodeHistory True path content <- getFileContentsLBS path @@ -162,8 +161,9 @@ loadPageInRepository repos name rev $ fromMaybe "text/x-rakka" $ fmap chomp (lookup "svn:mime-type" props) - lastMod <- getRevisionProp "svn:date" - >>= return . fromJust . parseW3CDateTime . chomp . fromJust + lastMod <- unsafeIOToFS $ + liftM (fromJust . parseW3CDateTime . chomp . fromJust) + (getRevisionProp' fs pageRev "svn:date") return Entity { entityName = name @@ -188,19 +188,19 @@ loadPageInRepository repos name rev , entityUpdateInfo = undefined } - loadPageRedirect :: Rev Page - loadPageRedirect + loadPageRedirect :: FileSystem -> Rev Page + loadPageRedirect fs = do hist <- getNodeHistory True path content <- getFileContents path let pageRev = fst $ head hist dest = chomp $ decodeString content - lastMod <- getRevisionProp "svn:date" - >>= return . fromJust . parseW3CDateTime . chomp . fromJust + lastMod <- unsafeIOToFS $ + liftM (fromJust . parseW3CDateTime . chomp . fromJust) + (getRevisionProp' fs pageRev "svn:date") - isLocked <- getRevisionProp "rakka:isLocked" - >>= return . isJust + isLocked <- liftM isJust (getNodeProp path "rakka:isLocked") return Redirection { redirName = name @@ -214,8 +214,7 @@ loadPageInRepository repos name rev putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode putPageIntoRepository repos userID page - = filterSvnError $ - do let name = pageName page + = do let name = pageName page author = fromMaybe "[Rakka]" userID case pageUpdateInfo page of Just ui @@ -226,16 +225,25 @@ putPageIntoRepository repos userID page if denied then return Forbidden else - do ret <- doReposTxn + do rev <- if oldRev == 0 then + getRepositoryFS repos >>= getYoungestRev + else + return oldRev + ret <- doReposTxn repos - (uiOldRevision ui) + rev author (Just "Automatic commit by Rakka for page update") - $ do case uiOldName ui of + $ do + case uiOldName ui of Nothing -> return () - Just oldName -> movePage (uiOldRevision ui) oldName name - >> - moveAttachments (uiOldRevision ui) oldName name + Just oldName -> do exists <- isFile (mkPagePath oldName) + when exists + $ do movePage (uiOldRevision ui) oldName name + moveAttachments (uiOldRevision ui) oldName name + exists <- isFile (mkPagePath name) + unless exists + $ createPage name updatePage name case ret of Left _ -> return Conflict @@ -258,10 +266,14 @@ putPageIntoRepository repos userID page checkDenial rev name = do fs <- getRepositoryFS repos withRevision fs rev - $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked" - case prop of - Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目 - Nothing -> return False + $ do exists <- isFile (mkPagePath name) + if exists then + do prop <- getNodeProp (mkPagePath name) "rakka:isLocked" + case prop of + Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目 + Nothing -> return False + else + return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの… movePage :: RevNum -> PageName -> PageName -> Txn () movePage oldRev oldName newName @@ -342,8 +354,7 @@ createParentDirectories path deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode deletePageFromRepository repos userID name - = filterSvnError $ - do let pagePath = mkPagePath name + = do let pagePath = mkPagePath name attachmentPath = mkAttachmentDirPath name fs <- getRepositoryFS repos rev <- getYoungestRev fs @@ -409,7 +420,7 @@ loadAttachmentInRepository repos pName aName rev path = mkAttachmentPath pName aName loadAttachment' :: Rev a - loadAttachment' = getFileContents path >>= return . deserializeFromString . decodeString + loadAttachment' = liftM (deserializeFromString . decodeString) (getFileContents path) putAttachmentIntoRepository :: Attachment a => @@ -421,8 +432,7 @@ putAttachmentIntoRepository :: Attachment a => -> a -> IO StatusCode putAttachmentIntoRepository repos userID oldRev pName aName attachment - = filterSvnError $ - do let author = fromMaybe "[Rakka]" userID + = do let author = fromMaybe "[Rakka]" userID path = mkAttachmentPath pName aName fs <- getRepositoryFS repos oldRev' <- case oldRev of @@ -441,14 +451,3 @@ putAttachmentIntoRepository repos userID oldRev pName aName attachment case ret of Left _ -> return Conflict Right _ -> return NoContent - - -filterSvnError :: IO a -> IO a -filterSvnError f = catchDyn f rethrow - where - rethrow :: SvnError -> IO a - rethrow err - = let code = svnErrCode err - msg = svnErrMsg err - in - fail $ "SvnError: " ++ (show code) ++ ": " ++ msg