X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FRepos.hs;h=1c5ef08abca28079845c0802dd34170d1551e624;hb=9a1da61204cdcf932d8260c87c69bd8fa1992533;hp=e1f4b8e24049cab6d564666974328d948f1f4bf4;hpb=0447be1b59496ca4266226ed52d264009cf41899;p=Rakka.git diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs index e1f4b8e..1c5ef08 100644 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@ -1,9 +1,12 @@ module Rakka.Storage.Repos ( findAllPagesInRevision + , getDirContentsInRevision , findChangedPagesAtRevision , loadPageInRepository , putPageIntoRepository , deletePageFromRepository + , loadAttachmentInRepository + , putAttachmentIntoRepository ) where @@ -17,6 +20,7 @@ import Data.Set (Set) import qualified Data.Set as S hiding (Set) import Data.Time import Network.HTTP.Lucu hiding (redirect) +import Rakka.Attachment import Rakka.Page import Rakka.SystemConfig import Rakka.Utils @@ -37,6 +41,21 @@ mkPagePath name = "/pages" encodePageName name <.> "page" +mkDirPath :: PageName -> FilePath +mkDirPath dir + = "/pages" encodePageName dir + + +mkAttachmentPath :: PageName -> String -> FilePath +mkAttachmentPath pName aName + = "/attachments" encodePageName pName <.> "page" aName + + +mkAttachmentDirPath :: PageName -> FilePath +mkAttachmentDirPath pName + = "/attachments" encodePageName pName <.> "page" + + findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName) findAllPagesInRevision repos rev = do fs <- getRepositoryFS repos @@ -68,6 +87,29 @@ findAllPagesInRevision repos rev decodePath = decodePageName . makeRelative root . dropExtension +getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName) +getDirContentsInRevision repos dir rev + = do fs <- getRepositoryFS repos + rev' <- case rev of + Nothing -> getYoungestRev fs + Just r -> return r + withRevision fs rev' + $ do exists <- isDirectory path + if exists then + return . S.fromList =<< getDir' + else + return S.empty + where + path :: FilePath + path = mkDirPath dir + + getDir' :: Rev [PageName] + getDir' = getDirEntries path >>= return . map entToName + + entToName :: DirEntry -> PageName + entToName = (dir ) . decodePageName . dropExtension . entName + + findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName) findChangedPagesAtRevision repos rev = do fs <- getRepositoryFS repos @@ -93,25 +135,25 @@ loadPageInRepository repos name rev Just r -> return r withRevision fs rev' $ do exists <- isFile path - case exists of - True - -> return . Just =<< loadPage' - False - -> return Nothing + if exists then + 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 @@ -121,7 +163,8 @@ loadPageInRepository repos name rev $ fromMaybe "text/x-rakka" $ fmap chomp (lookup "svn:mime-type" props) - lastMod <- getRevisionProp "svn:date" + lastMod <- unsafeIOToFS $ + getRevisionProp' fs pageRev "svn:date" >>= return . fromJust . parseW3CDateTime . chomp . fromJust return Entity { @@ -138,27 +181,28 @@ loadPageInRepository repos name rev -> True , entityRevision = pageRev , entityLastMod = zonedTimeToUTC lastMod - , entitySummary = lookup "rakka:summary" props + , entitySummary = fmap decodeString (lookup "rakka:summary" props) , entityOtherLang = fromMaybe M.empty $ fmap - (M.fromList . fromJust . deserializeStringPairs) + (M.fromList . fromJust . deserializeStringPairs . decodeString) (lookup "rakka:otherLang" props) , entityContent = content , 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" + lastMod <- unsafeIOToFS $ + getRevisionProp' fs pageRev "svn:date" >>= return . fromJust . parseW3CDateTime . chomp . fromJust - isLocked <- getRevisionProp "rakka:isLocked" + isLocked <- getNodeProp path "rakka:isLocked" >>= return . isJust return Redirection { @@ -185,14 +229,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 -> renamePage (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 @@ -215,13 +270,17 @@ 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 屬性をどうのこうの… - renamePage :: RevNum -> PageName -> PageName -> Txn () - renamePage oldRev oldName newName + movePage :: RevNum -> PageName -> PageName -> Txn () + movePage oldRev oldName newName = do let oldPath = mkPagePath oldName newPath = mkPagePath newName createParentDirectories newPath @@ -229,6 +288,15 @@ putPageIntoRepository repos userID page deleteEntry oldPath deleteEmptyParentDirectories oldPath + moveAttachments :: RevNum -> PageName -> PageName -> Txn () + moveAttachments oldRev oldName newName + = do let oldPath = mkAttachmentDirPath oldName + newPath = mkAttachmentDirPath newName + createParentDirectories newPath + copyEntry oldRev oldPath newPath + deleteEntry oldPath + deleteEmptyParentDirectories oldPath + createPage :: PageName -> Txn () createPage name = do let path = mkPagePath name @@ -263,13 +331,13 @@ putPageIntoRepository repos userID page setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page) setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page) setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page) - setNodeProp path "rakka:summary" (entitySummary page) + setNodeProp path "rakka:summary" (fmap encodeString $ entitySummary page) setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page in if M.null otherLang then Nothing else - Just (serializeStringPairs $ M.toList otherLang)) + Just (encodeString $ serializeStringPairs $ M.toList otherLang)) applyTextLBS path Nothing (entityContent page) encodeFlag :: Bool -> Maybe String @@ -291,13 +359,14 @@ createParentDirectories path deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode deletePageFromRepository repos userID name = filterSvnError $ - do let path = mkPagePath name + do let pagePath = mkPagePath name + attachmentPath = mkAttachmentDirPath name fs <- getRepositoryFS repos rev <- getYoungestRev fs status <- withRevision fs rev - $ do exists <- isFile path + $ do exists <- isFile pagePath if exists then - do prop <- getNodeProp path "rakka:isLocked" + do prop <- getNodeProp pagePath "rakka:isLocked" return $ case prop of Just _ -> if isNothing userID then @@ -314,8 +383,13 @@ deletePageFromRepository repos userID name rev "[Rakka]" (Just "Automatic commit by Rakka for page deleting") - $ do deleteEntry path - deleteEmptyParentDirectories path + $ do deleteEntry pagePath + deleteEmptyParentDirectories pagePath + + attachmentExists <- isDirectory attachmentPath + when attachmentExists + $ do deleteEntry attachmentPath + deleteEmptyParentDirectories attachmentPath return () return status @@ -329,6 +403,62 @@ deleteEmptyParentDirectories path deleteEmptyParentDirectories parentPath +loadAttachmentInRepository :: forall a. Attachment a => + Repository + -> PageName + -> String + -> Maybe RevNum + -> IO (Maybe a) +loadAttachmentInRepository repos pName aName rev + = do fs <- getRepositoryFS repos + rev' <- case rev of + Nothing -> getYoungestRev fs + Just r -> return r + withRevision fs rev' + $ do exists <- isFile path + if exists then + return . Just =<< loadAttachment' + else + return Nothing + where + path :: FilePath + path = mkAttachmentPath pName aName + + loadAttachment' :: Rev a + loadAttachment' = getFileContents path >>= return . deserializeFromString . decodeString + + +putAttachmentIntoRepository :: Attachment a => + Repository + -> Maybe String + -> Maybe RevNum + -> PageName + -> String + -> a + -> IO StatusCode +putAttachmentIntoRepository repos userID oldRev pName aName attachment + = filterSvnError $ + do let author = fromMaybe "[Rakka]" userID + path = mkAttachmentPath pName aName + fs <- getRepositoryFS repos + oldRev' <- case oldRev of + Nothing -> getYoungestRev fs + Just r -> return r + ret <- doReposTxn + repos + oldRev' + author + (Just "Automatic commit by Rakka for putting attachment") + $ do exists <- isFile path + unless exists + $ do createParentDirectories path + makeFile path + applyText path Nothing (serializeToString attachment) + case ret of + Left _ -> return Conflict + Right _ -> return NoContent + + filterSvnError :: IO a -> IO a filterSvnError f = catchDyn f rethrow where