improve robustness of fromDirect and replaceFile

Made fromDirect check that a file in the tree has good content (and is not
a broken symlink either) before copying it to another file that has the
same key.

Made replaceFile clean up the temp file if the action that creates it, or
the file replacement action fails.

1 files changed, 15 insertions, 10 deletions

diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs
index f0dfa5b27..93f807978 100644
--- a/Annex/ReplaceFile.hs
+++ b/Annex/ReplaceFile.hs
@@ -9,27 +9,32 @@ module Annex.ReplaceFile where
 
 import Common.Annex
 import Annex.Perms
+import Annex.Exception
 
 {- Replaces a possibly already existing file with a new version, 
  - atomically, by running an action.
  - 
  - The action is passed a temp file, which it can write to, and once
  - done the temp file is moved into place.
+ -
+ - The action can throw an IO exception, in which case the temp file
+ - will be deleted, and the existing file will be preserved.
+ -
+ - Throws an IO exception when it was unable to replace the file.
  -}
 replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex ()
 replaceFile file a = do
 	tmpdir <- fromRepo gitAnnexTmpDir
-	createAnnexDirectory tmpdir
-	tmpfile <- liftIO $ do
+	void $ createAnnexDirectory tmpdir
+	bracketIO (setup tmpdir) nukeFile $ \tmpfile -> do
+		a tmpfile
+		liftIO $ catchIO (rename tmpfile file) (fallback tmpfile)
+  where
+  	setup tmpdir = do
 		(tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir $
 			takeFileName file
 		hClose h
 		return tmpfile
-	a tmpfile
-	liftIO $ do
-		r <- tryIO $ rename tmpfile file
-		case r of
-			Left _ -> do
-				createDirectoryIfMissing True $ parentDir file
-				rename tmpfile file
-			_ -> noop
+	fallback tmpfile _ = do
+		createDirectoryIfMissing True $ parentDir file
+		rename tmpfile file