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.)

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
diff --git a/Core.hs b/Core.hs
index 90af62eb6..f04a3dfac 100644
--- a/Core.hs
+++ b/Core.hs
@@ -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]]