mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

suggest when user may want annex.stalldetection

Browse source 
When annex.stalldetection is not enabled, and a likely stall is detected,
display a suggestion to enable it.

Note that the progress meter display is not taken down when displaying
the message, so it will display like this:

	0%    8 B                 0 B/s
	  Transfer seems to have stalled. To handle stalling transfers, configure annex.stalldetection
	0%    10 B                0 B/s

Although of course if it's really stalled, it will never update
again after the message. Taking down the progress meter and starting
a new one doesn't seem too necessary given how unusual this is,
also this does help show the state it was at when it stalled.

Use of uninterruptibleCancel here is ok, the thread it's canceling
only does STM transactions and sleeps. The annex thread that gets
forked off is separate to avoid it being canceled, so that it
can be joined back at the end.

A module cycle required moving from dupState the precaching of the
remote list. Doing it at startConcurrency should cover all the cases
where the remote list is used in concurrent actions.

This commit was sponsored by Kevin Mueller on Patreon.
This commit is contained in:
Joey Hess 2021-02-03 15:35:32 -04:00
parent 7db4e62a90
commit dd39e9e255
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
18 changed files with 160 additions and 101 deletions
Download patch file Download diff file Expand all files Collapse all files

6
Annex/Concurrent.hs
View file

@ -19,7 +19,6 @@ import Types.Concurrency
import Types.CatFileHandles import Types.CatFileHandles
import Annex.CheckAttr import Annex.CheckAttr
import Annex.CheckIgnore import Annex.CheckIgnore
import Remote.List
import qualified Data.Map as M import qualified Data.Map as M
@ -72,11 +71,6 @@ forkState a = do
-} -}
dupState :: Annex AnnexState dupState :: Annex AnnexState
dupState = do dupState = do
-- Make sure that some expensive actions have been done before
-- starting threads. This way the state has them already run,
-- and each thread won't try to do them.
_ <- remoteList
st <- Annex.getState id st <- Annex.getState id
-- Make sure that concurrency is enabled, if it was not already, -- Make sure that concurrency is enabled, if it was not already,
-- so the concurrency-safe resource pools are set up. -- so the concurrency-safe resource pools are set up.

4
Annex/Import.hs
View file

@ -504,7 +504,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
return (Just (k', ok)) return (Just (k', ok))
checkDiskSpaceToGet k Nothing $ checkDiskSpaceToGet k Nothing $
notifyTransfer Download af $ notifyTransfer Download af $
download' (Remote.uuid remote) k af stdRetry $ \p' -> download' (Remote.uuid remote) k af Nothing stdRetry $ \p' ->
withTmp k $ downloader p' withTmp k $ downloader p'
-- The file is small, so is added to git, so while importing -- The file is small, so is added to git, so while importing
@ -558,7 +558,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
return Nothing return Nothing
checkDiskSpaceToGet tmpkey Nothing $ checkDiskSpaceToGet tmpkey Nothing $
notifyTransfer Download af $ notifyTransfer Download af $
download' (Remote.uuid remote) tmpkey af stdRetry $ \p -> download' (Remote.uuid remote) tmpkey af Nothing stdRetry $ \p ->
withTmp tmpkey $ \tmpfile -> withTmp tmpkey $ \tmpfile ->
metered (Just p) tmpkey $ metered (Just p) tmpkey $
const (rundownload tmpfile) const (rundownload tmpfile)

23
Annex/StallDetection.hs
View file

