summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Annex.hs7
-rw-r--r--Annex/Transfer.hs56
-rw-r--r--Assistant/Types/DaemonStatus.hs3
-rw-r--r--Assistant/Types/TransferQueue.hs1
-rw-r--r--CHANGELOG4
-rw-r--r--CmdLine/Action.hs38
-rw-r--r--Command/Get.hs13
-rw-r--r--Command/Mirror.hs2
-rw-r--r--Command/Move.hs9
-rw-r--r--Command/Sync.hs2
-rw-r--r--Logs/Transfer.hs1
-rw-r--r--Types.hs4
-rw-r--r--Types/ActionItem.hs1
-rw-r--r--Types/Transfer.hs13
-rw-r--r--doc/bugs/get_-J___34__fails__34___to_get_files_with_the_same_key.mdwn4
15 files changed, 81 insertions, 77 deletions
diff --git a/Annex.hs b/Annex.hs
index 8e79e63c1..32a303239 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -61,7 +61,6 @@ import Types.UUID
import Types.FileMatcher
import Types.NumCopies
import Types.LockCache
-import Types.Transfer
import Types.DesktopNotify
import Types.CleanupActions
import qualified Database.Keys.Handle as Keys
@@ -126,7 +125,6 @@ data AnnexState = AnnexState
, groupmap :: Maybe GroupMap
, ciphers :: M.Map StorableCipher Cipher
, lockcache :: LockCache
- , currentprocesstransfers :: TVar (S.Set Transfer)
, sshstalecleaned :: TMVar Bool
, flags :: M.Map String Bool
, fields :: M.Map String String
@@ -140,6 +138,7 @@ data AnnexState = AnnexState
, existinghooks :: M.Map Git.Hook.Hook Bool
, desktopnotify :: DesktopNotify
, workers :: [Either AnnexState (Async AnnexState)]
+ , activekeys :: TVar (M.Map Key ThreadId)
, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer)
, keysdbhandle :: Maybe Keys.DbHandle
, cachedcurrentbranch :: Maybe Git.Branch
@@ -149,9 +148,9 @@ data AnnexState = AnnexState
newState :: GitConfig -> Git.Repo -> IO AnnexState
newState c r = do
emptyactiveremotes <- newMVar M.empty
+ emptyactivekeys <- newTVarIO M.empty
o <- newMessageState
sc <- newTMVarIO False
- cpt <- newTVarIO S.empty
return $ AnnexState
{ repo = r
, repoadjustment = return
@@ -182,7 +181,6 @@ newState c r = do
, groupmap = Nothing
, ciphers = M.empty
, lockcache = M.empty
- , currentprocesstransfers = cpt
, sshstalecleaned = sc
, flags = M.empty
, fields = M.empty
@@ -196,6 +194,7 @@ newState c r = do
, existinghooks = M.empty
, desktopnotify = mempty
, workers = []
+ , activekeys = emptyactivekeys
, activeremotes = emptyactiveremotes
, keysdbhandle = Nothing
, cachedcurrentbranch = Nothing
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
diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs
index f775e3064..1166cd18a 100644
--- a/Assistant/Types/DaemonStatus.hs
+++ b/Assistant/Types/DaemonStatus.hs
@@ -38,8 +38,7 @@ data DaemonStatus = DaemonStatus
, lastSanityCheck :: Maybe POSIXTime
-- True when a scan for file transfers is running
, transferScanRunning :: Bool
- -- Currently running file content transfers, for both this process
- -- and other processes.
+ -- Currently running file content transfers
, currentTransfers :: TransferMap
-- Messages to display to the user.
, alertMap :: AlertMap
diff --git a/Assistant/Types/TransferQueue.hs b/Assistant/Types/TransferQueue.hs
index f7ce33bda..7e2b4ce3b 100644
--- a/Assistant/Types/TransferQueue.hs
+++ b/Assistant/Types/TransferQueue.hs
@@ -8,6 +8,7 @@
module Assistant.Types.TransferQueue where
import Annex.Common
+import Types.Transfer
import Control.Concurrent.STM
import Utility.TList
diff --git a/CHANGELOG b/CHANGELOG
index 1c9d6132a..1d9a71188 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -11,8 +11,8 @@ git-annex (6.20171004) UNRELEASED; urgency=medium
where interrupting an add could result in the file being
moved into the annex, with no symlink yet created.
* Avoid repeated checking that files passed on the command line exist.
- * Improve behavior when -J transfers multiple files that point to the
- same key.
+ * get -J/move -J/copy -J/mirror -J/sync -J: Avoid "transfer already in
+ progress" errors when two files use the same key.
* stack.yaml: Update to lts-9.9.
-- Joey Hess <id@joeyh.name> Sat, 07 Oct 2017 14:11:00 -0400
diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs
index 75c9e9471..b8d0e3a40 100644
--- a/CmdLine/Action.hs
+++ b/CmdLine/Action.hs
@@ -1,6 +1,6 @@
{- git-annex command-line actions
-
- - Copyright 2010-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -18,9 +18,12 @@ import Messages.Concurrent
import Types.Messages
import Remote.List
+import Control.Concurrent
import Control.Concurrent.Async
+import Control.Concurrent.STM
import Control.Exception (throwIO)
import Data.Either
+import qualified Data.Map.Strict as M
#ifdef WITH_CONCURRENTOUTPUT
import qualified System.Console.Regions as Regions
@@ -177,3 +180,36 @@ allowConcurrentOutput a = go =<< Annex.getState Annex.concurrency
#else
allowConcurrentOutput = id
#endif
+
+{- Ensures that only one thread processes a key at a time.
+ - Other threads will block until it's done. -}
+onlyActionOn :: Key -> CommandStart -> CommandStart
+onlyActionOn k a = onlyActionOn' k run
+ where
+ run = do
+ -- Run whole action, not just start stage, so other threads
+ -- block until it's done.
+ r <- callCommandAction' a
+ case r of
+ Nothing -> return Nothing
+ Just r' -> return $ Just $ return $ Just $ return r'
+
+onlyActionOn' :: Key -> Annex a -> Annex a
+onlyActionOn' k a = go =<< Annex.getState Annex.concurrency
+ where
+ go NonConcurrent = a
+ go (Concurrent _) = do
+ tv <- Annex.getState Annex.activekeys
+ bracket (setup tv) id (const a)
+ setup tv = liftIO $ do
+ mytid <- myThreadId
+ atomically $ do
+ m <- readTVar tv
+ case M.lookup k m of
+ Just tid
+ | tid /= mytid -> retry
+ | otherwise -> return (return ())
+ Nothing -> do
+ writeTVar tv $! M.insert k mytid m
+ return $ liftIO $ atomically $
+ modifyTVar tv $ M.delete k
diff --git a/Command/Get.hs b/Command/Get.hs
index e91798eba..a412b2cb3 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -62,8 +62,8 @@ startKeys from key ai = checkFailedTransferDirection ai Download $
start' (return True) from key (AssociatedFile Nothing) ai
start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart
-start' expensivecheck from key afile ai = stopUnless (not <$> inAnnex key) $
- stopUnless expensivecheck $
+start' expensivecheck from key afile ai = onlyActionOn key $
+ stopUnless (not <$> inAnnex key) $ stopUnless expensivecheck $
case from of
Nothing -> go $ perform key afile
Just src ->
@@ -109,10 +109,9 @@ getKey' key afile = dispatch
| Remote.hasKeyCheap r =
either (const False) id <$> Remote.hasKey r key
| otherwise = return True
- docopy r = download (Remote.uuid r) key afile forwardRetry $ \p ->
- ifM (inAnnex key)
- ( return True
- , getViaTmp (RemoteVerify r) key $ \dest -> do
+ docopy r witness = getViaTmp (RemoteVerify r) key $ \dest ->
+ download (Remote.uuid r) key afile forwardRetry
+ (\p -> do
showAction $ "from " ++ Remote.name r
Remote.retrieveKeyFile r key afile dest p
- )
+ ) witness
diff --git a/Command/Mirror.hs b/Command/Mirror.hs
index a8f4307a2..941e397a4 100644
--- a/Command/Mirror.hs
+++ b/Command/Mirror.hs
@@ -53,7 +53,7 @@ start o file k = startKey o afile k (mkActionItem afile)
afile = AssociatedFile (Just file)
startKey :: MirrorOptions -> AssociatedFile -> Key -> ActionItem -> CommandStart
-startKey o afile key ai = case fromToOptions o of
+startKey o afile key ai = onlyActionOn key $ case fromToOptions o of
ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key)
( Command.Move.toStart False afile key ai =<< getParsed r
, do
diff --git a/Command/Move.hs b/Command/Move.hs
index 9e6c03e3b..04e6aa384 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -74,7 +74,7 @@ startKey :: MoveOptions -> Bool -> Key -> ActionItem -> CommandStart
startKey o move = start' o move (AssociatedFile Nothing)
start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart
-start' o move afile key ai =
+start' o move afile key ai = onlyActionOn key $
case fromToOptions o of
Right (FromRemote src) ->
checkFailedTransferDirection ai Download $
@@ -200,11 +200,8 @@ fromPerform src move key afile = do
where
go = notifyTransfer Download afile $
download (Remote.uuid src) key afile forwardRetry $ \p ->
- ifM (inAnnex key)
- ( return True
- , getViaTmp (RemoteVerify src) key $ \t ->
- Remote.retrieveKeyFile src key afile t p
- )
+ getViaTmp (RemoteVerify src) key $ \t ->
+ Remote.retrieveKeyFile src key afile t p
dispatch _ False = stop -- failed
dispatch False True = next $ return True -- copy complete
-- Finish by dropping from remote, taking care to verify that
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 1bd8e623c..b2d0bd275 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -609,7 +609,7 @@ seekSyncContent o rs = do
- Returns True if any file transfers were made.
-}
syncFile :: Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool
-syncFile ebloom rs af k = do
+syncFile ebloom rs af k = onlyActionOn' k $ do
locs <- Remote.keyLocations k
let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 91683b1d0..3e90ae1ee 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -9,7 +9,6 @@
module Logs.Transfer where
-import Types
import Types.Transfer
import Types.ActionItem
import Annex.Common
diff --git a/Types.hs b/Types.hs
index ec7709a0e..884c91a6b 100644
--- a/Types.hs
+++ b/Types.hs
@@ -15,8 +15,6 @@ module Types (
RemoteGitConfig(..),
Remote,
RemoteType,
- Transfer,
- TransferInfo,
) where
import Annex
@@ -25,9 +23,7 @@ import Types.GitConfig
import Types.Key
import Types.UUID
import Types.Remote
-import Types.Transfer
type Backend = BackendA Annex
type Remote = RemoteA Annex
type RemoteType = RemoteTypeA Annex
-type TransferInfo = TransferInfoA Annex
diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs
index 0b53bec01..73d845101 100644
--- a/Types/ActionItem.hs
+++ b/Types/ActionItem.hs
@@ -10,7 +10,6 @@
module Types.ActionItem where
import Key
-import Types
import Types.Transfer
import Git.FilePath
diff --git a/Types/Transfer.hs b/Types/Transfer.hs
index 093307ea9..ade8fc763 100644
--- a/Types/Transfer.hs
+++ b/Types/Transfer.hs
@@ -7,13 +7,10 @@
module Types.Transfer where
-import Types.Remote
-import Types.Key
-import Types.UUID
+import Types
import Utility.PID
import Utility.QuickCheck
-import Control.Concurrent.STM
import Data.Time.Clock.POSIX
import Control.Concurrent
import Control.Applicative
@@ -33,18 +30,18 @@ data Transfer = Transfer
- git repository. It's some file, possibly relative to some directory,
- of some repository, that was acted on to initiate the transfer.
-}
-data TransferInfoA a = TransferInfo
+data TransferInfo = TransferInfo
{ startedTime :: Maybe POSIXTime
, transferPid :: Maybe PID
, transferTid :: Maybe ThreadId
- , transferRemote :: Maybe (RemoteA a)
+ , transferRemote :: Maybe Remote
, bytesComplete :: Maybe Integer
, associatedFile :: AssociatedFile
, transferPaused :: Bool
}
deriving (Show, Eq, Ord)
-stubTransferInfo :: TransferInfoA a
+stubTransferInfo :: TransferInfo
stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing (AssociatedFile Nothing) False
data Direction = Upload | Download
@@ -59,7 +56,7 @@ parseDirection "upload" = Just Upload
parseDirection "download" = Just Download
parseDirection _ = Nothing
-instance Arbitrary (TransferInfoA a) where
+instance Arbitrary TransferInfo where
arbitrary = TransferInfo
<$> arbitrary
<*> arbitrary
diff --git a/doc/bugs/get_-J___34__fails__34___to_get_files_with_the_same_key.mdwn b/doc/bugs/get_-J___34__fails__34___to_get_files_with_the_same_key.mdwn
index 80c16d6e1..7008eb62d 100644
--- a/doc/bugs/get_-J___34__fails__34___to_get_files_with_the_same_key.mdwn
+++ b/doc/bugs/get_-J___34__fails__34___to_get_files_with_the_same_key.mdwn
@@ -47,4 +47,6 @@ I wondered if annex should first analyze passed paths to get actual keys to be f
[[!meta author=yoh]]
-> [[fixed|done]] --[[Joey]]
+> [[fixed|done]]; also fixed for several other commands, but the final
+> fix needed each command that could have the problem to be modified, so
+> there could possibly be some I missed.. --[[Joey]]