diff options
| -rw-r--r-- | Annex.hs | 7 | ||||
| -rw-r--r-- | Annex/Transfer.hs | 56 | ||||
| -rw-r--r-- | Assistant/Types/DaemonStatus.hs | 3 | ||||
| -rw-r--r-- | Assistant/Types/TransferQueue.hs | 1 | ||||
| -rw-r--r-- | CHANGELOG | 4 | ||||
| -rw-r--r-- | CmdLine/Action.hs | 38 | ||||
| -rw-r--r-- | Command/Get.hs | 13 | ||||
| -rw-r--r-- | Command/Mirror.hs | 2 | ||||
| -rw-r--r-- | Command/Move.hs | 9 | ||||
| -rw-r--r-- | Command/Sync.hs | 2 | ||||
| -rw-r--r-- | Logs/Transfer.hs | 1 | ||||
| -rw-r--r-- | Types.hs | 4 | ||||
| -rw-r--r-- | Types/ActionItem.hs | 1 | ||||
| -rw-r--r-- | Types/Transfer.hs | 13 | ||||
| -rw-r--r-- | doc/bugs/get_-J___34__fails__34___to_get_files_with_the_same_key.mdwn | 4 |
15 files changed, 81 insertions, 77 deletions
@@ -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 @@ -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 @@ -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]] |