@ -15,9 +15,13 @@ import Utility.DataUnits
import Utility.ThreadScheduler import Utility.ThreadScheduler
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad.IO.Class (MonadIO)
detectStalls :: Maybe StallDetection -> TVar (Maybe BytesProcessed) -> IO () -> IO () {- This may be safely canceled (with eg uninterruptibleCancel),
- as long as the passed action can be safely canceled. -}
detectStalls :: (Monad m, MonadIO m) => Maybe StallDetection -> TVar (Maybe BytesProcessed) -> m () -> m ()
detectStalls Nothing _ _ = noop detectStalls Nothing _ _ = noop
detectStalls (Just StallDetectionDisabled) _ _ = noop
detectStalls (Just (StallDetection minsz duration)) metervar onstall = detectStalls (Just (StallDetection minsz duration)) metervar onstall =
detectStalls' minsz duration metervar onstall Nothing detectStalls' minsz duration metervar onstall Nothing
detectStalls (Just ProbeStallDetection) metervar onstall = do detectStalls (Just ProbeStallDetection) metervar onstall = do
@ -30,7 +34,7 @@ detectStalls (Just ProbeStallDetection) metervar onstall = do
ontimelyadvance v $ \v' -> ontimelyadvance v' $ ontimelyadvance v $ \v' -> ontimelyadvance v' $
detectStalls' 1 duration metervar onstall detectStalls' 1 duration metervar onstall
where where
getval = atomically $ fmap fromBytesProcessed getval = liftIO $ atomically $ fmap fromBytesProcessed
<$> readTVar metervar <$> readTVar metervar
duration = Duration 60 duration = Duration 60
@ -38,29 +42,30 @@ detectStalls (Just ProbeStallDetection) metervar onstall = do
delay = Seconds (fromIntegral (durationSeconds duration) `div` 2) delay = Seconds (fromIntegral (durationSeconds duration) `div` 2)
waitforfirstupdate startval = do waitforfirstupdate startval = do
threadDelaySeconds delay liftIO $ threadDelaySeconds delay
v <- getval v <- getval
if v > startval if v > startval
then return v then return v
else waitforfirstupdate startval else waitforfirstupdate startval
ontimelyadvance v cont = do ontimelyadvance v cont = do
threadDelaySeconds delay liftIO $ threadDelaySeconds delay
v' <- getval v' <- getval
when (v' > v) $ when (v' > v) $
cont v' cont v'
detectStalls' detectStalls'
:: ByteSize :: (Monad m, MonadIO m)
=> ByteSize
-> Duration -> Duration
-> TVar (Maybe BytesProcessed) -> TVar (Maybe BytesProcessed)
-> IO () -> m ()
-> Maybe ByteSize -> Maybe ByteSize
-> IO () -> m ()
detectStalls' minsz duration metervar onstall st = do detectStalls' minsz duration metervar onstall st = do
threadDelaySeconds delay liftIO $ threadDelaySeconds delay
-- Get whatever progress value was reported most recently, if any. -- Get whatever progress value was reported most recently, if any.
v <- atomically $ fmap fromBytesProcessed v <- liftIO $ atomically $ fmap fromBytesProcessed
<$> readTVar metervar <$> readTVar metervar
let cont = detectStalls' minsz duration metervar onstall v let cont = detectStalls' minsz duration metervar onstall v
case (st, v) of case (st, v) of

117
Annex/Transfer.hs
View file

