From bf86b5ca16b3b17cf17be0dbcfb085c8c0caad29 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 22 May 2013 20:58:27 -0400
Subject: [PATCH] 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.
---
Annex/Content.hs | 2 +-
Annex/Content/Direct.hs | 2 +-
Annex/Direct.hs | 33 ++++++++++++++++++---------------
Annex/Exception.hs | 5 ++---
Annex/Journal.hs | 2 +-
Annex/ReplaceFile.hs | 25 +++++++++++++++----------
Logs/Transfer.hs | 2 +-
Remote/Git.hs | 2 +-
8 files changed, 40 insertions(+), 33 deletions(-)
diff --git a/Annex/Content.hs b/Annex/Content.hs
index 3e6d621b68..62c52cf881 100644
--- a/Annex/Content.hs
+++ b/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. -}
diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs
index ef2573c344..b9c78f8c05 100644
--- a/Annex/Content/Direct.hs
+++ b/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
diff --git a/Annex/Direct.hs b/Annex/Direct.hs
index dc09742bc9..a3bc951d1a 100644
--- a/Annex/Direct.hs
+++ b/Annex/Direct.hs
@@ -173,7 +173,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 +182,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). -}
diff --git a/Annex/Exception.hs b/Annex/Exception.hs
index f06f568a46..96070ee26d 100644
--- a/Annex/Exception.hs
+++ b/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)
diff --git a/Annex/Journal.hs b/Annex/Journal.hs
index e68591ce2c..0f0803aaac 100644
--- a/Annex/Journal.hs
+++ b/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__
diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs
index f0dfa5b272..93f8079783 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
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 6f28ef1159..47c6e74953 100644
--- a/Logs/Transfer.hs
+++ b/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
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 32f6a1c7c1..05dad469a9 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -346,7 +346,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