Merge branch 'robustness'

Annex/Content.hs

@@ -115,7 +115,7 @@ lockContent key a = do
 	a
 #else
 	file <- calcRepo $ gitAnnexLocation key
-	bracketIO (openforlock file >>= lock) unlock a
+	bracketIO (openforlock file >>= lock) unlock (const a)
   where
 	{- Since files are stored with the write bit disabled, have
 	 - to fiddle with permissions to open for an exclusive lock. -}

Annex/Content/Direct.hs

@@ -193,7 +193,7 @@ compareInodeCachesWith :: Annex InodeComparisonType
 compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
 
 {- Copies the contentfile to the associated file, if the associated
- - file has not content. If the associated file does have content,
+ - file has no content. If the associated file does have content,
  - even if the content differs, it's left unchanged. -}
 addContentWhenNotPresent :: Key -> FilePath -> FilePath -> Annex ()
 addContentWhenNotPresent key contentfile associatedfile = do

Annex/Direct.hs

@@ -27,6 +27,7 @@ import Utility.InodeCache
 import Utility.CopyFile
 import Annex.Perms
 import Annex.ReplaceFile
+import Annex.Exception
 
 {- Uses git ls-files to find files that need to be committed, and stages
  - them into the index. Returns True if some changes were staged. -}
@@ -139,8 +140,10 @@ mergeDirectCleanup d oldsha newsha = do
 	liftIO $ removeDirectoryRecursive d
   where
 	updated item = do
-		go DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
-		go DiffTree.dstsha DiffTree.dstmode movein movein_raw
+		void $ tryAnnex $
+			go DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
+		void $ tryAnnex $ 
+			go DiffTree.dstsha DiffTree.dstmode movein movein_raw
 	  where
 		go getsha getmode a araw
 			| getsha item == nullSha = noop
@@ -173,7 +176,8 @@ mergeDirectCleanup d oldsha newsha = do
 		void $ tryIO $ rename (d </> f) f
 
 {- If possible, converts a symlink in the working tree into a direct
- - mode file. -}
+ - mode file. If the content is not available, leaves the symlink
+ - unchanged. -}
 toDirect :: Key -> FilePath -> Annex ()
 toDirect k f = fromMaybe noop =<< toDirectGen k f
 
@@ -181,28 +185,30 @@ toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ()))
 toDirectGen k f = do
 	loc <- calcRepo $ gitAnnexLocation k
 	ifM (liftIO $ doesFileExist loc)
-		( fromindirect loc
-		, fromdirect
+		( return $ Just $ fromindirect loc
+		, do
+			{- Copy content from another direct file. -}
+			absf <- liftIO $ absPath f
+			locs <- filterM (\l -> isNothing <$> getAnnexLinkTarget l) =<<
+				(filter (/= absf) <$> addAssociatedFile k f)		
+			return $ Just $ fromdirect locs
 		)
   where
-  	fromindirect loc = return $ Just $ do
+  	fromindirect loc = do
 		{- Move content from annex to direct file. -}
 		thawContentDir loc
 		updateInodeCache k loc
 		void $ addAssociatedFile k f
 		thawContent loc
 		replaceFile f $ liftIO . moveFile loc
-	fromdirect = do
-		{- Copy content from another direct file. -}
-		absf <- liftIO $ absPath f
-		locs <- filterM (\loc -> isNothing <$> getAnnexLinkTarget loc) =<<
-			(filter (/= absf) <$> addAssociatedFile k f)
-		case locs of
-			(loc:_) -> return $ Just $ do
-				replaceFile f $
-					liftIO . void . copyFileExternal loc
-				updateInodeCache k f
-			_ -> return Nothing
+	fromdirect (loc:locs) = ifM (goodContent k loc)
+		( do
+			replaceFile f $
+				liftIO . void . copyFileExternal loc
+			updateInodeCache k f
+		, fromdirect locs
+		)
+	fromdirect [] = noop
 
 {- Removes a direct mode file, while retaining its content in the annex
  - (unless its content has already been changed). -}

Annex/Exception.hs

@@ -24,9 +24,8 @@ import Control.Exception hiding (handle, try, throw, bracket, catch)
 import Common.Annex
 
 {- Runs an Annex action, with setup and cleanup both in the IO monad. -}
-bracketIO :: IO c -> (c -> IO b) -> Annex a -> Annex a
-bracketIO setup cleanup go =
-	bracket (liftIO setup) (liftIO . cleanup) (const go)
+bracketIO :: IO v -> (v -> IO b) -> (v -> Annex a) -> Annex a
+bracketIO setup cleanup go = bracket (liftIO setup) (liftIO . cleanup) go
 
 {- try in the Annex monad -}
 tryAnnex :: Annex a -> Annex (Either SomeException a)

Annex/Journal.hs

@@ -84,7 +84,7 @@ lockJournal a = do
 	lockfile <- fromRepo gitAnnexJournalLock
 	createAnnexDirectory $ takeDirectory lockfile
 	mode <- annexFileMode
-	bracketIO (lock lockfile mode) unlock a
+	bracketIO (lock lockfile mode) unlock (const a)
   where
 	lock lockfile mode = do
 #ifndef __WINDOWS__

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

Logs/Transfer.hs

@@ -119,7 +119,7 @@ runTransfer t file shouldretry a = do
 	mode <- annexFileMode
 	fd <- liftIO $ prep tfile mode info
 	ok <- retry info metervar $
-		bracketIO (return fd) (cleanup tfile) (a meter)
+		bracketIO (return fd) (cleanup tfile) (const $ a meter)
 	unless ok $ recordFailedTransfer t info
 	return ok
   where

Remote/Git.hs

@@ -354,7 +354,7 @@ copyFromRemote' r key file dest
 			forever $
 				send =<< readSV v
 		let feeder = writeSV v . fromBytesProcessed
-		bracketIO noop (const $ tryIO $ killThread tid) (a feeder)
+		bracketIO noop (const $ tryIO $ killThread tid) (const $ a feeder)
 
 copyFromRemoteCheap :: Remote -> Key -> FilePath -> Annex Bool
 copyFromRemoteCheap r key file