@ -1,6 +1,6 @@
{- git-annex transfers {- git-annex transfers
- -
- Copyright 2012-2020 Joey Hess <id@joeyh.name> - Copyright 2012-2021 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -37,50 +37,56 @@ import Annex.LockPool
import Types.Key import Types.Key
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
import Types.Concurrency import Types.Concurrency
import Annex.Concurrent.Utility import Annex.Concurrent
import Types.WorkerPool import Types.WorkerPool
import Annex.WorkerPool import Annex.WorkerPool
import Annex.TransferrerPool import Annex.TransferrerPool
import Annex.StallDetection
import Backend (isCryptographicallySecure) import Backend (isCryptographicallySecure)
import Types.StallDetection import Types.StallDetection
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM hiding (retry)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified System.FilePath.ByteString as P import qualified System.FilePath.ByteString as P
import Data.Ord import Data.Ord
-- Upload, supporting stall detection. -- Upload, supporting canceling detected stalls.
upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool
upload r key f d witness = stallDetection r >>= \case upload r key f d witness = stallDetection r >>= \case
Nothing -> upload' (Remote.uuid r) key f d go witness Nothing -> go (Just ProbeStallDetection)
Just StallDetectionDisabled -> go Nothing
Just sd -> runTransferrer sd r key f d Upload witness Just sd -> runTransferrer sd r key f d Upload witness
where where
go = action . Remote.storeKey r key f go sd = upload' (Remote.uuid r) key f sd d (action . Remote.storeKey r key f) witness
-- Upload, not supporting stall detection. -- Upload, not supporting canceling detected stalls
upload' :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v upload' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
upload' u key f d a _witness = guardHaveUUID u $ upload' u key f sd d a _witness = guardHaveUUID u $
runTransfer (Transfer Upload u (fromKey id key)) f d a runTransfer (Transfer Upload u (fromKey id key)) f sd d a
alwaysUpload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v alwaysUpload :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
alwaysUpload u key f d a _witness = guardHaveUUID u $ alwaysUpload u key f sd d a _witness = guardHaveUUID u $
alwaysRunTransfer (Transfer Upload u (fromKey id key)) f d a alwaysRunTransfer (Transfer Upload u (fromKey id key)) f sd d a
-- Download, supporting stall detection. -- Download, supporting canceling detected stalls.
download :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool download :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool
download r key f d witness = logStatusAfter key $ stallDetection r >>= \case download r key f d witness = logStatusAfter key $ stallDetection r >>= \case
Nothing -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key f $ \dest -> Nothing -> go (Just ProbeStallDetection)
download' (Remote.uuid r) key f d (go dest) witness Just StallDetectionDisabled -> go Nothing
Just sd -> runTransferrer sd r key f d Download witness Just sd -> runTransferrer sd r key f d Download witness
where where
go dest p = verifiedAction $ go sd = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key f $ \dest ->
download' (Remote.uuid r) key f sd d (go' dest) witness
go' dest p = verifiedAction $
Remote.retrieveKeyFile r key f (fromRawFilePath dest) p Remote.retrieveKeyFile r key f (fromRawFilePath dest) p
-- Download, not supporting stall detection. -- Download, not supporting canceling detected stalls.
download' :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v download' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
download' u key f d a _witness = guardHaveUUID u $ download' u key f sd d a _witness = guardHaveUUID u $
runTransfer (Transfer Download u (fromKey id key)) f d a runTransfer (Transfer Download u (fromKey id key)) f sd d a
guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v
guardHaveUUID u a guardHaveUUID u a
@ -98,34 +104,44 @@ guardHaveUUID u a
- -
- An upload can be run from a read-only filesystem, and in this case - An upload can be run from a read-only filesystem, and in this case
- no transfer information or lock file is used. - no transfer information or lock file is used.
-
- Cannot cancel stalls, but when a likely stall is detected,
- suggests to the user that they enable stall detection handling.
-} -}
runTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v runTransfer :: Observable v => Transfer -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
runTransfer = runTransfer' False runTransfer = runTransfer' False
{- Like runTransfer, but ignores any existing transfer lock file for the {- Like runTransfer, but ignores any existing transfer lock file for the
- transfer, allowing re-running a transfer that is already in progress. - transfer, allowing re-running a transfer that is already in progress.
-} -}
alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
alwaysRunTransfer = runTransfer' True alwaysRunTransfer = runTransfer' True
runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
runTransfer' ignorelock t afile retrydecider transferaction = enteringStage TransferStage $ debugLocks $ preCheckSecureHashes (transferKey t) $ do runTransfer' ignorelock t afile stalldetection retrydecider transferaction =
info <- liftIO $ startTransferInfo afile enteringStage TransferStage $
(meter, tfile, createtfile, metervar) <- mkProgressUpdater t info debugLocks $
mode <- annexFileMode preCheckSecureHashes (transferKey t) go
(lck, inprogress) <- prep tfile createtfile mode
if inprogress && not ignorelock
then do
showNote "transfer already in progress, or unable to take transfer lock"
return observeFailure
else do
v <- retry 0 info metervar (transferaction meter)
liftIO $ cleanup tfile lck
if observeBool v
then removeFailedTransfer t
else recordFailedTransfer t info
return v
where where
go = do
info <- liftIO $ startTransferInfo afile
(meter, tfile, createtfile, metervar) <- mkProgressUpdater t info
mode <- annexFileMode
(lck, inprogress) <- prep tfile createtfile mode
if inprogress && not ignorelock
then do
showNote "transfer already in progress, or unable to take transfer lock"
return observeFailure
else do
v <- retry 0 info metervar $
detectStallsAndSuggestConfig stalldetection metervar $
transferaction meter
liftIO $ cleanup tfile lck
if observeBool v
then removeFailedTransfer t
else recordFailedTransfer t info
return v
prep :: RawFilePath -> Annex () -> FileMode -> Annex (Maybe LockHandle, Bool) prep :: RawFilePath -> Annex () -> FileMode -> Annex (Maybe LockHandle, Bool)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
prep tfile createtfile mode = catchPermissionDenied (const prepfailed) $ do prep tfile createtfile mode = catchPermissionDenied (const prepfailed) $ do
@ -191,11 +207,32 @@ runTransfer' ignorelock t afile retrydecider transferaction = enteringStage Tran
getbytescomplete metervar getbytescomplete metervar
| transferDirection t == Upload = | transferDirection t == Upload =
liftIO $ readMVar metervar liftIO $ maybe 0 fromBytesProcessed
<$> readTVarIO metervar
| otherwise = do | otherwise = do
f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t) f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t)
liftIO $ catchDefaultIO 0 $ getFileSize f liftIO $ catchDefaultIO 0 $ getFileSize f
detectStallsAndSuggestConfig :: Maybe StallDetection -> TVar (Maybe BytesProcessed) -> Annex a -> Annex a
detectStallsAndSuggestConfig Nothing _ a = a
detectStallsAndSuggestConfig sd@(Just _) metervar a =
bracket setup cleanup (const a)
where
setup = do
v <- liftIO newEmptyTMVarIO
sdt <- liftIO $ async $ detectStalls sd metervar $
void $ atomically $ tryPutTMVar v True
wt <- liftIO . async =<< forkState (warnonstall v)
return (v, sdt, wt)
cleanup (v, sdt, wt) = do
liftIO $ uninterruptibleCancel sdt
void $ liftIO $ atomically $ tryPutTMVar v False
join (liftIO (wait wt))
warnonstall v = whenM (liftIO (atomically (takeTMVar v))) $
warning "Transfer seems to have stalled. To restart stalled transfers, configure annex.stalldetection"
{- Runs a transfer using a separate process, which lets detected stalls be
- canceled. -}
runTransferrer runTransferrer
:: StallDetection :: StallDetection
-> Remote -> Remote

