diff options
| -rw-r--r-- | Annex.hs | 4 | ||||
| -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 | 2 | ||||
| -rw-r--r-- | Command/Get.hs | 9 | ||||
| -rw-r--r-- | Command/Move.hs | 7 | ||||
| -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 | 2 |
12 files changed, 72 insertions, 31 deletions
@@ -61,6 +61,7 @@ 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 @@ -125,6 +126,7 @@ 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 @@ -149,6 +151,7 @@ newState c r = do emptyactiveremotes <- newMVar M.empty o <- newMessageState sc <- newTMVarIO False + cpt <- newTVarIO S.empty return $ AnnexState { repo = r , repoadjustment = return @@ -179,6 +182,7 @@ newState c r = do , groupmap = Nothing , ciphers = M.empty , lockcache = M.empty + , currentprocesstransfers = cpt , sshstalecleaned = sc , flags = M.empty , fields = M.empty diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index 3fcf1a1b9..35294ba2b 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -32,7 +32,9 @@ 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 @@ -89,22 +91,23 @@ 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 $ 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 +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 where #ifndef mingw32_HOST_OS prep tfile mode info = catchPermissionDenied (const prepfailed) $ do @@ -153,7 +156,7 @@ runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t dropLock lockhandle void $ tryIO $ removeFile lck #endif - retry oldinfo metervar run = do + handleretry oldinfo metervar run = do v <- tryNonAsync run case v of Right b -> return b @@ -162,7 +165,7 @@ runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t b <- getbytescomplete metervar let newinfo = oldinfo { bytesComplete = Just b } if shouldretry oldinfo newinfo - then retry newinfo metervar run + then handleretry newinfo metervar run else return observeFailure getbytescomplete metervar | transferDirection t == Upload = @@ -256,3 +259,20 @@ 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 1166cd18a..f775e3064 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -38,7 +38,8 @@ data DaemonStatus = DaemonStatus , lastSanityCheck :: Maybe POSIXTime -- True when a scan for file transfers is running , transferScanRunning :: Bool - -- Currently running file content transfers + -- Currently running file content transfers, for both this process + -- and other processes. , currentTransfers :: TransferMap -- Messages to display to the user. , alertMap :: AlertMap diff --git a/Assistant/Types/TransferQueue.hs b/Assistant/Types/TransferQueue.hs index 7e2b4ce3b..f7ce33bda 100644 --- a/Assistant/Types/TransferQueue.hs +++ b/Assistant/Types/TransferQueue.hs @@ -8,7 +8,6 @@ module Assistant.Types.TransferQueue where import Annex.Common -import Types.Transfer import Control.Concurrent.STM import Utility.TList @@ -11,6 +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. * stack.yaml: Update to lts-9.9. -- Joey Hess <id@joeyh.name> Sat, 07 Oct 2017 14:11:00 -0400 diff --git a/Command/Get.hs b/Command/Get.hs index 5cb0245d9..e91798eba 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -109,9 +109,10 @@ getKey' key afile = dispatch | Remote.hasKeyCheap r = either (const False) id <$> Remote.hasKey r key | otherwise = return True - docopy r witness = getViaTmp (RemoteVerify r) key $ \dest -> - download (Remote.uuid r) key afile forwardRetry - (\p -> do + docopy r = download (Remote.uuid r) key afile forwardRetry $ \p -> + ifM (inAnnex key) + ( return True + , getViaTmp (RemoteVerify r) key $ \dest -> do showAction $ "from " ++ Remote.name r Remote.retrieveKeyFile r key afile dest p - ) witness + ) diff --git a/Command/Move.hs b/Command/Move.hs index b9e0b6548..9e6c03e3b 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -200,8 +200,11 @@ fromPerform src move key afile = do where go = notifyTransfer Download afile $ download (Remote.uuid src) key afile forwardRetry $ \p -> - getViaTmp (RemoteVerify src) key $ \t -> - Remote.retrieveKeyFile src key afile t p + ifM (inAnnex key) + ( return True + , 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/Logs/Transfer.hs b/Logs/Transfer.hs index 3e90ae1ee..91683b1d0 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -9,6 +9,7 @@ module Logs.Transfer where +import Types import Types.Transfer import Types.ActionItem import Annex.Common @@ -15,6 +15,8 @@ module Types ( RemoteGitConfig(..), Remote, RemoteType, + Transfer, + TransferInfo, ) where import Annex @@ -23,7 +25,9 @@ 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 73d845101..0b53bec01 100644 --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -10,6 +10,7 @@ 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 ade8fc763..093307ea9 100644 --- a/Types/Transfer.hs +++ b/Types/Transfer.hs @@ -7,10 +7,13 @@ module Types.Transfer where -import Types +import Types.Remote +import Types.Key +import Types.UUID import Utility.PID import Utility.QuickCheck +import Control.Concurrent.STM import Data.Time.Clock.POSIX import Control.Concurrent import Control.Applicative @@ -30,18 +33,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 TransferInfo = TransferInfo +data TransferInfoA a = TransferInfo { startedTime :: Maybe POSIXTime , transferPid :: Maybe PID , transferTid :: Maybe ThreadId - , transferRemote :: Maybe Remote + , transferRemote :: Maybe (RemoteA a) , bytesComplete :: Maybe Integer , associatedFile :: AssociatedFile , transferPaused :: Bool } deriving (Show, Eq, Ord) -stubTransferInfo :: TransferInfo +stubTransferInfo :: TransferInfoA a stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing (AssociatedFile Nothing) False data Direction = Upload | Download @@ -56,7 +59,7 @@ parseDirection "upload" = Just Upload parseDirection "download" = Just Download parseDirection _ = Nothing -instance Arbitrary TransferInfo where +instance Arbitrary (TransferInfoA a) 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 fade3b331..80c16d6e1 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 @@ -46,3 +46,5 @@ so at the end we get a run of git-annex which exits with error 1... and in json I wondered if annex should first analyze passed paths to get actual keys to be fetched? [[!meta author=yoh]] + +> [[fixed|done]] --[[Joey]] |