diff --git a/Annex.hs b/Annex.hs index 8e79e63c18..32a303239a 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 35294ba2b7..3fcf1a1b97 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 f775e3064b..1166cd18ad 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 f7ce33bda2..7e2b4ce3bb 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/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index c4e43e1405..5450638d92 100644 --- a/Assistant/WebApp/Types.hs +++ b/Assistant/WebApp/Types.hs @@ -22,6 +22,7 @@ import Utility.NotificationBroadcaster import Utility.AuthToken import Utility.WebApp import Utility.Yesod +import Types.Transfer import Utility.Gpg (KeyId) import Build.SysConfig (packageversion) import Types.ScheduledActivity diff --git a/CHANGELOG b/CHANGELOG index 1c9d6132ae..1d9a711888 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 Sat, 07 Oct 2017 14:11:00 -0400 diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index 75c9e9471b..b8d0e3a402 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -1,6 +1,6 @@ {- git-annex command-line actions - - - Copyright 2010-2015 Joey Hess + - Copyright 2010-2017 Joey Hess - - 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 e91798eba2..a412b2cb30 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 a8f4307a28..941e397a4c 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 9e6c03e3b9..04e6aa3847 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 1bd8e623c9..b2d0bd2750 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 91683b1d08..3e90ae1ee2 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 ec7709a0e9..884c91a6bb 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 0b53bec018..73d8451017 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 093307ea9d..ade8fc7630 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 80c16d6e18..7008eb62d3 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]]