2
CHANGELOG
View file

@ -18,6 +18,8 @@ git-annex (8.20210128) UNRELEASED; urgency=medium
* annex.stalldetection can now be set to "true" to make git-annex * annex.stalldetection can now be set to "true" to make git-annex
do automatic stall detection when it detects a remote is updating its do automatic stall detection when it detects a remote is updating its
transfer progress consistently enough. transfer progress consistently enough.
* When annex.stalldetection is not enabled and a likely stall is
detected, display a suggestion to enable it.
-- Joey Hess <id@joeyh.name> Thu, 28 Jan 2021 12:34:32 -0400 -- Joey Hess <id@joeyh.name> Thu, 28 Jan 2021 12:34:32 -0400

10
CmdLine/Action.hs
View file

@ -18,6 +18,7 @@ import Types.Concurrency
import Messages.Concurrent import Messages.Concurrent
import Types.Messages import Types.Messages
import Types.WorkerPool import Types.WorkerPool
import Remote.List
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async import Control.Concurrent.Async
@ -251,10 +252,19 @@ startConcurrency usedstages a = do
initworkerpool n = do initworkerpool n = do
tv <- liftIO newEmptyTMVarIO tv <- liftIO newEmptyTMVarIO
Annex.changeState $ \s -> s { Annex.workers = Just tv } Annex.changeState $ \s -> s { Annex.workers = Just tv }
prepDupState
st <- dupState st <- dupState
liftIO $ atomically $ putTMVar tv $ liftIO $ atomically $ putTMVar tv $
allocateWorkerPool st (max n 1) usedstages allocateWorkerPool st (max n 1) usedstages
-- Make sure that some expensive actions have been done before
-- starting threads. This way the state has them already run,
-- and each thread won't try to do them.
prepDupState :: Annex ()
prepDupState = do
_ <- remoteList
return ()
{- Ensures that only one thread processes a key at a time. {- Ensures that only one thread processes a key at a time.
- Other threads will block until it's done. - Other threads will block until it's done.
- -

4
Command/AddUrl.hs
View file

@ -332,7 +332,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink) let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)
showNote "using youtube-dl" showNote "using youtube-dl"
Transfer.notifyTransfer Transfer.Download url $ Transfer.notifyTransfer Transfer.Download url $
Transfer.download' webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p -> Transfer.download' webUUID mediakey (AssociatedFile Nothing) Nothing Transfer.noRetry $ \p ->
youtubeDl url (fromRawFilePath workdir) p >>= \case youtubeDl url (fromRawFilePath workdir) p >>= \case
Right (Just mediafile) -> do Right (Just mediafile) -> do
cleanuptmp cleanuptmp
@ -396,7 +396,7 @@ downloadWith' downloader dummykey u url afile =
checkDiskSpaceToGet dummykey Nothing $ do checkDiskSpaceToGet dummykey Nothing $ do
tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey
ok <- Transfer.notifyTransfer Transfer.Download url $ ok <- Transfer.notifyTransfer Transfer.Download url $
Transfer.download' u dummykey afile Transfer.stdRetry $ \p -> do Transfer.download' u dummykey afile Nothing Transfer.stdRetry $ \p -> do
createAnnexDirectory (parentDir tmp) createAnnexDirectory (parentDir tmp)
downloader (fromRawFilePath tmp) p downloader (fromRawFilePath tmp) p
if ok if ok

