summaryrefslogtreecommitdiff
path: root/Annex
diff options
context:
space:
mode:
Diffstat (limited to 'Annex')
-rw-r--r--Annex/Transfer.hs56
1 files changed, 18 insertions, 38 deletions
diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index 35294ba2b..3fcf1a1b9 100644
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@@ -32,9 +32,7 @@ import qualified Types.Remote as Remote
import Types.Concurrency
import Control.Concurrent
-import Control.Concurrent.STM
import qualified Data.Map.Strict as M
-import qualified Data.Set as S
import Data.Ord
class Observable a where
@@ -91,23 +89,22 @@ alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider
alwaysRunTransfer = runTransfer' True
runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
-runTransfer' ignorelock t afile shouldretry transferaction =
- checkSecureHashes t $ currentProcessTransfer t $ do
- info <- liftIO $ startTransferInfo afile
- (meter, tfile, metervar) <- mkProgressUpdater t info
- mode <- annexFileMode
- (lck, inprogress) <- prep tfile mode info
- if inprogress && not ignorelock
- then do
- showNote "transfer already in progress, or unable to take transfer lock"
- return observeFailure
- else do
- v <- handleretry info metervar $ transferaction meter
- liftIO $ cleanup tfile lck
- if observeBool v
- then removeFailedTransfer t
- else recordFailedTransfer t info
- return v
+runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t $ do
+ info <- liftIO $ startTransferInfo afile
+ (meter, tfile, metervar) <- mkProgressUpdater t info
+ mode <- annexFileMode
+ (lck, inprogress) <- prep tfile mode info
+ if inprogress && not ignorelock
+ then do
+ showNote "transfer already in progress, or unable to take transfer lock"
+ return observeFailure
+ else do
+ v <- retry info metervar $ transferaction meter
+ liftIO $ cleanup tfile lck
+ if observeBool v
+ then removeFailedTransfer t
+ else recordFailedTransfer t info
+ return v
where
#ifndef mingw32_HOST_OS
prep tfile mode info = catchPermissionDenied (const prepfailed) $ do
@@ -156,7 +153,7 @@ runTransfer' ignorelock t afile shouldretry transferaction =
dropLock lockhandle
void $ tryIO $ removeFile lck
#endif
- handleretry oldinfo metervar run = do
+ retry oldinfo metervar run = do
v <- tryNonAsync run
case v of
Right b -> return b
@@ -165,7 +162,7 @@ runTransfer' ignorelock t afile shouldretry transferaction =
b <- getbytescomplete metervar
let newinfo = oldinfo { bytesComplete = Just b }
if shouldretry oldinfo newinfo
- then handleretry newinfo metervar run
+ then retry newinfo metervar run
else return observeFailure
getbytescomplete metervar
| transferDirection t == Upload =
@@ -259,20 +256,3 @@ lessActiveFirst :: M.Map Remote Integer -> Remote -> Remote -> Ordering
lessActiveFirst active a b
| Remote.cost a == Remote.cost b = comparing (`M.lookup` active) a b
| otherwise = compare a b
-
-{- Runs a transfer action. Only one thread can run for a given Transfer
- - at a time; other threads will block. -}
-currentProcessTransfer :: Transfer -> Annex a -> Annex a
-currentProcessTransfer t a = go =<< Annex.getState Annex.concurrency
- where
- go NonConcurrent = a
- go (Concurrent _) = do
- tv <- Annex.getState Annex.currentprocesstransfers
- bracket_ (setup tv) (cleanup tv) a
- setup tv = liftIO $ atomically $ do
- s <- readTVar tv
- if S.member t s
- then retry
- else writeTVar tv $! S.insert t s
- cleanup tv = liftIO $ atomically $
- modifyTVar' tv $ S.delete t