Update working tree files fully atomically

This avoids commit churn by the assistant when eg,
replacing a file with a symlink.

But, just as importantly, it prevents the working tree being left with a
deleted file if git-annex, or perhaps the whole system, crashes at the
wrong time.

(It also probably avoids confusing displays in file managers.)

Annex/Content.hs

@@ -49,6 +49,7 @@ import Config
 import Annex.Exception
 import Git.SharedRepository
 import Annex.Perms
+import Annex.Link
 import Annex.Content.Direct
 import Backend
 
@@ -256,20 +257,33 @@ moveAnnex key src = withObjectLoc key storeobject storedirect
 		updateInodeCache key src
 		thawContent src
 		replaceFile dest $ liftIO . moveFile src
+		{- Copy to any other locations. -}
 		forM_ fs $ \f -> replaceFile f $
-			void . liftIO . copyFileExternal dest
+			liftIO . void . copyFileExternal dest
 
-{- Replaces any existing file with a new version, by running an action.
+{- Replaces a possibly already existing file with a new version, 
- - First, makes sure the file is deleted. Or, if it didn't already exist,
+ - atomically, by running an action.
- - makes sure the parent directory exists. -}
+
+ - The action is passed a temp file, which it can write to, and once
+ - done the temp file is moved into place.
+ -}
 replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex ()
 replaceFile file a = do
+	tmpdir <- fromRepo gitAnnexTmpDir
+	createAnnexDirectory tmpdir
+	tmpfile <- liftIO $ do
+		(tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir $
+			takeFileName file
+		hClose h
+		return tmpfile
+	a tmpfile
 	liftIO $ do
-		r <- tryIO $ removeFile file
+		r <- tryIO $ rename tmpfile file
 		case r of
-			Left _ -> createDirectoryIfMissing True $ parentDir file
+			Left _ -> do
+				createDirectoryIfMissing True $ parentDir file
+				rename tmpfile file
 			_ -> noop
-	a file
 
 {- Runs an action to transfer an object's content.
  -
@@ -366,8 +380,7 @@ removeAnnex key = withObjectLoc key remove removedirect
 		cwd <- liftIO getCurrentDirectory
 		let top' = fromMaybe top $ absNormPath cwd top
 		let l' = relPathDirToFile top' (fromMaybe l $ absNormPath top' l)
-		replaceFile f $ const $
+		replaceFile f $ makeAnnexLink l'
-			makeAnnexLink l' f
 
 {- Moves a key's file out of .git/annex/objects/ -}
 fromAnnex :: Key -> FilePath -> Annex ()

Annex/Direct.hs

@@ -153,8 +153,7 @@ mergeDirectCleanup d oldsha newsha = do
  	 - Symlinks are replaced with their content, if it's available. -}
 	movein k f = do
 		l <- calcGitLink f k
-		replaceFile f $
+		replaceFile f $ makeAnnexLink l
-			makeAnnexLink l
 		toDirect k f
 	
 	{- Any new, modified, or renamed files were written to the temp
@@ -179,15 +178,14 @@ toDirectGen k f = do
 				{- Move content from annex to direct file. -}
 				updateInodeCache k loc
 				thawContent loc
-				replaceFile f $
+				replaceFile f $ liftIO . moveFile loc
-					liftIO . moveFile loc
 			, return Nothing
 			)
 		(loc':_) -> ifM (isNothing <$> getAnnexLinkTarget loc')
 			{- Another direct file has the content; copy it. -}
 			( return $ Just $
 				replaceFile f $
-					void . liftIO . copyFileExternal loc'
+					liftIO . void . copyFileExternal loc'
 			, return Nothing
 			)
 

Annex/Link.hs

@@ -60,7 +60,9 @@ getAnnexLinkTarget file = do
  -}
 makeAnnexLink :: LinkTarget -> FilePath -> Annex ()
 makeAnnexLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
-	( liftIO $ createSymbolicLink linktarget file
+	( liftIO $ do
+		void $ tryIO $ removeFile file
+		createSymbolicLink linktarget file
 	, liftIO $ writeFile file linktarget
 	)
 

Assistant/Threads/Watcher.hs

@@ -222,9 +222,9 @@ onAddSymlink isdirect file filestatus = go =<< liftAnnex (Backend.lookupFile fil
 		ifM ((==) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file))
 			( ensurestaged (Just link) (Just key) =<< getDaemonStatus
 			, do
-				unless isdirect $ do
+				unless isdirect $
-					liftIO $ removeFile file
+					liftAnnex $ replaceFile file $
-					liftAnnex $ Backend.makeAnnexLink link file
+						makeAnnexLink link
 				addLink file link (Just key)
 			)
 	go Nothing = do -- other symlink

Backend.hs

@@ -11,7 +11,6 @@ module Backend (
 	genKey,
 	lookupFile,
 	isAnnexLink,
-	makeAnnexLink,
 	chooseBackend,
 	lookupBackendName,
 	maybeLookupBackendName

Command/Add.hs

@@ -175,7 +175,7 @@ undo file key e = do
 link :: FilePath -> Key -> Bool -> Annex String
 link file key hascontent = handle (undo file key) $ do
 	l <- calcGitLink file key
-	makeAnnexLink l file
+	replaceFile file $ makeAnnexLink l
 
 #ifndef __ANDROID__
 	when hascontent $ do

Locations.hs

@@ -148,7 +148,7 @@ gitAnnexObjectDir r = addTrailingPathSeparator $ Git.localGitDir r </> objectDir
 gitAnnexTmpDir :: Git.Repo -> FilePath
 gitAnnexTmpDir r = addTrailingPathSeparator $ gitAnnexDir r </> "tmp"
 
-{- The temp file to use for a given key. -}
+{- The temp file to use for a given key's content. -}
 gitAnnexTmpLocation :: Key -> Git.Repo -> FilePath
 gitAnnexTmpLocation key r = gitAnnexTmpDir r </> keyFile key
 

debian/changelog

@@ -26,6 +26,7 @@ git-annex (4.20130324) UNRELEASED; urgency=low
     repositories.
   * assistant: Fix bug that could cause direct mode files to be unstaged
     from git.
+  * Update working tree files fully atomically.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 25 Mar 2013 10:21:46 -0400