summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Annex/Content.hs2
-rw-r--r--Annex/Content/Direct.hs2
-rw-r--r--Annex/Direct.hs33
-rw-r--r--Annex/Exception.hs5
-rw-r--r--Annex/Journal.hs2
-rw-r--r--Annex/ReplaceFile.hs25
-rw-r--r--Logs/Transfer.hs2
-rw-r--r--Remote/Git.hs2
8 files changed, 40 insertions, 33 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs
index 3e6d621b6..62c52cf88 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 ef2573c34..b9c78f8c0 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 dc09742bc..a3bc951d1 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 f06f568a4..96070ee26 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 e68591ce2..0f0803aaa 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 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
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 6f28ef115..47c6e7495 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 32f6a1c7c..05dad469a 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