2
Command/Export.hs
View file

@ -287,7 +287,7 @@ performExport r db ek af contentsha loc allfilledvar = do
-- could be used for more than one export -- could be used for more than one export
-- location, and concurrently uploading -- location, and concurrently uploading
-- of the content should still be allowed. -- of the content should still be allowed.
alwaysUpload (uuid r) k af stdRetry $ \pm -> do alwaysUpload (uuid r) k af Nothing stdRetry $ \pm -> do
let rollback = void $ let rollback = void $
performUnexport r db [ek] loc performUnexport r db [ek] loc
sendAnnex k rollback $ \f -> sendAnnex k rollback $ \f ->

2
Command/SendKey.hs
View file

@ -50,7 +50,7 @@ fieldTransfer direction key a = do
<$> Fields.getField Fields.associatedFile <$> Fields.getField Fields.associatedFile
ok <- maybe (a $ const noop) ok <- maybe (a $ const noop)
-- Using noRetry here because we're the sender. -- Using noRetry here because we're the sender.
(\u -> runner (Transfer direction (toUUID u) (fromKey id key)) afile noRetry a) (\u -> runner (Transfer direction (toUUID u) (fromKey id key)) afile Nothing noRetry a)
=<< Fields.getField Fields.remoteUUID =<< Fields.getField Fields.remoteUUID
liftIO $ debugM "fieldTransfer" "transfer done" liftIO $ debugM "fieldTransfer" "transfer done"
liftIO $ exitBool ok liftIO $ exitBool ok

4
Command/TransferKey.hs
View file

@ -51,7 +51,7 @@ start o (_, key) = startingCustomOutput key $ case fromToOptions o of
toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
toPerform key file remote = go Upload file $ toPerform key file remote = go Upload file $
upload' (uuid remote) key file stdRetry $ \p -> do upload' (uuid remote) key file Nothing stdRetry $ \p -> do
tryNonAsync (Remote.storeKey remote key file p) >>= \case tryNonAsync (Remote.storeKey remote key file p) >>= \case
Right () -> do Right () -> do
Remote.logStatus remote key InfoPresent Remote.logStatus remote key InfoPresent
@ -62,7 +62,7 @@ toPerform key file remote = go Upload file $
fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
fromPerform key file remote = go Upload file $ fromPerform key file remote = go Upload file $
download' (uuid remote) key file stdRetry $ \p -> download' (uuid remote) key file Nothing stdRetry $ \p ->
logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t ->
tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case
Right v -> return (True, v) Right v -> return (True, v)

