add: Be even more robust to avoid ever leaving the file seemingly deleted.

A failure at any point after the file is annexed will result in an undo
that puts the original file back into place and wipes the location log.

2 files changed, 40 insertions, 10 deletions

diff --git a/Command/Add.hs b/Command/Add.hs
index e7d16b6c0..5c7cad044 100644
--- a/Command/Add.hs
+++ b/Command/Add.hs
@@ -9,6 +9,10 @@ module Command.Add where
 
 import Control.Monad.State (liftIO)
 import System.Posix.Files
+import System.Directory
+import Control.Exception.Control (handle)
+import Control.Exception.Base (throwIO)
+import Control.Exception.Extensible (IOException)
 
 import Command
 import qualified Annex
@@ -20,6 +24,7 @@ import Content
 import Messages
 import Utility
 import Touch
+import Locations
 
 command :: [Command]
 command = [repoCommand "add" paramPath seek "add files to annex"]
@@ -46,20 +51,39 @@ perform (file, backend) = do
 	case k of
 		Nothing -> stop
 		Just (key, _) -> do
-			moveAnnex key file
+			handle (undo file key) $ moveAnnex key file
 			next $ cleanup file key
 
-cleanup :: FilePath -> Key -> CommandCleanup
-cleanup file key = do
-	link <- calcGitLink file key
-	liftIO $ createSymbolicLink link file
+{- On error, put the file back so it doesn't seem to have vanished.
+ - This can be called before or after the symlink is in place. -}
+undo :: FilePath -> Key -> IOException -> Annex a
+undo file key e = do
+	unlessM (inAnnex key) $ rethrow -- no cleanup to do
+	liftIO $ whenM (doesFileExist file) $ do removeFile file
+	handle tryharder $ fromAnnex key file
+	logStatus key InfoMissing
+	rethrow
+	where
+		rethrow = liftIO $ throwIO e
 
-	logStatus key InfoPresent
+		-- fromAnnex could fail if the file ownership is weird
+		tryharder :: IOException -> Annex ()
+		tryharder _ = do
+			g <- Annex.gitRepo
+			liftIO $ renameFile (gitAnnexLocation g key) file
 
-	-- touch the symlink to have the same mtime as the file it points to
-	s <- liftIO $ getFileStatus file
-	let mtime = modificationTime s
-	liftIO $ touch file (TimeSpec mtime) False
+cleanup :: FilePath -> Key -> CommandCleanup
+cleanup file key = do
+	handle (undo file key) $ do
+		link <- calcGitLink file key
+		liftIO $ createSymbolicLink link file
+		logStatus key InfoPresent
+	
+		-- touch the symlink to have the same mtime as the
+		-- file it points to
+		s <- liftIO $ getFileStatus file
+		let mtime = modificationTime s
+		liftIO $ touch file (TimeSpec mtime) False
 
 	force <- Annex.getState Annex.force
 	if force
diff --git a/debian/changelog b/debian/changelog
index 626e38837..80fe84256 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+git-annex (3.20110708) UNRELEASED; urgency=low
+
+  * add: Be even more robust to avoid ever leaving the file seemingly deleted.
+
+ -- Joey Hess <joeyh@debian.org>  Thu, 07 Jul 2011 21:28:49 -0400
+
 git-annex (3.20110707) unstable; urgency=low
 
   * Fix sign bug in disk free space checking.