diff options
| -rw-r--r-- | Command/Add.hs | 9 | ||||
| -rw-r--r-- | Command/Drop.hs | 17 | ||||
| -rw-r--r-- | Command/DropKey.hs | 8 | ||||
| -rw-r--r-- | Command/SetKey.hs | 22 | ||||
| -rw-r--r-- | Command/Unannex.hs | 9 | ||||
| -rw-r--r-- | Core.hs | 53 | ||||
| -rw-r--r-- | debian/changelog | 3 | ||||
| -rw-r--r-- | doc/todo/immutable_annexed_files.mdwn | 2 |
8 files changed, 74 insertions, 49 deletions
diff --git a/Command/Add.hs b/Command/Add.hs index 3cc681f69..6c5d24f84 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -9,12 +9,9 @@ module Command.Add where import Control.Monad.State (liftIO) import System.Posix.Files -import System.Directory import Command import qualified Annex -import Utility -import Locations import qualified Backend import LocationLog import Types @@ -42,11 +39,9 @@ perform (file, backend) = do cleanup :: FilePath -> Key -> SubCmdCleanup cleanup file key = do + moveAnnex key file logStatus key ValuePresent - g <- Annex.gitRepo - let dest = annexLocation g key - liftIO $ createDirectoryIfMissing True (parentDir dest) - liftIO $ renameFile file dest + link <- calcGitLink file key liftIO $ createSymbolicLink link file Annex.queue "add" [] file diff --git a/Command/Drop.hs b/Command/Drop.hs index d1ebd7f64..48433b14c 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -7,12 +7,9 @@ module Command.Drop where -import Control.Monad.State (liftIO) -import System.Directory +import Control.Monad (when) import Command -import qualified Annex -import Locations import qualified Backend import LocationLog import Types @@ -39,13 +36,7 @@ perform key backend = do cleanup :: Key -> SubCmdCleanup cleanup key = do - logStatus key ValueMissing inannex <- inAnnex key - if (inannex) - then do - g <- Annex.gitRepo - let loc = annexLocation g key - liftIO $ removeFile loc - return True - else return True - + when (inannex) $ removeAnnex key + logStatus key ValueMissing + return True diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 8076e6fd3..e0b20918c 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -7,12 +7,8 @@ module Command.DropKey where -import Control.Monad.State (liftIO) -import System.Directory - import Command import qualified Annex -import Locations import qualified Backend import LocationLog import Types @@ -36,9 +32,7 @@ start keyname = do perform :: Key -> SubCmdPerform perform key = do - g <- Annex.gitRepo - let loc = annexLocation g key - liftIO $ removeFile loc + removeAnnex key return $ Just $ cleanup key cleanup :: Key -> SubCmdCleanup diff --git a/Command/SetKey.hs b/Command/SetKey.hs index 9286e740b..50e9a590b 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -13,7 +13,6 @@ import Control.Monad (when) import Command import qualified Annex import Utility -import Locations import qualified Backend import LocationLog import Types @@ -22,21 +21,22 @@ import Messages {- Sets cached content for a key. -} start :: SubCmdStartString -start tmpfile = do +start file = do keyname <- Annex.flagGet "key" when (null keyname) $ error "please specify the key with --key" backends <- Backend.list let key = genKey (backends !! 0) keyname - showStart "setkey" tmpfile - return $ Just $ perform tmpfile key + showStart "setkey" file + return $ Just $ perform file key perform :: FilePath -> Key -> SubCmdPerform -perform tmpfile key = do - g <- Annex.gitRepo - let loc = annexLocation g key - ok <- liftIO $ boolSystem "mv" [tmpfile, loc] - if (not ok) - then error "mv failed!" - else return $ Just $ cleanup key +perform file key = do + -- the file might be on a different filesystem, so mv is used + -- rather than simply calling moveToObjectDir key file + ok <- getViaTmp key $ \dest -> liftIO $ boolSystem "mv" [file, dest] + if ok + then return $ Just $ cleanup key + else error "mv failed!" + cleanup :: Key -> SubCmdCleanup cleanup key = do logStatus key ValuePresent diff --git a/Command/Unannex.hs b/Command/Unannex.hs index e0848cd4a..a9c18f765 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -13,7 +13,6 @@ import System.Directory import Command import qualified Annex import Utility -import Locations import qualified Backend import LocationLog import Types @@ -38,12 +37,14 @@ perform file key backend = do cleanup :: FilePath -> Key -> SubCmdCleanup cleanup file key = do - logStatus key ValueMissing g <- Annex.gitRepo - let src = annexLocation g key + liftIO $ removeFile file liftIO $ Git.run g ["rm", "--quiet", file] -- git rm deletes empty directories; put them back liftIO $ createDirectoryIfMissing True (parentDir file) - liftIO $ renameFile src file + + fromAnnex key file + logStatus key ValueMissing + return True @@ -144,7 +144,7 @@ getViaTmp key action = do success <- action tmp if (success) then do - moveToObjectDir key tmp + moveAnnex key tmp logStatus key ValuePresent return True else do @@ -152,14 +152,53 @@ getViaTmp key action = do -- to resume its transfer return False +{- Removes the write bits from a file. -} +preventWrite :: FilePath -> IO () +preventWrite f = unsetFileMode f writebits + where + writebits = foldl unionFileModes ownerWriteMode + [groupWriteMode, otherWriteMode] + +{- Turns a file's write bit back on. -} +allowWrite :: FilePath -> IO () +allowWrite f = do + s <- getFileStatus f + setFileMode f $ (fileMode s) `unionFileModes` ownerWriteMode + {- Moves a file into .git/annex/objects/ -} -moveToObjectDir :: Key -> FilePath -> Annex () -moveToObjectDir key src = do +moveAnnex :: Key -> FilePath -> Annex () +moveAnnex key src = do g <- Annex.gitRepo let dest = annexLocation g key - liftIO $ createDirectoryIfMissing True (parentDir dest) - liftIO $ renameFile src dest - -- TODO directory and file mode tweaks + let dir = parentDir dest + liftIO $ do + createDirectoryIfMissing True dir + renameFile src dest + preventWrite dest + preventWrite dir + +{- Removes a key's file from .git/annex/objects/ -} +removeAnnex :: Key -> Annex () +removeAnnex key = do + g <- Annex.gitRepo + let file = annexLocation g key + let dir = parentDir file + liftIO $ do + allowWrite dir + removeFile file + removeDirectory dir + +{- Moves a key's file out of .git/annex/objects/ -} +fromAnnex :: Key -> FilePath -> Annex () +fromAnnex key dest = do + g <- Annex.gitRepo + let file = annexLocation g key + let dir = parentDir file + liftIO $ do + allowWrite dir + allowWrite file + renameFile file dest + removeDirectory dir {- List of keys whose content exists in .git/annex/objects/ -} getKeysPresent :: Annex [Key] @@ -202,7 +241,7 @@ upgradeFrom0 = do -- do the reorganisation of the files let olddir = annexDir g keys <- getKeysPresent' olddir - _ <- mapM (\k -> moveToObjectDir k $ olddir ++ "/" ++ keyFile k) keys + _ <- mapM (\k -> moveAnnex k $ olddir ++ "/" ++ keyFile k) keys -- update the symlinks to the files files <- liftIO $ Git.inRepo g $ Git.workTree g diff --git a/debian/changelog b/debian/changelog index dc9dcedc2..1ce6a2deb 100644 --- a/debian/changelog +++ b/debian/changelog @@ -8,6 +8,9 @@ git-annex (0.04) UNRELEASED; urgency=low git-annex is used in a repository with the old layout. * Note that git-annex 0.04 cannot transfer content from old repositories that have not yet been upgraded. + * Annexed file contents are now made unwritable and put in unwriteable + directories, to avoid them accidentially being removed or modified. + (Thanks Josh Triplett for the idea.) -- Joey Hess <joeyh@debian.org> Mon, 08 Nov 2010 12:36:39 -0400 diff --git a/doc/todo/immutable_annexed_files.mdwn b/doc/todo/immutable_annexed_files.mdwn index e5207dc16..b26838e95 100644 --- a/doc/todo/immutable_annexed_files.mdwn +++ b/doc/todo/immutable_annexed_files.mdwn @@ -4,3 +4,5 @@ > josh: Oh, I just thought of another slightly crazy but handy idea. > josh: I'd hate to run into a program which somehow followed the symlink and then did an unlink to replace the file. > josh: To break that, you could create a new directory under annex's internal directory for each file, and make the directory have no write permission. + +[[done]] and done --[[Joey]] |