4
Command/TransferKeys.hs
View file

@ -40,7 +40,7 @@ start = do
where where
runner (TransferRequest direction remote key file) runner (TransferRequest direction remote key file)
| direction == Upload = notifyTransfer direction file $ | direction == Upload = notifyTransfer direction file $
upload' (Remote.uuid remote) key file stdRetry $ \p -> do upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do
tryNonAsync (Remote.storeKey remote key file p) >>= \case tryNonAsync (Remote.storeKey remote key file p) >>= \case
Left e -> do Left e -> do
warning (show e) warning (show e)
@ -49,7 +49,7 @@ start = do
Remote.logStatus remote key InfoPresent Remote.logStatus remote key InfoPresent
return True return True
| otherwise = notifyTransfer direction file $ | otherwise = notifyTransfer direction file $
download' (Remote.uuid remote) key file stdRetry $ \p -> download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->
logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case
Left e -> do Left e -> do

14
Command/Transferrer.hs
View file

@ -45,21 +45,23 @@ start = do
runner (UploadRequest _ key (TransferAssociatedFile file)) remote = runner (UploadRequest _ key (TransferAssociatedFile file)) remote =
-- This is called by eg, Annex.Transfer.upload, -- This is called by eg, Annex.Transfer.upload,
-- so caller is responsible for doing notification, -- so caller is responsible for doing notification,
-- and for retrying, and updating location log. -- and for retrying, and updating location log,
upload' (Remote.uuid remote) key file noRetry -- and stall canceling.
upload' (Remote.uuid remote) key file Nothing noRetry
(Remote.action . Remote.storeKey remote key file) (Remote.action . Remote.storeKey remote key file)
noNotification noNotification
runner (DownloadRequest _ key (TransferAssociatedFile file)) remote = runner (DownloadRequest _ key (TransferAssociatedFile file)) remote =
-- This is called by eg, Annex.Transfer.download -- This is called by eg, Annex.Transfer.download
-- so caller is responsible for doing notification -- so caller is responsible for doing notification
-- and for retrying, and updating location log. -- and for retrying, and updating location log,
-- and stall canceling.
let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p)
in download' (Remote.uuid remote) key file noRetry go in download' (Remote.uuid remote) key file Nothing noRetry go
noNotification noNotification
runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote = runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote =
notifyTransfer Upload file $ notifyTransfer Upload file $
upload' (Remote.uuid remote) key file stdRetry $ \p -> do upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do
tryNonAsync (Remote.storeKey remote key file p) >>= \case tryNonAsync (Remote.storeKey remote key file p) >>= \case
Left e -> do Left e -> do
warning (show e) warning (show e)
@ -69,7 +71,7 @@ start = do
return True return True
runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote = runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote =
notifyTransfer Download file $ notifyTransfer Download file $
download' (Remote.uuid remote) key file stdRetry $ \p -> download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->
logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case
Left e -> do Left e -> do

32
Logs/Transfer.hs
View file

@ -1,6 +1,6 @@
{- git-annex transfer information files and lock files {- git-annex transfer information files and lock files
- -
- Copyright 2012-2019 Joey Hess <id@joeyh.name> - Copyright 2012-2021 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -27,7 +27,7 @@ import Annex.Perms
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import Control.Concurrent import Control.Concurrent.STM
import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as B8
import qualified System.FilePath.ByteString as P import qualified System.FilePath.ByteString as P
@ -58,23 +58,25 @@ percentComplete t info =
- the transfer info file. Also returns the file it'll be updating, - the transfer info file. Also returns the file it'll be updating,
- an action that sets up the file with appropriate permissions, - an action that sets up the file with appropriate permissions,
- which should be run after locking the transfer lock file, but - which should be run after locking the transfer lock file, but
- before using the callback, and a MVar that can be used to read - before using the callback, and a TVar that can be used to read
- the number of bytesComplete. -} - the number of bytes processed so far. -}
mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, RawFilePath, Annex (), MVar Integer) mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, RawFilePath, Annex (), TVar (Maybe BytesProcessed))
mkProgressUpdater t info = do mkProgressUpdater t info = do
tfile <- fromRepo $ transferFile t tfile <- fromRepo $ transferFile t
let createtfile = void $ tryNonAsync $ writeTransferInfoFile info tfile let createtfile = void $ tryNonAsync $ writeTransferInfoFile info tfile
mvar <- liftIO $ newMVar 0 tvar <- liftIO $ newTVarIO Nothing
return (liftIO . updater (fromRawFilePath tfile) mvar, tfile, createtfile, mvar) loggedtvar <- liftIO $ newTVarIO 0
return (liftIO . updater (fromRawFilePath tfile) tvar loggedtvar, tfile, createtfile, tvar)
where where
updater tfile mvar b = modifyMVar_ mvar $ \oldbytes -> do updater tfile tvar loggedtvar new = do
let newbytes = fromBytesProcessed b old <- atomically $ swapTVar tvar (Just new)
if newbytes - oldbytes >= mindelta let oldbytes = maybe 0 fromBytesProcessed old
then do let newbytes = fromBytesProcessed new
let info' = info { bytesComplete = Just newbytes } when (newbytes - oldbytes >= mindelta) $ do
_ <- tryIO $ updateTransferInfoFile info' tfile let info' = info { bytesComplete = Just newbytes }
return newbytes _ <- tryIO $ updateTransferInfoFile info' tfile
else return oldbytes atomically $ writeTVar loggedtvar newbytes
{- The minimum change in bytesComplete that is worth {- The minimum change in bytesComplete that is worth
- updating a transfer info file for is 1% of the total - updating a transfer info file for is 1% of the total
- keySize, rounded down. -} - keySize, rounded down. -}

8
P2P/Annex.hs
View file

@ -64,7 +64,7 @@ runLocal runst runner a = case a of
case v of case v of
Right (Just (f, checkchanged)) -> proceed $ do Right (Just (f, checkchanged)) -> proceed $ do
-- alwaysUpload to allow multiple uploads of the same key. -- alwaysUpload to allow multiple uploads of the same key.
let runtransfer ti = transfer alwaysUpload k af $ \p -> let runtransfer ti = transfer alwaysUpload k af Nothing $ \p ->
sinkfile f o checkchanged sender p ti sinkfile f o checkchanged sender p ti
checktransfer runtransfer fallback checktransfer runtransfer fallback
Right Nothing -> proceed fallback Right Nothing -> proceed fallback
@ -75,7 +75,7 @@ runLocal runst runner a = case a of
let rsp = RetrievalAllKeysSecure let rsp = RetrievalAllKeysSecure
v <- tryNonAsync $ do v <- tryNonAsync $ do
let runtransfer ti = let runtransfer ti =
Right <$> transfer download' k af (\p -> Right <$> transfer download' k af Nothing (\p ->
logStatusAfter k $ getViaTmp rsp DefaultVerify k af $ \tmp -> logStatusAfter k $ getViaTmp rsp DefaultVerify k af $ \tmp ->
storefile (fromRawFilePath tmp) o l getb validitycheck p ti) storefile (fromRawFilePath tmp) o l getb validitycheck p ti)
let fallback = return $ Left $ let fallback = return $ Left $
@ -145,11 +145,11 @@ runLocal runst runner a = case a of
runner next runner next
RunValidityCheck checkaction next -> runner . next =<< checkaction RunValidityCheck checkaction next -> runner . next =<< checkaction
where where
transfer mk k af ta = case runst of transfer mk k af sd ta = case runst of
-- Update transfer logs when serving. -- Update transfer logs when serving.
-- Using noRetry because we're the sender. -- Using noRetry because we're the sender.
Serving theiruuid _ _ -> Serving theiruuid _ _ ->
mk theiruuid k af noRetry ta noNotification mk theiruuid k af sd noRetry ta noNotification
-- Transfer logs are updated higher in the stack when -- Transfer logs are updated higher in the stack when
-- a client. -- a client.
Client _ -> ta nullMeterUpdate Client _ -> ta nullMeterUpdate

4
Remote/Git.hs
View file

@ -543,7 +543,7 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest met
Just (object, checksuccess) -> do Just (object, checksuccess) -> do
copier <- mkCopier hardlink st params copier <- mkCopier hardlink st params
(ok, v) <- runTransfer (Transfer Download u (fromKey id key)) (ok, v) <- runTransfer (Transfer Download u (fromKey id key))
file stdRetry $ \p -> file Nothing stdRetry $ \p ->
metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' -> metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' ->
copier object dest p' checksuccess copier object dest p' checksuccess
if ok if ok
@ -688,7 +688,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate
-- run copy from perspective of remote -- run copy from perspective of remote
res <- onLocalFast st $ ifM (Annex.Content.inAnnex key) res <- onLocalFast st $ ifM (Annex.Content.inAnnex key)
( return True ( return True
, runTransfer (Transfer Download u (fromKey id key)) file stdRetry $ \p -> do , runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> do
copier <- mkCopier hardlink st params copier <- mkCopier hardlink st params
let verify = Annex.Content.RemoteVerify r let verify = Annex.Content.RemoteVerify r
let rsp = RetrievalAllKeysSecure let rsp = RetrievalAllKeysSecure

3
Types/StallDetection.hs
View file

@ -19,6 +19,7 @@ data StallDetection
| ProbeStallDetection | ProbeStallDetection
-- ^ Used when unsure how frequently transfer progress is updated, -- ^ Used when unsure how frequently transfer progress is updated,
-- or how fast data can be sent. -- or how fast data can be sent.
| StallDetectionDisabled
deriving (Show) deriving (Show)
-- Parse eg, "0KiB/60s" -- Parse eg, "0KiB/60s"
@ -38,4 +39,4 @@ parseStallDetection s = case isTrueFalse s of
d <- parseDuration ds d <- parseDuration ds
return (Just (StallDetection b d)) return (Just (StallDetection b d))
Just True -> Right (Just ProbeStallDetection) Just True -> Right (Just ProbeStallDetection)
Just False -> Right Nothing Just False -> Right (Just StallDetectionDisabled)

20
doc/git-annex.mdwn
View file

@ -1422,16 +1422,20 @@ Remotes are configured using these settings in `.git/config`.
* `remote.<name>.annex-stalldetecton`, `annex.stalldetection` * `remote.<name>.annex-stalldetecton`, `annex.stalldetection`
This lets stalled or too-slow transfers be detected, and dealt with, so Configuring this lets stalled or too-slow transfers be detected, and
rather than getting stuck, git-annex will cancel the stalled operation. dealt with, so rather than getting stuck, git-annex will cancel the
When this happens, the transfer will be considered to have failed, so stalled operation. The transfer will be considered to have failed, so
settings like annex.retry will control what it does next. settings like annex.retry will control what it does next.
Set to "true" to enable automatic stall detection. With this setting, By default, git-annex detects transfers that have probably stalled,
if a remote does not update its progress consistently, no stall detection and suggests configuring this. If it is incorrectly detecting
will be done. And it may take a while for git-annex to decide a remote stalls, setting this to "false" will avoid that.
is really stalled when using automatic stall detection, since it needs
to be conservative about what looks like a stall. Set to "true" to enable automatic stall detection. If a remote does not
update its progress consistently, no automatic stall detection will be
done. And it may take a while for git-annex to decide a remote is really
stalled when using automatic stall detection, since it needs to be
conservative about what looks like a stall.
For more fine control over what constitutes a stall, set to a value in For more fine control over what constitutes a stall, set to a value in
the form "$amount/$timeperiod" to specify how much data git-annex should the form "$amount/$timeperiod" to specify how much data git-annex should

2
doc/todo/dynamic_stall_detection.mdwn
View file

@ -20,3 +20,5 @@ gets it wrong and the remote does not support resuming transfers,
defaulting to on could lead to bad waste of resources. It could defaulting to on could lead to bad waste of resources. It could
detect stalls even when not turned on, but only display a message detect stalls even when not turned on, but only display a message
suggesting enabling the config. --[[Joey]] suggesting enabling the config. --[[Joey]]
> [[done]] --[[Joey]]