git-annex 8.20210127 → 8.20210223

raw patch · 82 files changed

+1232/−698 lines, 82 files

Files

• Annex.hs +1/−1
• Annex/Concurrent.hs +0/−120
• Annex/Content/Presence.hs +1/−14
• Annex/Import.hs +2/−2
• Annex/Ingest.hs +14/−8
• Annex/StallDetection.hs +83/−0
• Annex/Transfer.hs +77/−40
• Annex/TransferrerPool.hs +2/−26
• Annex/Verify.hs +25/−0
• Annex/YoutubeDl.hs +1/−1
• Assistant/Threads/Committer.hs +1/−1
• Assistant/Threads/Watcher.hs +1/−1
• Assistant/WebApp/Configurators/AWS.hs +1/−1
• Assistant/WebApp/Configurators/Local.hs +1/−1
• Assistant/WebApp/DashBoard.hs +1/−1
• Assistant/WebApp/Gpg.hs +1/−1
• Backend.hs +14/−1
• Backend/External.hs +2/−0
• Backend/Hash.hs +80/−60
• Backend/URL.hs +1/−0
• Backend/WORM.hs +1/−0
• Benchmark.hs +1/−2
• Build/Mans.hs +3/−1
• Build/TestConfig.hs +1/−1
• CHANGELOG +37/−0
• CmdLine.hs +92/−25
• CmdLine/Action.hs +11/−0
• CmdLine/GitAnnex.hs +6/−3
• CmdLine/GitAnnexShell.hs +7/−4
• CmdLine/GlobalSetter.hs +4/−3
• Command.hs +1/−1
• Command/Add.hs +1/−0
• Command/AddUrl.hs +2/−2
• Command/Assistant.hs +1/−1
• Command/Export.hs +1/−1
• Command/Get.hs +3/−3
• Command/Import.hs +1/−1
• Command/Map.hs +2/−2
• Command/SendKey.hs +1/−1
• Command/TransferKey.hs +2/−2
• Command/TransferKeys.hs +2/−2
• Command/Transferrer.hs +8/−6
• Command/Unannex.hs +27/−13
• Git/Construct.hs +21/−22
• Git/CurrentRepo.hs +3/−2
• Git/LsTree.hs +7/−4
• Git/Repair.hs +1/−1
• Logs/Export.hs +7/−5
• Logs/Transfer.hs +17/−15
• P2P/Annex.hs +51/−15
• P2P/IO.hs +1/−1
• P2P/Protocol.hs +19/−17
• Remote/BitTorrent.hs +4/−1
• Remote/Bup.hs +3/−3
• Remote/Git.hs +157/−72
• Remote/Glacier.hs +2/−1
• Remote/Helper/Chunked.hs +86/−18
• Remote/Helper/Chunked/Legacy.hs +2/−1
• Remote/Helper/P2P.hs +6/−4
• Remote/Helper/Special.hs +2/−60
• Remote/P2P.hs +2/−1
• Remote/Tahoe.hs +3/−1
• Types/Backend.hs +17/−4
• Types/Command.hs +8/−1
• Types/GitConfig.hs +2/−2
• Types/Remote.hs +3/−1
• Types/StallDetection.hs +22/−9
• Utility/Batch.hs +1/−1
• Utility/DirWatcher/Kqueue.hs +1/−1
• Utility/Gpg.hs +2/−2
• Utility/Hash.hs +98/−1
• Utility/MagicWormhole.hs +1/−1
• Utility/Matcher.hs +63/−24
• Utility/Metered.hs +9/−8
• Utility/Path.hs +46/−29
• Utility/Shell.hs +3/−3
• Utility/Su.hs +1/−1
• Utility/Tor.hs +1/−1
• Utility/libkqueue.h +3/−0
• doc/git-annex-import.mdwn +5/−3
• doc/git-annex.mdwn +23/−7
• git-annex.cabal +5/−2

@@ -247,7 +247,7 @@  - any necessary git repo fixups. -} new :: Git.Repo -> IO AnnexState new r = do-	r' <- Git.Config.read =<< Git.relPath r+	r' <- Git.Config.read r 	let c = extractGitConfig FromGitConfig r' 	newState c =<< fixupRepo r' c 

@@ -16,14 +16,10 @@ import qualified Annex.Queue import Annex.Action import Types.Concurrency-import Types.WorkerPool import Types.CatFileHandles import Annex.CheckAttr import Annex.CheckIgnore-import Remote.List -import Control.Concurrent-import Control.Concurrent.STM import qualified Data.Map as M  setConcurrency :: ConcurrencySetting -> Annex ()@@ -75,11 +71,6 @@  -} dupState :: Annex AnnexState 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 	-- Make sure that concurrency is enabled, if it was not already, 	-- so the concurrency-safe resource pools are set up.@@ -104,114 +95,3 @@ 		uncurry addCleanupAction 	Annex.Queue.mergeFrom st' 	changeState $ \s -> s { errcounter = errcounter s + errcounter st' }--{- Runs an action and makes the current thread have the specified stage- - while doing so. If too many other threads are running in the specified- - stage, waits for one of them to become idle.- -- - Noop if the current thread already has the requested stage, or if the- - current thread is not in the worker pool, or if concurrency is not- - enabled.- -- - Also a noop if the stage is not one of the stages that the worker pool- - uses.- -}-enteringStage :: WorkerStage -> Annex a -> Annex a-enteringStage newstage a = Annex.getState Annex.workers >>= \case-	Nothing -> a-	Just tv -> do-		mytid <- liftIO myThreadId-		let set = changeStageTo mytid tv (const newstage)-		let restore = maybe noop (void . changeStageTo mytid tv . const)-		bracket set restore (const a)--{- Transition the current thread to the initial stage.- - This is done once the thread is ready to begin work.- -}-enteringInitialStage :: Annex ()-enteringInitialStage = Annex.getState Annex.workers >>= \case-	Nothing -> noop-	Just tv -> do-		mytid <- liftIO myThreadId-		void $ changeStageTo mytid tv initialStage--{- This needs to leave the WorkerPool with the same number of- - idle and active threads, and with the same number of threads for each- - WorkerStage. So, all it can do is swap the WorkerStage of our thread's- - ActiveWorker with an IdleWorker.- -- - Must avoid a deadlock if all worker threads end up here at the same- - time, or if there are no suitable IdleWorkers left. So if necessary- - we first replace our ActiveWorker with an IdleWorker in the pool, to allow- - some other thread to use it, before waiting for a suitable IdleWorker- - for us to use.- -- - Note that the spareVals in the WorkerPool does not get anything added to- - it when adding the IdleWorker, so there will for a while be more IdleWorkers- - in the pool than spareVals. That does not prevent other threads that call- - this from using them though, so it's fine.- -}-changeStageTo :: ThreadId -> TMVar (WorkerPool AnnexState) -> (UsedStages -> WorkerStage) -> Annex (Maybe WorkerStage)-changeStageTo mytid tv getnewstage = liftIO $-	replaceidle >>= maybe-		(return Nothing)-		(either waitidle (return . Just))-  where-	replaceidle = atomically $ do-		pool <- takeTMVar tv-		let newstage = getnewstage (usedStages pool)-		let notchanging = do-			putTMVar tv pool-			return Nothing-		if memberStage newstage (usedStages pool)-			then case removeThreadIdWorkerPool mytid pool of-				Just ((myaid, oldstage), pool')-					| oldstage /= newstage -> case getIdleWorkerSlot newstage pool' of-						Nothing -> do-							putTMVar tv $-								addWorkerPool (IdleWorker oldstage) pool'-							return $ Just $ Left (myaid, newstage, oldstage)-						Just pool'' -> do-							-- optimisation-							putTMVar tv $-								addWorkerPool (IdleWorker oldstage) $-									addWorkerPool (ActiveWorker myaid newstage) pool''-							return $ Just $ Right oldstage-					| otherwise -> notchanging-				_ -> notchanging-			else notchanging-	-	waitidle (myaid, newstage, oldstage) = atomically $ do-		pool <- waitIdleWorkerSlot newstage =<< takeTMVar tv-		putTMVar tv $ addWorkerPool (ActiveWorker myaid newstage) pool-		return (Just oldstage)---- | Waits until there's an idle StartStage worker in the worker pool,--- removes it from the pool, and returns its state.------ If the worker pool is not already allocated, returns Nothing.-waitStartWorkerSlot :: TMVar (WorkerPool Annex.AnnexState) -> STM (Maybe (Annex.AnnexState, WorkerStage))-waitStartWorkerSlot tv = do-	pool <- takeTMVar tv-	st <- go pool-	return $ Just (st, StartStage)-  where-	go pool = case spareVals pool of-		[] -> retry-		(v:vs) -> do-			let pool' = pool { spareVals = vs }-			putTMVar tv =<< waitIdleWorkerSlot StartStage pool'-			return v--waitIdleWorkerSlot :: WorkerStage -> WorkerPool Annex.AnnexState -> STM (WorkerPool Annex.AnnexState)-waitIdleWorkerSlot wantstage = maybe retry return . getIdleWorkerSlot wantstage--getIdleWorkerSlot :: WorkerStage -> WorkerPool Annex.AnnexState -> Maybe (WorkerPool Annex.AnnexState)-getIdleWorkerSlot wantstage pool = do-	l <- findidle [] (workerList pool)-	return $ pool { workerList = l }-  where-	findidle _ [] = Nothing-	findidle c ((IdleWorker stage):rest)-		| stage == wantstage = Just (c ++ rest)-	findidle c (w:rest) = findidle (w:c) rest

@@ -26,10 +26,10 @@  import Annex.Common import qualified Annex+import Annex.Verify import Annex.LockPool import Annex.WorkerPool import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..))-import qualified Types.Remote import qualified Types.Backend import qualified Backend import qualified Database.Keys@@ -231,16 +231,3 @@ 	]   where 	kv = decodeBS (formatKeyVariety (fromKey keyVariety k))--data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify--shouldVerify :: VerifyConfig -> Annex Bool-shouldVerify AlwaysVerify = return True-shouldVerify NoVerify = return False-shouldVerify DefaultVerify = annexVerify <$> Annex.getGitConfig-shouldVerify (RemoteVerify r) = -	(shouldVerify DefaultVerify-			<&&> pure (remoteAnnexVerify (Types.Remote.gitconfig r)))-	-- Export remotes are not key/value stores, so always verify-	-- content from them even when verification is disabled.-	<||> Types.Remote.isExportSupported r

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

@@ -329,18 +329,24 @@  {- Whether a file should be added unlocked or not. Default is to not,  - unless symlinks are not supported. annex.addunlocked can override that.- - Also, when in an adjusted unlocked branch, always add files unlocked.+ - Also, when in an adjusted branch that unlocked files, always add files+ - unlocked.  -}-addUnlocked :: AddUnlockedMatcher -> MatchInfo -> Annex Bool-addUnlocked matcher mi =+addUnlocked :: AddUnlockedMatcher -> MatchInfo -> Bool -> Annex Bool+addUnlocked matcher mi contentpresent = 	((not . coreSymlinks <$> Annex.getGitConfig) <||> 	 (checkAddUnlockedMatcher matcher mi) <||>-	 (maybe False isadjustedunlocked . snd <$> getCurrentBranch)+	 (maybe False go . snd <$> getCurrentBranch) 	)   where-	isadjustedunlocked (LinkAdjustment UnlockAdjustment) = True-	isadjustedunlocked (PresenceAdjustment _ (Just UnlockAdjustment)) = True-	isadjustedunlocked _ = False+	go (LinkAdjustment UnlockAdjustment) = True+	go (LinkAdjustment LockAdjustment) = False+	go (LinkAdjustment FixAdjustment) = False+	go (LinkAdjustment UnFixAdjustment) = False+	go (PresenceAdjustment _ (Just la)) = go (LinkAdjustment la)+	go (PresenceAdjustment _ Nothing) = False+	go (LinkPresentAdjustment UnlockPresentAdjustment) = contentpresent+	go (LinkPresentAdjustment LockPresentAdjustment) = False  {- Adds a file to the work tree for the key, and stages it in the index.  - The content of the key may be provided in a temp file, which will be@@ -350,7 +356,7 @@  - When the content of the key is not accepted into the annex, returns False.  -} addAnnexedFile :: CheckGitIgnore -> AddUnlockedMatcher -> RawFilePath -> Key -> Maybe RawFilePath -> Annex Bool-addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi)+addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi (isJust mtmp)) 	( do 		mode <- maybe 			(pure Nothing)

@@ -0,0 +1,83 @@+{- Stall detection for transfers.+ -+ - Copyright 2020-2021 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.StallDetection (detectStalls, StallDetection) where++import Annex.Common+import Types.StallDetection+import Utility.Metered+import Utility.HumanTime+import Utility.DataUnits+import Utility.ThreadScheduler++import Control.Concurrent.STM+import Control.Monad.IO.Class (MonadIO)++{- 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 (Just StallDetectionDisabled) _ _ = noop+detectStalls (Just (StallDetection minsz duration)) metervar onstall =+	detectStalls' minsz duration metervar onstall Nothing+detectStalls (Just ProbeStallDetection) metervar onstall = do+	-- Only do stall detection once the progress is confirmed to be+	-- consistently updating. After the first update, it needs to+	-- advance twice within 30 seconds. With that established,+	-- if no data at all is sent for a 60 second period, it's+	-- assumed to be a stall.+	v <- getval >>= waitforfirstupdate+	ontimelyadvance v $ \v' -> ontimelyadvance v' $+		detectStalls' 1 duration metervar onstall+  where+	getval = liftIO $ atomically $ fmap fromBytesProcessed+		<$> readTVar metervar+	+	duration = Duration 60++	delay = Seconds (fromIntegral (durationSeconds duration) `div` 2)+	+	waitforfirstupdate startval = do+		liftIO $ threadDelaySeconds delay+		v <- getval+		if v > startval+			then return v+			else waitforfirstupdate startval++	ontimelyadvance v cont = do+		liftIO $ threadDelaySeconds delay+		v' <- getval+		when (v' > v) $+			cont v'++detectStalls'+	:: (Monad m, MonadIO m)+	=> ByteSize+	-> Duration+	-> TVar (Maybe BytesProcessed)+	-> m ()+	-> Maybe ByteSize+	-> m ()+detectStalls' minsz duration metervar onstall st = do+	liftIO $ threadDelaySeconds delay+	-- Get whatever progress value was reported most recently, if any.+	v <- liftIO $ atomically $ fmap fromBytesProcessed+		<$> readTVar metervar+	let cont = detectStalls' minsz duration metervar onstall v+	case (st, v) of+		(Nothing, _) -> cont+		(_, Nothing) -> cont+		(Just prev, Just sofar)+			-- Just in case a progress meter somehow runs+			-- backwards, or a second progress meter was+			-- started and is at a smaller value than+			-- the previous one.+			| prev > sofar -> cont+			| sofar - prev < minsz -> onstall+			| otherwise -> cont+  where+	delay = Seconds (fromIntegral (durationSeconds duration))

@@ -1,6 +1,6 @@ {- 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.  -}@@ -37,50 +37,56 @@ import Types.Key import qualified Types.Remote as Remote import Types.Concurrency-import Annex.Concurrent.Utility+import Annex.Concurrent import Types.WorkerPool import Annex.WorkerPool import Annex.TransferrerPool+import Annex.StallDetection import Backend (isCryptographicallySecure) import Types.StallDetection import qualified Utility.RawFilePath as R  import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM hiding (retry) import qualified Data.Map.Strict as M import qualified System.FilePath.ByteString as P import Data.Ord --- Upload, supporting stall detection.+-- Upload, supporting canceling detected stalls. upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool 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   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' :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v-upload' u key f d a _witness = guardHaveUUID u $ -	runTransfer (Transfer Upload u (fromKey id key)) f d a+-- Upload, not supporting canceling detected stalls+upload' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v+upload' u key f sd d a _witness = guardHaveUUID u $ +	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 u key f d a _witness = guardHaveUUID u $ -	alwaysRunTransfer (Transfer Upload u (fromKey id key)) f d a+alwaysUpload :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v+alwaysUpload u key f sd d a _witness = guardHaveUUID u $ +	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 r key f d witness = logStatusAfter key $ stallDetection r >>= \case-	Nothing -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key f $ \dest ->-		download' (Remote.uuid r) key f d (go dest) witness+	Nothing -> go (Just ProbeStallDetection)+	Just StallDetectionDisabled -> go Nothing 	Just sd -> runTransferrer sd r key f d Download witness   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 --- Download, not supporting stall detection.-download' :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v-download' u key f d a _witness = guardHaveUUID u $-	runTransfer (Transfer Download u (fromKey id key)) f d a+-- Download, not supporting canceling detected stalls.+download' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v+download' u key f sd d a _witness = guardHaveUUID u $+	runTransfer (Transfer Download u (fromKey id key)) f sd d a  guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v guardHaveUUID u a@@ -98,34 +104,44 @@  -  - An upload can be run from a read-only filesystem, and in this case  - 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  {- Like runTransfer, but ignores any existing transfer lock file for the  - 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 -runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v-runTransfer' ignorelock t afile retrydecider transferaction = enteringStage TransferStage $ debugLocks $ preCheckSecureHashes (transferKey t) $ 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 (transferaction meter)-			liftIO $ cleanup tfile lck-			if observeBool v-				then removeFailedTransfer t-				else recordFailedTransfer t info-			return v+runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v+runTransfer' ignorelock t afile stalldetection retrydecider transferaction =+	enteringStage TransferStage $+		debugLocks $+			preCheckSecureHashes (transferKey t) go   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) #ifndef mingw32_HOST_OS 	prep tfile createtfile mode = catchPermissionDenied (const prepfailed) $ do@@ -191,11 +207,32 @@  	getbytescomplete metervar 		| transferDirection t == Upload =-			liftIO $ readMVar metervar+			liftIO $ maybe 0 fromBytesProcessed +				<$> readTVarIO metervar 		| otherwise = do 			f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t) 			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 	:: StallDetection 	-> Remote

@@ -1,6 +1,6 @@ {- A pool of "git-annex transferrer" processes  -- - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ - Copyright 2013-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -16,15 +16,13 @@ import Types.Transferrer import Types.Transfer import qualified Types.Remote as Remote-import Types.StallDetection import Types.Messages import Types.CleanupActions import Messages.Serialized import Annex.Path+import Annex.StallDetection import Utility.Batch import Utility.Metered-import Utility.HumanTime-import Utility.ThreadScheduler import qualified Utility.SimpleProtocol as Proto  import Control.Concurrent@@ -176,28 +174,6 @@ 		atomically $ writeTVar bpv n 	updatemeter _bpv metervar Nothing = liftIO $ 		atomically $ writeTVar metervar Nothing--detectStalls :: Maybe StallDetection -> TVar (Maybe BytesProcessed) -> IO () -> IO ()-detectStalls Nothing _ _ = noop-detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothing-  where-	go st = do-		threadDelaySeconds (Seconds (fromIntegral (durationSeconds duration)))-		-- Get whatever progress value was reported last, if any.-		v <- atomically $ fmap fromBytesProcessed-			<$> readTVar metervar-		let cont = go v-		case (st, v) of-			(Nothing, _) -> cont-			(_, Nothing) -> cont-			(Just prev, Just sofar)-				-- Just in case a progress meter somehow runs-				-- backwards, or a second progress meter was-				-- started and is at a smaller value than-				-- the previous one.-				| prev > sofar -> cont-				| sofar - prev < minsz -> onstall-				| otherwise -> cont  {- Starts a new git-annex transfer process, setting up handles  - that will be used to communicate with it. -}

@@ -0,0 +1,25 @@+{- verification+ -+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.Verify where++import Annex.Common+import qualified Annex+import qualified Types.Remote++data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify++shouldVerify :: VerifyConfig -> Annex Bool+shouldVerify AlwaysVerify = return True+shouldVerify NoVerify = return False+shouldVerify DefaultVerify = annexVerify <$> Annex.getGitConfig+shouldVerify (RemoteVerify r) = +	(shouldVerify DefaultVerify+			<&&> pure (remoteAnnexVerify (Types.Remote.gitconfig r)))+	-- Export remotes are not key/value stores, so always verify+	-- content from them even when verification is disabled.+	<||> Types.Remote.isExportSupported r

@@ -68,7 +68,7 @@  youtubeDl' :: URLString -> FilePath -> MeterUpdate -> UrlOptions -> Annex (Either String (Maybe FilePath)) youtubeDl' url workdir p uo-	| supportedScheme uo url = ifM (liftIO $ inPath "youtube-dl")+	| supportedScheme uo url = ifM (liftIO $ inSearchPath "youtube-dl") 		( runcmd >>= \case 			Right True -> workdirfiles >>= \case 				(f:[]) -> return (Right (Just f))

@@ -49,7 +49,7 @@ {- This thread makes git commits at appropriate times. -} commitThread :: NamedThread commitThread = namedThread "Committer" $ do-	havelsof <- liftIO $ inPath "lsof"+	havelsof <- liftIO $ inSearchPath "lsof" 	delayadd <- liftAnnex $ 		fmap Seconds . annexDelayAdd <$> Annex.getGitConfig 	msg <- liftAnnex Command.Sync.commitMsg

@@ -58,7 +58,7 @@ 	| canWatch = do #ifndef mingw32_HOST_OS 		liftIO Lsof.setup-		unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force)+		unlessM (liftIO (inSearchPath "lsof") <||> Annex.getState Annex.force) 			needLsof #else 		noop

@@ -34,7 +34,7 @@  glacierConfigurator :: Widget -> Handler Html glacierConfigurator a = do-	ifM (liftIO $ inPath "glacier")+	ifM (liftIO $ inSearchPath "glacier") 		( awsConfigurator a 		, awsConfigurator needglaciercli 		)

@@ -164,7 +164,7 @@ getFirstRepositoryR = postFirstRepositoryR postFirstRepositoryR :: Handler Html postFirstRepositoryR = page "Getting started" (Just Configuration) $ do-	unlessM (liftIO $ inPath "git") $+	unlessM (liftIO $ inSearchPath "git") $ 		giveup "You need to install git in order to use git-annex!" 	androidspecial <- liftIO osAndroid 	path <- liftIO . defaultRepositoryPath =<< liftH inFirstRun

@@ -134,7 +134,7 @@ 	let p = proc cmd [path] #endif #endif-	ifM (liftIO $ inPath cmd)+	ifM (liftIO $ inSearchPath cmd) 		( do 			let run = void $ liftIO $ forkIO $ do 				withCreateProcess p $ \_ _ _ pid -> void $

@@ -41,7 +41,7 @@ genKeyModal = $(widgetFile "configurators/genkeymodal")  isGcryptInstalled :: IO Bool-isGcryptInstalled = inPath "git-remote-gcrypt"+isGcryptInstalled = inSearchPath "git-remote-gcrypt"  whenGcryptInstalled :: Handler Html -> Handler Html whenGcryptInstalled a = ifM (liftIO isGcryptInstalled)

@@ -1,6 +1,6 @@ {- git-annex key/value backends  -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -17,11 +17,13 @@ 	isStableKey, 	isCryptographicallySecure, 	isVerifiable,+	startVerifyKeyContentIncrementally, ) where  import Annex.Common import qualified Annex import Annex.CheckAttr+import Annex.Verify import Types.Key import Types.KeySource import qualified Types.Backend as B@@ -127,3 +129,14 @@ isVerifiable :: Key -> Annex Bool isVerifiable k = maybe False (isJust . B.verifyKeyContent)  	<$> maybeLookupBackendVariety (fromKey keyVariety k)++startVerifyKeyContentIncrementally :: VerifyConfig -> Key -> Annex (Maybe B.IncrementalVerifier)+startVerifyKeyContentIncrementally verifyconfig k = +	ifM (shouldVerify verifyconfig)+		( maybeLookupBackendVariety (fromKey keyVariety k) >>= \case+			Just b -> case B.verifyKeyContentIncrementally b of+				Just v -> Just <$> v k+				Nothing -> return Nothing+			Nothing -> return Nothing+		, return Nothing+		)

@@ -67,6 +67,7 @@ 				-- bump if progress handling is later added. 				nullMeterUpdate 			else Nothing+		, verifyKeyContentIncrementally = Nothing 		, canUpgradeKey = Nothing 		, fastMigrate = Nothing 		, isStableKey = const isstable@@ -80,6 +81,7 @@ 		{ backendVariety = ExternalKey bname hasext 		, genKey = Nothing 		, verifyKeyContent = Nothing+		, verifyKeyContentIncrementally = Nothing 		, canUpgradeKey = Nothing 		, fastMigrate = Nothing 		, isStableKey = const False

@@ -1,6 +1,6 @@ {- git-annex hashing backends  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -28,6 +28,7 @@ import qualified Data.ByteString.Lazy as L import Control.DeepSeq import Control.Exception (evaluate)+import Data.IORef  data Hash 	= MD5Hash@@ -75,6 +76,7 @@ 	{ backendVariety = hashKeyVariety hash (HasExt False) 	, genKey = Just (keyValue hash) 	, verifyKeyContent = Just $ checkKeyChecksum hash+	, verifyKeyContentIncrementally = Just $ checkKeyChecksumIncremental hash 	, canUpgradeKey = Just needsUpgrade 	, fastMigrate = Just trivialMigrate 	, isStableKey = const True@@ -116,8 +118,6 @@ 	keyValue hash source meterupdate 		>>= addE source (const $ hashKeyVariety hash (HasExt True)) -{- A key's checksum is checked during fsck when it's content is present- - except for in fast mode. -} checkKeyChecksum :: Hash -> Key -> RawFilePath -> Annex Bool checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do 	fast <- Annex.getState Annex.fast@@ -125,22 +125,28 @@ 	case (exists, fast) of 		(True, False) -> do 			showAction "checksum"-			check <$> hashFile hash file nullMeterUpdate+			sameCheckSum key +				<$> hashFile hash file nullMeterUpdate 		_ -> return True   where-	expected = decodeBS (keyHash key)-	check s-		| s == expected = True-		{- A bug caused checksums to be prefixed with \ in some-		 - cases; still accept these as legal now that the bug has been-		 - fixed. -}-		| '\\' : s == expected = True-		| otherwise = False- 	hwfault e = do 		warning $ "hardware fault: " ++ show e 		return False +sameCheckSum :: Key -> String -> Bool+sameCheckSum key s+	| s == expected = True+	{- A bug caused checksums to be prefixed with \ in some+	 - cases; still accept these as legal now that the bug+	 - has been fixed. -}+	| '\\' : s == expected = True+	| otherwise = False+  where+	expected = decodeBS (keyHash key)++checkKeyChecksumIncremental :: Hash -> Key -> Annex IncrementalVerifier+checkKeyChecksumIncremental hash key = liftIO $ (snd $ hasher hash) key+ keyHash :: Key -> S.ByteString keyHash = fst . splitKeyNameExtension @@ -195,79 +201,93 @@ hashFile :: Hash -> RawFilePath -> MeterUpdate -> Annex String hashFile hash file meterupdate =  	liftIO $ withMeteredFile (fromRawFilePath file) meterupdate $ \b -> do-		let h = hasher b+		let h = (fst $ hasher hash) b 		-- Force full evaluation of hash so whole file is read 		-- before returning. 		evaluate (rnf h) 		return h-  where-	hasher = case hash of-		MD5Hash -> md5Hasher-		SHA1Hash -> sha1Hasher-		SHA2Hash hashsize -> sha2Hasher hashsize-		SHA3Hash hashsize -> sha3Hasher hashsize-		SkeinHash hashsize -> skeinHasher hashsize-		Blake2bHash hashsize -> blake2bHasher hashsize-		Blake2bpHash hashsize -> blake2bpHasher hashsize-		Blake2sHash hashsize -> blake2sHasher hashsize-		Blake2spHash hashsize -> blake2spHasher hashsize -sha2Hasher :: HashSize -> (L.ByteString -> String)+type Hasher = (L.ByteString -> String, Key -> IO IncrementalVerifier)++hasher :: Hash -> Hasher+hasher MD5Hash = md5Hasher+hasher SHA1Hash = sha1Hasher+hasher (SHA2Hash hashsize) = sha2Hasher hashsize+hasher (SHA3Hash hashsize) = sha3Hasher hashsize+hasher (SkeinHash hashsize) = skeinHasher hashsize+hasher (Blake2bHash hashsize) = blake2bHasher hashsize+hasher (Blake2bpHash hashsize) = blake2bpHasher hashsize+hasher (Blake2sHash hashsize) = blake2sHasher hashsize+hasher (Blake2spHash hashsize) = blake2spHasher hashsize++mkHasher :: HashAlgorithm h => (L.ByteString -> Digest h) -> Context h -> Hasher+mkHasher h c = (show . h, mkIncrementalVerifier c)++sha2Hasher :: HashSize -> Hasher sha2Hasher (HashSize hashsize)-	| hashsize == 256 = use sha2_256-	| hashsize == 224 = use sha2_224-	| hashsize == 384 = use sha2_384-	| hashsize == 512 = use sha2_512-	| otherwise = error $ "unsupported SHA size " ++ show hashsize-  where-	use hasher = show . hasher+	| hashsize == 256 = mkHasher sha2_256 sha2_256_context+	| hashsize == 224 = mkHasher sha2_224 sha2_224_context+	| hashsize == 384 = mkHasher sha2_384 sha2_384_context+	| hashsize == 512 = mkHasher sha2_512 sha2_512_context+	| otherwise = error $ "unsupported SHA2 size " ++ show hashsize -sha3Hasher :: HashSize -> (L.ByteString -> String)+sha3Hasher :: HashSize -> Hasher sha3Hasher (HashSize hashsize)-	| hashsize == 256 = show . sha3_256-	| hashsize == 224 = show . sha3_224-	| hashsize == 384 = show . sha3_384-	| hashsize == 512 = show . sha3_512+	| hashsize == 256 = mkHasher sha3_256 sha3_256_context+	| hashsize == 224 = mkHasher sha3_224 sha3_224_context+	| hashsize == 384 = mkHasher sha3_384 sha3_384_context+	| hashsize == 512 = mkHasher sha3_512 sha3_512_context 	| otherwise = error $ "unsupported SHA3 size " ++ show hashsize -skeinHasher :: HashSize -> (L.ByteString -> String)+skeinHasher :: HashSize -> Hasher skeinHasher (HashSize hashsize)-	| hashsize == 256 = show . skein256-	| hashsize == 512 = show . skein512+	| hashsize == 256 = mkHasher skein256 skein256_context+	| hashsize == 512 = mkHasher skein512 skein512_context 	| otherwise = error $ "unsupported SKEIN size " ++ show hashsize -blake2bHasher :: HashSize -> (L.ByteString -> String)+blake2bHasher :: HashSize -> Hasher blake2bHasher (HashSize hashsize)-	| hashsize == 256 = show . blake2b_256-	| hashsize == 512 = show . blake2b_512-	| hashsize == 160 = show . blake2b_160-	| hashsize == 224 = show . blake2b_224-	| hashsize == 384 = show . blake2b_384+	| hashsize == 256 = mkHasher blake2b_256 blake2b_256_context+	| hashsize == 512 = mkHasher blake2b_512 blake2b_512_context+	| hashsize == 160 = mkHasher blake2b_160 blake2b_160_context+	| hashsize == 224 = mkHasher blake2b_224 blake2b_224_context+	| hashsize == 384 = mkHasher blake2b_384 blake2b_384_context 	| otherwise = error $ "unsupported BLAKE2B size " ++ show hashsize -blake2bpHasher :: HashSize -> (L.ByteString -> String)+blake2bpHasher :: HashSize -> Hasher blake2bpHasher (HashSize hashsize)-	| hashsize == 512 = show . blake2bp_512+	| hashsize == 512 = mkHasher blake2bp_512 blake2bp_512_context 	| otherwise = error $ "unsupported BLAKE2BP size " ++ show hashsize -blake2sHasher :: HashSize -> (L.ByteString -> String)+blake2sHasher :: HashSize -> Hasher blake2sHasher (HashSize hashsize)-	| hashsize == 256 = show . blake2s_256-	| hashsize == 160 = show . blake2s_160-	| hashsize == 224 = show . blake2s_224+	| hashsize == 256 = mkHasher blake2s_256 blake2s_256_context+	| hashsize == 160 = mkHasher blake2s_160 blake2s_160_context+	| hashsize == 224 = mkHasher blake2s_224 blake2s_224_context 	| otherwise = error $ "unsupported BLAKE2S size " ++ show hashsize -blake2spHasher :: HashSize -> (L.ByteString -> String)+blake2spHasher :: HashSize -> Hasher blake2spHasher (HashSize hashsize)-	| hashsize == 256 = show . blake2sp_256-	| hashsize == 224 = show . blake2sp_224+	| hashsize == 256 = mkHasher blake2sp_256 blake2sp_256_context+	| hashsize == 224 = mkHasher blake2sp_224 blake2sp_224_context 	| otherwise = error $ "unsupported BLAKE2SP size " ++ show hashsize -sha1Hasher :: L.ByteString -> String-sha1Hasher = show . sha1+sha1Hasher :: Hasher+sha1Hasher = mkHasher sha1 sha1_context -md5Hasher :: L.ByteString -> String-md5Hasher = show . md5+md5Hasher :: Hasher+md5Hasher = mkHasher md5 md5_context++mkIncrementalVerifier :: HashAlgorithm h => Context h -> Key -> IO IncrementalVerifier+mkIncrementalVerifier ctx key = do+	v <- newIORef ctx+	return $ IncrementalVerifier+		{ updateIncremental = modifyIORef' v . flip hashUpdate+		, finalizeIncremental = do+			ctx' <- readIORef v+			let digest = hashFinalize ctx'+			return $ sameCheckSum key (show digest)+		}  {- A varient of the SHA256E backend, for testing that needs special keys  - that cannot collide with legitimate keys in the repository.

@@ -23,6 +23,7 @@ 	{ backendVariety = URLKey 	, genKey = Nothing 	, verifyKeyContent = Nothing+	, verifyKeyContentIncrementally = Nothing 	, canUpgradeKey = Nothing 	, fastMigrate = Nothing 	-- The content of an url can change at any time, so URL keys are

@@ -26,6 +26,7 @@ 	{ backendVariety = WORMKey 	, genKey = Just keyValue 	, verifyKeyContent = Nothing+	, verifyKeyContentIncrementally = Nothing 	, canUpgradeKey = Just needsUpgrade 	, fastMigrate = Just removeProblemChars 	, isStableKey = const True

@@ -12,7 +12,6 @@ import Types.Command import CmdLine.Action import CmdLine-import CmdLine.GitAnnex.Options import qualified Annex import qualified Annex.Branch @@ -39,7 +38,7 @@ 	-- matching or out-of-repo commands. 	parsesubcommand ps = do 		(cmd, seek, globalconfig) <- liftIO $ O.handleParseResult $-			parseCmd "git-annex" "benchmarking" gitAnnexGlobalOptions ps cmds cmdparser+			parseCmd "git-annex" "benchmarking" ps cmds cmdparser 		-- Make an entirely separate Annex state for each subcommand, 		-- and prepare it to run the cmd. 		st <- liftIO . Annex.new =<< Annex.getState Annex.repo

@@ -38,7 +38,9 @@ 		if (Just srcm > destm) 			then do 				r <- system $ unwords-					[ "./Build/mdwn2man"+					-- Run with per because in some+					-- cases it may not be executable.+					[ "perl", "./Build/mdwn2man" 					, progName src 					, "1" 					, src

@@ -97,7 +97,7 @@  - the command. -} findCmdPath :: ConfigKey -> String -> Test findCmdPath k command = do-	ifM (inPath command)+	ifM (inSearchPath command) 		( return $ Config k $ MaybeStringConfig $ Just command 		, do 			r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"]

@@ -1,3 +1,40 @@+git-annex (8.20210223) upstream; urgency=medium++  * annex.stalldetection can now be set to "true" to make git-annex+    do automatic stall detection when it detects a remote is updating its+    transfer progress consistently enough for stall detection to work.+  * When annex.stalldetection is not enabled and a likely stall is+    detected, display a suggestion to enable it.+  * Commands can be added to git-annex, by installing a program in PATH+    with a name starting with "git-annex-"+  * Fix a reversion that made import of a tree from a special remote+    result in a merge that deleted files that were not preferred content+    of that special remote.+  * Bugfix: fsck --from a ssh remote did not actually check that the+    content on the remote is not corrupted.+  * unannex, uninit: When an annexed file is modified, don't overwrite+    the modified version with an older version from the annex.+  * When adding files to an adjusted branch set up by --unlock-present,+    add them unlocked, not locked.+  * Fix an oddity in matching options and preferred content expressions+    such as "foo (bar or baz)", which was incorrectly handled as if+    it were "(foo or bar) and baz)" rather than the intended+    "foo and (bar or baz)"+  * Checksum as content is received from a remote git-annex repository,+    rather than doing it in a second pass.+  * Tahoe: Avoid verifying hash after download, since tahoe does sufficient+    verification itself.+  * unannex, uninit: Don't run git rm once per annexed file, +    for a large speedup.+  * When a git remote is configured with an absolute path, use that+    path, rather than making it relative.+  * get: Improve output when failing to get a file fails.+  * Fix build on openbsd.+    Thanks, James Cook for the patch.+  * Include libkqueue.h file needed to build the assistant on BSDs.++ -- Joey Hess <id@joeyh.name>  Tue, 23 Feb 2021 14:40:14 -0400+ git-annex (8.20210127) upstream; urgency=medium    * Added mincopies configuration. This is like numcopies, but is

@@ -1,6 +1,6 @@ {- git-annex command line parsing and dispatch  -- - Copyright 2010-2015 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -15,6 +15,8 @@ import qualified Options.Applicative as O import qualified Options.Applicative.Help as H import Control.Exception (throw)+import Control.Monad.IO.Class (MonadIO)+import System.Exit  import Annex.Common import qualified Annex@@ -26,9 +28,26 @@ import Command import Types.Messages -{- Runs the passed command line. -}-dispatch :: Bool -> CmdParams -> [Command] -> [GlobalOption] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()-dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progdesc = do+{- Parses input arguments, finds a matching Command, and runs it. -}+dispatch :: Bool -> Bool -> CmdParams -> [Command] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()+dispatch addonok fuzzyok allargs allcmds fields getgitrepo progname progdesc =+	go addonok allcmds $+		findAddonCommand subcommandname >>= \case+			Just c -> go addonok (c:allcmds) noop+			Nothing -> go addonok allcmds $+				findAllAddonCommands >>= \cs ->+					go False (cs++allcmds) noop+  where+	go p allcmds' cont =+		let (fuzzy, cmds) = selectCmd fuzzyok allcmds' subcommandname+		in if not p || (not fuzzy && not (null cmds))+			then dispatch' subcommandname args fuzzy cmds allargs allcmds' fields getgitrepo progname progdesc+			else cont+	+	(subcommandname, args) = subCmdName allargs++dispatch' :: (Maybe String) -> CmdParams -> Bool -> [Command] -> CmdParams -> [Command] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()+dispatch' subcommandname args fuzzy cmds allargs allcmds fields getgitrepo progname progdesc = do 	setupConsole 	go =<< tryNonAsync getgitrepo   where@@ -61,29 +80,28 @@ 				a  	parsewith secondrun getparser ingitrepo handleresult =-		case parseCmd progname progdesc globaloptions allargs allcmds getparser of+		case parseCmd progname progdesc allargs allcmds getparser of 			O.Failure _ -> do 				-- parse failed, so fall back to 				-- fuzzy matching, or to showing usage 				when (fuzzy && not secondrun) $ 					ingitrepo autocorrect-				handleresult (parseCmd progname progdesc globaloptions correctedargs allcmds getparser)+				handleresult (parseCmd progname progdesc correctedargs allcmds getparser) 			res -> handleresult res 	  where-		autocorrect = Git.AutoCorrect.prepare (fromJust inputcmdname) cmdname cmds-		(fuzzy, cmds, inputcmdname, args) = findCmd fuzzyok allargs allcmds+		autocorrect = Git.AutoCorrect.prepare (fromJust subcommandname) cmdname cmds 		name 			| fuzzy = case cmds of 				(c:_) -> Just (cmdname c)-				_ -> inputcmdname-			| otherwise = inputcmdname+				_ -> subcommandname+			| otherwise = subcommandname 		correctedargs = case name of 			Nothing -> allargs 			Just n -> n:args  {- Parses command line, selecting one of the commands from the list. -}-parseCmd :: String -> String -> [GlobalOption] -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v, GlobalSetter)-parseCmd progname progdesc globaloptions allargs allcmds getparser = +parseCmd :: String -> String -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v, GlobalSetter)+parseCmd progname progdesc allargs allcmds getparser =  	O.execParserPure (O.prefs O.idm) pinfo allargs   where 	pinfo = O.info (O.helper <*> subcmds) (O.progDescDoc (Just intro))@@ -91,33 +109,36 @@ 	mkcommand c = O.command (cmdname c) $ O.info (mkparser c) $ O.fullDesc  		<> O.header (synopsis (progname ++ " " ++ cmdname c) (cmddesc c)) 		<> O.footer ("For details, run: " ++ progname ++ " help " ++ cmdname c)+		<> cmdinfomod c 	mkparser c = (,,)  		<$> pure c 		<*> getparser c-		<*> combineGlobalOptions (globaloptions ++ cmdglobaloptions c)+		<*> parserGlobalOptions (cmdglobaloptions c) 	synopsis n d = n ++ " - " ++ d 	intro = mconcat $ concatMap (\l -> [H.text l, H.line]) 		(synopsis progname progdesc : commandList allcmds) -{- Parses command line params far enough to find the Command to run, and- - returns the remaining params.+{- Selects the Command that matches the subcommand name.  - Does fuzzy matching if necessary, which may result in multiple Commands. -}-findCmd :: Bool -> CmdParams -> [Command] -> (Bool, [Command], Maybe String, CmdParams)-findCmd fuzzyok argv cmds-	| not (null exactcmds) = ret (False, exactcmds)-	| fuzzyok && not (null inexactcmds) = ret (True, inexactcmds)-	| otherwise = ret (False, [])+selectCmd :: Bool -> [Command] -> Maybe String -> (Bool, [Command])+selectCmd fuzzyok cmds (Just n)+	| not (null exactcmds) = (False, exactcmds)+	| fuzzyok && not (null inexactcmds) = (True, inexactcmds)+	| otherwise = (False, [])   where-	ret (fuzzy, matches) = (fuzzy, matches, name, args)+	exactcmds = filter (\c -> cmdname c == n) cmds+	inexactcmds = Git.AutoCorrect.fuzzymatches n cmdname cmds+selectCmd _ _ Nothing = (False, [])++{- Parses command line params far enough to find the subcommand name. -}+subCmdName :: CmdParams -> (Maybe String, CmdParams)+subCmdName argv = (name, args)+  where 	(name, args) = findname argv [] 	findname [] c = (Nothing, reverse c) 	findname (a:as) c 		| "-" `isPrefixOf` a = findname as (a:c) 		| otherwise = (Just a, reverse c ++ as)-	exactcmds = filter (\c -> name == Just (cmdname c)) cmds-	inexactcmds = case name of-		Nothing -> []-		Just n -> Git.AutoCorrect.fuzzymatches n cmdname cmds  prepRunCommand :: Command -> GlobalSetter -> Annex () prepRunCommand cmd globalconfig = do@@ -126,3 +147,49 @@ 	getParsed globalconfig 	whenM (annexDebug <$> Annex.getGitConfig) $ 		liftIO enableDebugOutput++findAddonCommand :: Maybe String -> IO (Maybe Command)+findAddonCommand Nothing = return Nothing+findAddonCommand (Just subcommandname) =+	searchPath c >>= \case+		Nothing -> return Nothing+		Just p -> return (Just (mkAddonCommand p subcommandname))+  where+	c = "git-annex-" ++ subcommandname++findAllAddonCommands :: IO [Command]+findAllAddonCommands = +	filter isaddoncommand+		. map (\p -> mkAddonCommand p (deprefix p))+		<$> searchPathContents ("git-annex-" `isPrefixOf`)+  where+	deprefix = replace "git-annex-" "" . takeFileName+	isaddoncommand c+		-- git-annex-shell+		| cmdname c == "shell" = False+		-- external special remotes+		| "remote-" `isPrefixOf` cmdname c = False+		-- external backends+		| "backend-" `isPrefixOf` cmdname c = False+		| otherwise = True++mkAddonCommand :: FilePath -> String -> Command+mkAddonCommand p subcommandname = Command+	{ cmdcheck = []+	, cmdnocommit = True+	, cmdnomessages = True+	, cmdname = subcommandname+	, cmdparamdesc = "[PARAMS]"+	, cmdsection = SectionAddOn+	, cmddesc = "addon command"+	, cmdglobaloptions = []+	, cmdinfomod = O.forwardOptions+	, cmdparser = parse+	, cmdnorepo = Just parse+	}+  where+	parse :: (Monad m, MonadIO m) => Parser (m ())+	parse = (liftIO . run) <$> cmdParams "PARAMS"++	run ps = withCreateProcess (proc p ps) $ \_ _ _ pid ->+		exitWith =<< waitForProcess pid

@@ -12,11 +12,13 @@ import Annex.Common import qualified Annex import Annex.Concurrent+import Annex.WorkerPool import Types.Command import Types.Concurrency import Messages.Concurrent import Types.Messages import Types.WorkerPool+import Remote.List  import Control.Concurrent import Control.Concurrent.Async@@ -250,9 +252,18 @@ 	initworkerpool n = do 		tv <- liftIO newEmptyTMVarIO 		Annex.changeState $ \s -> s { Annex.workers = Just tv }+		prepDupState 		st <- dupState 		liftIO $ atomically $ putTMVar tv $ 			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.  - Other threads will block until it's done.

@@ -126,7 +126,7 @@ import qualified Command.Benchmark  cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command]-cmds testoptparser testrunner mkbenchmarkgenerator = +cmds testoptparser testrunner mkbenchmarkgenerator = map addGitAnnexGlobalOptions $ 	[ Command.Help.cmd 	, Command.Add.cmd 	, Command.Get.cmd@@ -237,12 +237,15 @@ 		mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop) 	] +addGitAnnexGlobalOptions :: Command -> Command+addGitAnnexGlobalOptions c = c { cmdglobaloptions = gitAnnexGlobalOptions ++ cmdglobaloptions c }+ run :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [String] -> IO () run testoptparser testrunner mkbenchmarkgenerator args = go envmodes   where-	go [] = dispatch True args +	go [] = dispatch True True args  		(cmds testoptparser testrunner mkbenchmarkgenerator)-		gitAnnexGlobalOptions [] Git.CurrentRepo.get+		[] Git.CurrentRepo.get 		"git-annex" 		"manage files with git, without checking their contents in" 	go ((v, a):rest) = maybe (go rest) a =<< getEnv v

@@ -40,7 +40,7 @@ 	, (ServeReadWrite, allcmds) 	]   where-	readonlycmds = +	readonlycmds = map addGlobalOptions 		[ Command.ConfigList.cmd 		, gitAnnexShellCheck Command.InAnnex.cmd 		, gitAnnexShellCheck Command.LockContent.cmd@@ -51,11 +51,11 @@ 		-- determine the security policy to use 		, gitAnnexShellCheck Command.P2PStdIO.cmd 		]-	appendcmds = readonlycmds +++	appendcmds = readonlycmds ++ map addGlobalOptions 		[ gitAnnexShellCheck Command.RecvKey.cmd 		, gitAnnexShellCheck Command.Commit.cmd 		]-	allcmds =+	allcmds = map addGlobalOptions 		[ gitAnnexShellCheck Command.DropKey.cmd 		, Command.GCryptSetup.cmd 		]@@ -69,6 +69,9 @@ cmdsList :: [Command] cmdsList = concat $ M.elems cmdsMap +addGlobalOptions :: Command -> Command+addGlobalOptions c = c { cmdglobaloptions = globalOptions ++ cmdglobaloptions c }+ globalOptions :: [GlobalOption] globalOptions =  	globalSetter checkUUID (strOption@@ -119,7 +122,7 @@ 	let (params', fieldparams, opts) = partitionParams params 	    rsyncopts = ("RsyncOptions", unwords opts) 	    fields = rsyncopts : filter checkField (parseFields fieldparams)-	dispatch False (cmd : params') cmdsList globalOptions fields mkrepo+	dispatch False False (cmd : params') cmdsList fields mkrepo 		"git-annex-shell" 		"Restricted login shell for git-annex only SSH access"   where

@@ -1,6 +1,6 @@ {- git-annex global options  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.   -}@@ -19,6 +19,7 @@ globalSetter :: (v -> Annex ()) -> Parser v -> GlobalOption globalSetter setter parser = DeferredParse . setter <$> parser -combineGlobalOptions :: [GlobalOption] -> Parser GlobalSetter-combineGlobalOptions l = DeferredParse . mapM_ getParsed+parserGlobalOptions :: [GlobalOption] -> Parser GlobalSetter+parserGlobalOptions [] = DeferredParse <$> pure noop+parserGlobalOptions l = DeferredParse . mapM_ getParsed 	<$> many (foldl1 (<|>) l)

@@ -33,7 +33,7 @@ command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command command name section desc paramdesc mkparser = 	Command commonChecks False False name paramdesc -		section desc (mkparser paramdesc) [] Nothing+		section desc (mkparser paramdesc) mempty [] Nothing  {- Simple option parser that takes all non-option params as-is. -} withParams :: (CmdParams -> v) -> CmdParamsDesc -> Parser v

@@ -172,6 +172,7 @@ perform o file addunlockedmatcher = withOtherTmp $ \tmpdir -> do 	lockingfile <- not <$> addUnlocked addunlockedmatcher 		(MatchingFile (FileInfo (Just file) file Nothing))+		True 	let cfg = LockDownConfig 		{ lockingFile = lockingfile 		, hardlinkFileTmpDir = Just tmpdir

@@ -332,7 +332,7 @@ 			let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink) 			showNote "using youtube-dl" 			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 						Right (Just mediafile) -> do 							cleanuptmp@@ -396,7 +396,7 @@ 	checkDiskSpaceToGet dummykey Nothing $ do 		tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey 		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) 				downloader (fromRawFilePath tmp) p 		if ok

@@ -79,7 +79,7 @@ 		f <- autoStartFile 		giveup $ "Nothing listed in " ++ f 	program <- programPath-	haveionice <- pure BuildInfo.ionice <&&> inPath "ionice"+	haveionice <- pure BuildInfo.ionice <&&> inSearchPath "ionice" 	pids <- forM dirs $ \d -> do 		putStrLn $ "git-annex autostart in " ++ d 		mpid <- catchMaybeIO $ go haveionice program d

@@ -287,7 +287,7 @@ 				-- could be used for more than one export 				-- location, and concurrently uploading 				-- 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 $ 						performUnexport r db [ek] loc 					sendAnnex k rollback $ \f ->

@@ -92,7 +92,7 @@   where 	dispatch [] = do 		showNote "not available"-		showlocs+		showlocs [] 		return False 	dispatch remotes = notifyTransfer Download afile $ \witness -> do 		ok <- pickRemote remotes $ \r -> ifM (probablyPresent r)@@ -103,9 +103,9 @@ 			then return ok 			else do 				Remote.showTriedRemotes remotes-				showlocs+				showlocs (map Remote.uuid remotes) 				return False-	showlocs = Remote.showLocations False key []+	showlocs exclude = Remote.showLocations False key exclude 		"No other repository is known to contain the file." 	-- This check is to avoid an ugly message if a remote is a 	-- drive that is not mounted.

@@ -243,7 +243,7 @@ 			, matchFile = destfile 			, matchKey = Nothing 			}-		lockingfile <- not <$> addUnlocked addunlockedmatcher mi+		lockingfile <- not <$> addUnlocked addunlockedmatcher mi True 		-- Minimal lock down with no hard linking so nothing 		-- has to be done to clean up from it. 		let cfg = LockDownConfig

@@ -64,7 +64,7 @@ runViewer file [] = do 	showLongNote $ "left map in " ++ file 	return True-runViewer file ((c, ps):rest) = ifM (liftIO $ inPath c)+runViewer file ((c, ps):rest) = ifM (liftIO $ inSearchPath c) 	( do 		showLongNote $ "running: " ++ c ++ unwords (toCommand ps) 		showOutput@@ -178,7 +178,7 @@ 	| Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r 	| Git.repoIsUrl r = return r 	| otherwise = liftIO $ do-		r' <- Git.Construct.fromAbsPath =<< absPath (Git.repoPath r)+		r' <- Git.Construct.fromPath =<< absPath (Git.repoPath r) 		r'' <- safely $ flip Annex.eval Annex.gitRepo =<< Annex.new r' 		return (fromMaybe r' r'') 

@@ -50,7 +50,7 @@ 		<$> Fields.getField Fields.associatedFile 	ok <- maybe (a $ const noop) 		-- 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 	liftIO $ debugM "fieldTransfer" "transfer done" 	liftIO $ exitBool ok

@@ -51,7 +51,7 @@  toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform 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 			Right () -> do 				Remote.logStatus remote key InfoPresent@@ -62,7 +62,7 @@  fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform 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 -> 			tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case 				Right v -> return (True, v)	

@@ -40,7 +40,7 @@   where 	runner (TransferRequest direction remote key 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 					Left e -> do 						warning (show e)@@ -49,7 +49,7 @@ 						Remote.logStatus remote key InfoPresent 						return True 		| 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 					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case 						Left e -> do

@@ -45,21 +45,23 @@ 	runner (UploadRequest _ key (TransferAssociatedFile file)) remote = 		-- This is called by eg, Annex.Transfer.upload, 		-- so caller is responsible for doing notification,-		-- and for retrying, and updating location log.-		upload' (Remote.uuid remote) key file noRetry+		-- and for retrying, and updating location log,+		-- and stall canceling.+		upload' (Remote.uuid remote) key file Nothing noRetry 			(Remote.action . Remote.storeKey remote key file) 			noNotification 	runner (DownloadRequest _ key (TransferAssociatedFile file)) remote = 		-- This is called by eg, Annex.Transfer.download 		-- 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 			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 	runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote = 		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 					Left e -> do 						warning (show e)@@ -69,7 +71,7 @@ 						return True 	runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote = 		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 					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case 						Left e -> do

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010-2013 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -10,7 +10,8 @@ import Command import qualified Annex import Annex.Perms-import qualified Git.Command+import Annex.Link+import qualified Annex.Queue import Utility.CopyFile import qualified Database.Keys import Git.FilePath@@ -41,28 +42,41 @@  perform :: RawFilePath -> Key -> CommandPerform perform file key = do-	liftIO $ removeFile (fromRawFilePath file)-	inRepo $ Git.Command.run-		[ Param "rm"-		, Param "--cached"+	Annex.Queue.addCommand [] "rm"+		[ Param "--cached" 		, Param "--force" 		, Param "--quiet" 		, Param "--"-		, File (fromRawFilePath file) 		]-	next $ cleanup file key+		[fromRawFilePath file]+	isAnnexLink file >>= \case+		-- If the file is locked, it needs to be replaced with+		-- the content from the annex. Note that it's possible+		-- for key' (read from the symlink) to differ from key+		-- (cached in git).+		Just key' -> do+			removeassociated+			next $ cleanup file key'+		-- If the file is unlocked, it can be unmodified or not and+		-- does not need to be replaced either way.+		Nothing -> do+			removeassociated+			next $ return True+  where+	removeassociated = +		Database.Keys.removeAssociatedFile key+			=<< inRepo (toTopFilePath file)  cleanup :: RawFilePath -> Key -> CommandCleanup cleanup file key = do-	Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file)+	liftIO $ removeFile (fromRawFilePath file) 	src <- calcRepo (gitAnnexLocation key) 	ifM (Annex.getState Annex.fast) 		( do 			-- Only make a hard link if the annexed file does not-			-- already have other hard links pointing at it.-			-- This avoids unannexing (and uninit) ending up-			-- hard linking files together, which would be-			-- surprising.+			-- already have other hard links pointing at it. This+			-- avoids unannexing (and uninit) ending up hard+			-- linking files together, which would be surprising. 			s <- liftIO $ R.getFileStatus src 			if linkCount s > 1 				then copyfrom src

@@ -57,35 +57,34 @@  {- Local Repo constructor, accepts a relative or absolute path. -} fromPath :: RawFilePath -> IO Repo-fromPath dir = fromAbsPath =<< absPath dir+fromPath dir+	-- When dir == "foo/.git", git looks for "foo/.git/.git",+	-- and failing that, uses "foo" as the repository.+	| (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir =+		ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git")+			( ret dir+			, ret (P.takeDirectory canondir)+			)+	| otherwise = ifM (doesDirectoryExist (fromRawFilePath dir))+		( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom)+		-- git falls back to dir.git when dir doesn't+		-- exist, as long as dir didn't end with a+		-- path separator+		, if dir == canondir+			then ret (dir <> ".git")+			else ret dir+		)+  where+	ret = pure . newFrom . LocalUnknown+	canondir = P.dropTrailingPathSeparator dir  {- Local Repo constructor, requires an absolute path to the repo be  - specified. -} fromAbsPath :: RawFilePath -> IO Repo fromAbsPath dir-	| absoluteGitPath dir = hunt+	| absoluteGitPath dir = fromPath dir 	| otherwise = 		error $ "internal error, " ++ show dir ++ " is not absolute"-  where-	ret = pure . newFrom . LocalUnknown-	canondir = P.dropTrailingPathSeparator dir-	{- When dir == "foo/.git", git looks for "foo/.git/.git",-	 - and failing that, uses "foo" as the repository. -}-	hunt-		| (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir =-			ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git")-				( ret dir-				, ret (P.takeDirectory canondir)-				)-		| otherwise = ifM (doesDirectoryExist (fromRawFilePath dir))-			( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom)-			-- git falls back to dir.git when dir doesn't-			-- exist, as long as dir didn't end with a-			-- path separator-			, if dir == canondir-				then ret (dir <> ".git")-				else ret dir-			)  {- Construct a Repo for a remote's url.  -

@@ -10,6 +10,7 @@ module Git.CurrentRepo where  import Common+import Git import Git.Types import Git.Construct import qualified Git.Config@@ -46,12 +47,12 @@ 	wt <- maybe (worktree (location r)) Just 		<$> getpathenvprefix "GIT_WORK_TREE" prefix 	case wt of-		Nothing -> return r+		Nothing -> relPath r 		Just d -> do 			curr <- R.getCurrentDirectory 			unless (d `dirContains` curr) $ 				setCurrentDirectory (fromRawFilePath d)-			return $ addworktree wt r+			relPath $ addworktree wt r   where 	getpathenv s = do 		v <- getEnv s

@@ -101,6 +101,10 @@ {- Parses a line of ls-tree output, in format:  - mode SP type SP sha TAB file  -+ - The TAB can also be a space. Git does not use that, but an earlier+ - version of formatLsTree did, and this keeps parsing what it output+ - working.+ -  - (The --long format is not currently supported.) -} parserLsTree :: A.Parser TreeItem parserLsTree = TreeItem@@ -111,8 +115,8 @@ 	<*> A8.takeTill (== ' ') 	<* A8.char ' ' 	-- sha-	<*> (Ref <$> A8.takeTill (== '\t'))-	<* A8.char '\t'+	<*> (Ref <$> A8.takeTill A8.isSpace)+	<* A8.space 	-- file 	<*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString) @@ -122,5 +126,4 @@ 	[ showOct (mode ti) "" 	, decodeBS (typeobj ti) 	, fromRef (sha ti)-	, fromRawFilePath (getTopFilePath (file ti))-	]+	] ++ ('\t' : fromRawFilePath (getTopFilePath (file ti)))

@@ -105,7 +105,7 @@ 	| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do 		unlessM (boolSystem "git" [Param "init", File tmpdir]) $ 			error $ "failed to create temp repository in " ++ tmpdir-		tmpr <- Config.read =<< Construct.fromAbsPath (toRawFilePath tmpdir)+		tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir) 		rs <- Construct.fromRemotes r 		stillmissing <- pullremotes tmpr rs fetchrefstags missing 		if S.null (knownMissing stillmissing)

@@ -197,10 +197,12 @@ getExportExcluded :: UUID -> Annex [Git.Tree.TreeItem] getExportExcluded u = do 	logf <- fromRepo $ gitAnnexExportExcludeLog u-	liftIO $ catchDefaultIO [] $ parser+	liftIO $ catchDefaultIO [] $ exportExcludedParser 		<$> L.readFile (fromRawFilePath logf)   where-	parser = map Git.Tree.lsTreeItemToTreeItem-		. rights-		. map Git.LsTree.parseLsTree-		. L.split (fromIntegral $ ord '\n')++exportExcludedParser :: L.ByteString -> [Git.Tree.TreeItem]+exportExcludedParser = map Git.Tree.lsTreeItemToTreeItem+	. rights+	. map Git.LsTree.parseLsTree+	. L.split (fromIntegral $ ord '\n')

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

@@ -1,6 +1,6 @@ {- P2P protocol, Annex implementation  -- - Copyright 2016-2018 Joey Hess <id@joeyh.name>+ - Copyright 2016-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -23,9 +23,12 @@ import Logs.Location import Types.NumCopies import Utility.Metered+import Types.Backend (IncrementalVerifier(..))+import Backend  import Control.Monad.Free import Control.Concurrent.STM+import qualified Data.ByteString as S  -- Full interpreter for Proto, that can receive and send objects. runFullProto :: RunState -> P2PConnection -> Proto a -> Annex (Either ProtoFailure a)@@ -64,7 +67,7 @@ 		case v of 			Right (Just (f, checkchanged)) -> proceed $ do 				-- 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 				checktransfer runtransfer fallback  			Right Nothing -> proceed fallback@@ -74,10 +77,11 @@ 		-- Remote.P2P and Remote.Git. 		let rsp = RetrievalAllKeysSecure 		v <- tryNonAsync $ do+			iv <- startVerifyKeyContentIncrementally DefaultVerify k 			let runtransfer ti = -				Right <$> transfer download' k af (\p ->+				Right <$> transfer download' k af Nothing (\p -> 					logStatusAfter k $ getViaTmp rsp DefaultVerify k af $ \tmp ->-						storefile (fromRawFilePath tmp) o l getb validitycheck p ti)+						storefile (fromRawFilePath tmp) o l getb iv validitycheck p ti) 			let fallback = return $ Left $ 				ProtoFailureMessage "transfer already in progress, or unable to take transfer lock" 			checktransfer runtransfer fallback@@ -85,10 +89,10 @@ 			Left e -> return $ Left $ ProtoFailureException e 			Right (Left e) -> return $ Left e 			Right (Right ok) -> runner (next ok)-	StoreContentTo dest o l getb validitycheck next -> do+	StoreContentTo dest iv o l getb validitycheck next -> do 		v <- tryNonAsync $ do 			let runtransfer ti = Right-				<$> storefile dest o l getb validitycheck nullMeterUpdate ti+				<$> storefile dest o l getb iv validitycheck nullMeterUpdate ti 			let fallback = return $ Left $ 				ProtoFailureMessage "transfer failed" 			checktransfer runtransfer fallback@@ -145,24 +149,52 @@ 		runner next 	RunValidityCheck checkaction next -> runner . next =<< checkaction   where-	transfer mk k af ta = case runst of+	transfer mk k af sd ta = case runst of 		-- Update transfer logs when serving. 		-- Using noRetry because we're the sender. 		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 		-- a client. 		Client _ -> ta nullMeterUpdate+	+	resumefromoffset o incrementalverifier p h+		| o /= 0 = do+			p' <- case incrementalverifier of+				Just iv -> do+					go iv o+					return p+				_ -> return $ offsetMeterUpdate p (toBytesProcessed o)+			-- Make sure the handle is seeked to the offset.+			-- (Reading the file probably left it there+			-- when that was done, but let's be sure.)+			hSeek h AbsoluteSeek o+			return p'+		| otherwise = return p+	  where+		go iv n+			| n == 0 = return ()+			| otherwise = do+				let c = if n > fromIntegral defaultChunkSize+					then defaultChunkSize+					else fromIntegral n+				b <- S.hGet h c+				updateIncremental iv b+				unless (b == S.empty) $+					go iv (n - fromIntegral (S.length b)) -	storefile dest (Offset o) (Len l) getb validitycheck p ti = do-		let p' = offsetMeterUpdate p (toBytesProcessed o)+	storefile dest (Offset o) (Len l) getb incrementalverifier validitycheck p ti = do 		v <- runner getb 		case v of 			Right b -> do 				liftIO $ withBinaryFile dest ReadWriteMode $ \h -> do-					when (o /= 0) $-						hSeek h AbsoluteSeek o-					meteredWrite p' h b+					p' <- resumefromoffset o incrementalverifier p h+					let writechunk = case incrementalverifier of+						Nothing -> \c -> S.hPut h c+						Just iv -> \c -> do+							S.hPut h c+							updateIncremental iv c+					meteredWrite p' writechunk b 				indicatetransferred ti  				rightsize <- do@@ -170,8 +202,12 @@ 					return (toInteger sz == l + o) 					 				runner validitycheck >>= \case-					Right (Just Valid) ->-						return (rightsize, UnVerified)+					Right (Just Valid) -> case incrementalverifier of+						Just iv -> ifM (liftIO (finalizeIncremental iv) <&&> pure rightsize)+							( return (True, Verified)+							, return (False, UnVerified)+							)+						Nothing -> return (rightsize, UnVerified) 					Right (Just Invalid) | l == 0 -> 						-- Special case, for when 						-- content was not

@@ -259,7 +259,7 @@ -- connection. False is returned to indicate this problem. sendExactly :: Len -> L.ByteString -> Handle -> MeterUpdate -> IO Bool sendExactly (Len n) b h p = do-	sent <- meteredWrite' p h (L.take (fromIntegral n) b)+	sent <- meteredWrite' p (B.hPut h) (L.take (fromIntegral n) b) 	return (fromBytesProcessed sent == n)  receiveExactly :: Len -> Handle -> MeterUpdate -> IO L.ByteString

@@ -2,7 +2,7 @@  -  - See doc/design/p2p_protocol.mdwn  -- - Copyright 2016-2020 Joey Hess <id@joeyh.name>+ - Copyright 2016-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -17,7 +17,9 @@ import Types (Annex) import Types.Key import Types.UUID-import Types.Remote (Verification(..), unVerified)+import Types.Remote (Verification(..))+import Types.Backend (IncrementalVerifier(..))+import Types.Transfer import Utility.AuthToken import Utility.Applicative import Utility.PartialPrelude@@ -266,7 +268,7 @@ 	-- Note: The ByteString may not contain the entire remaining content 	-- of the key. Only once the temp file size == Len has the whole 	-- content been transferred.-	| StoreContentTo FilePath Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) ((Bool, Verification) -> c)+	| StoreContentTo FilePath (Maybe IncrementalVerifier) Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) ((Bool, Verification) -> c) 	-- ^ Like StoreContent, but stores the content to a temp file. 	| SetPresent Key UUID c 	| CheckContentPresent Key (Bool -> c)@@ -351,13 +353,13 @@ 	net $ sendMessage (REMOVE key) 	checkSuccess -get :: FilePath -> Key -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification)-get dest key af m p = +get :: FilePath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification)+get dest key iv af m p =  	receiveContent (Just m) p sizer storer $ \offset -> 		GET offset (ProtoAssociatedFile af) key   where 	sizer = fileSize dest-	storer = storeContentTo dest+	storer = storeContentTo dest iv  put :: Key -> AssociatedFile -> MeterUpdate -> Proto Bool put key af p = do@@ -503,10 +505,9 @@ 			then net $ sendMessage ALREADY_HAVE 			else do 				let sizer = tmpContentSize key-				let storer = \o l b v -> unVerified $-					storeContent key af o l b v-				(ok, _v) <- receiveContent Nothing nullMeterUpdate sizer storer PUT_FROM-				when ok $+				let storer = storeContent key af+				v <- receiveContent Nothing nullMeterUpdate sizer storer PUT_FROM+				when (observeBool v) $ 					local $ setPresent key myuuid 		return ServerContinue @@ -532,12 +533,13 @@ 		checkSuccess  receiveContent-	:: Maybe Meter+	:: Observable t+	=> Maybe Meter 	-> MeterUpdate 	-> Local Len-	-> (Offset -> Len -> Proto L.ByteString -> Proto (Maybe Validity) -> Local (Bool, Verification))+	-> (Offset -> Len -> Proto L.ByteString -> Proto (Maybe Validity) -> Local t) 	-> (Offset -> Message)-	-> Proto (Bool, Verification)+	-> Proto t receiveContent mm p sizer storer mkmsg = do 	Len n <- local sizer 	let p' = offsetMeterUpdate p (toBytesProcessed n)@@ -557,14 +559,14 @@ 						net $ sendMessage (ERROR "expected VALID or INVALID") 						return Nothing 				else return Nothing-			(ok, v) <- local $ storer offset len+			v <- local $ storer offset len 				(net (receiveBytes len p')) 				validitycheck-			sendSuccess ok-			return (ok, v)+			sendSuccess (observeBool v)+			return v 		_ -> do 			net $ sendMessage (ERROR "expected DATA")-			return (False, UnVerified)+			return observeFailure  checkSuccess :: Proto Bool checkSuccess = do

@@ -99,6 +99,9 @@ downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification downloadKey key _file dest p = do 	get . map (torrentUrlNum . fst . getDownloader) =<< getBitTorrentUrls key+	-- While bittorrent verifies the hash in the torrent file,+	-- the torrent file itself is downloaded without verification,+	-- so the overall download is not verified. 	return UnVerified   where 	get [] = giveup "could not download torrent"@@ -291,7 +294,7 @@  checkDependencies :: Annex () checkDependencies = do-	missing <- liftIO $ filterM (not <$$> inPath) deps+	missing <- liftIO $ filterM (not <$$> inSearchPath) deps 	unless (null missing) $ 		giveup $ "need to install additional software in order to download from bittorrent: " ++ unwords missing   where

@@ -167,7 +167,7 @@ 				} 			else cmd 		    feeder = \h -> do-			meteredWrite p h b+			meteredWrite p (S.hPut h) b 			hClose h 		in withCreateProcess cmd' (go feeder cmd')   where@@ -287,11 +287,11 @@ bup2GitRemote "" = do 	-- bup -r "" operates on ~/.bup 	h <- myHomeDir-	Git.Construct.fromAbsPath $ toRawFilePath $ h </> ".bup"+	Git.Construct.fromPath $ toRawFilePath $ h </> ".bup" bup2GitRemote r 	| bupLocal r =  		if "/" `isPrefixOf` r-			then Git.Construct.fromAbsPath (toRawFilePath r)+			then Git.Construct.fromPath (toRawFilePath r) 			else giveup "please specify an absolute path" 	| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir   where

@@ -1,6 +1,6 @@ {- Standard git remotes.  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -46,8 +46,10 @@ import Utility.Metered import Utility.CopyFile import Utility.Env+import Utility.FileMode import Utility.Batch import Utility.SimpleProtocol+import Utility.Touch import Remote.Helper.Git import Remote.Helper.Messages import Remote.Helper.ExportImport@@ -61,18 +63,21 @@ import Creds import Types.NumCopies import Types.ProposedAccepted+import Types.Backend+import Backend import Annex.Action+import Annex.Verify import Messages.Progress  #ifndef mingw32_HOST_OS import qualified Utility.RawFilePath as R-import Utility.FileMode #endif  import Control.Concurrent import Control.Concurrent.MSampleVar import qualified Data.Map as M import qualified Data.ByteString as S+import Data.Time.Clock.POSIX import Network.URI  remote :: RemoteType@@ -184,7 +189,7 @@ 			, name = Git.repoDescribe r 			, storeKey = copyToRemote new st 			, retrieveKeyFile = copyFromRemote new st-			, retrieveKeyFileCheap = copyFromRemoteCheap new st r+			, retrieveKeyFileCheap = copyFromRemoteCheap st r 			, retrievalSecurityPolicy = RetrievalAllKeysSecure 			, removeKey = dropKey new st 			, lockContent = Just (lockKey new st)@@ -535,17 +540,17 @@ 			giveup "failed to download content" 		return UnVerified 	| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ do-		params <- Ssh.rsyncParams r Download 		u <- getUUID 		hardlink <- wantHardLink 		-- run copy from perspective of remote 		onLocalFast st $ Annex.Content.prepSendAnnex key >>= \case 			Just (object, checksuccess) -> do-				copier <- mkCopier hardlink st params+				let verify = Annex.Content.RemoteVerify r+				copier <- mkCopier hardlink st 				(ok, v) <- runTransfer (Transfer Download u (fromKey id key))-					file stdRetry $ \p ->+					file Nothing stdRetry $ \p -> 						metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' -> -							copier object dest p' checksuccess+							copier object dest key p' checksuccess verify 				if ok 					then return v 					else giveup "failed to retrieve content from remote"@@ -557,6 +562,7 @@ 				then return v 				else giveup "failed to retrieve content from remote" 		else P2PHelper.retrieve+			(Annex.Content.RemoteVerify r) 			(\p -> Ssh.runProto r connpool (return (False, UnVerified)) (fallback p)) 			key file dest meterupdate 	| otherwise = giveup "copying from non-ssh, non-http remote not supported"@@ -634,9 +640,9 @@ 		bracketIO noop (const cleanup) (const $ a feeder) 			`onException` liftIO forcestop -copyFromRemoteCheap :: Remote -> State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())+copyFromRemoteCheap :: State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) #ifndef mingw32_HOST_OS-copyFromRemoteCheap r st repo+copyFromRemoteCheap st repo 	| not $ Git.repoIsUrl repo = Just $ \key _af file -> guardUsable repo (giveup "cannot access remote") $ do 		gc <- getGitConfigFromState st 		loc <- liftIO $ gitAnnexLocation key repo gc@@ -646,14 +652,9 @@ 				R.createSymbolicLink absloc (toRawFilePath file) 			, giveup "remote does not contain key" 			)-	| Git.repoIsSsh repo = Just $ \key af file ->-		ifM (Annex.Content.preseedTmp key file)-			( void $ copyFromRemote' True r st key af file nullMeterUpdate-			, giveup "cannot preseed rsync with existing content"-			) 	| otherwise = Nothing #else-copyFromRemoteCheap _ _ _ = Nothing+copyFromRemoteCheap _ _ = Nothing #endif  {- Tries to copy a key's content to a remote's annex. -}@@ -682,19 +683,18 @@ 		-- the remote's Annex, but it needs access to the local 		-- Annex monad's state. 		checksuccessio <- Annex.withCurrentState checksuccess-		params <- Ssh.rsyncParams r Upload 		u <- getUUID 		hardlink <- wantHardLink 		-- run copy from perspective of remote 		res <- onLocalFast st $ ifM (Annex.Content.inAnnex key) 			( return True-			, runTransfer (Transfer Download u (fromKey id key)) file stdRetry $ \p -> do-				copier <- mkCopier hardlink st params+			, runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> do 				let verify = Annex.Content.RemoteVerify r+				copier <- mkCopier hardlink st 				let rsp = RetrievalAllKeysSecure 				res <- logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest -> 					metered (Just (combineMeterUpdate meterupdate p)) key $ \_ p' -> -						copier object (fromRawFilePath dest) p' (liftIO checksuccessio)+						copier object (fromRawFilePath dest) key p' (liftIO checksuccessio) verify 				Annex.Content.saveState True 				return res 			)@@ -787,50 +787,6 @@ onLocalFast :: State -> Annex a -> Annex a onLocalFast st a = onLocal st $ Annex.BranchState.disableUpdate >> a --- To avoid the overhead of trying copy-on-write every time, it's tried--- once and if it fails, is not tried again.-newtype CopyCoWTried = CopyCoWTried (MVar Bool)--newCopyCoWTried :: IO CopyCoWTried-newCopyCoWTried = CopyCoWTried <$> newEmptyMVar--{- Copys a file. Uses copy-on-write if it is supported. Otherwise,- - uses rsync, so that interrupted copies can be resumed. -}-rsyncOrCopyFile :: State -> [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool-#ifdef mingw32_HOST_OS-rsyncOrCopyFile _st _rsyncparams src dest p =-	-- rsync is only available on Windows in some installation methods,-	-- and is not strictly needed here, so don't use it.-	docopywith copyFileExternal-  where-#else-rsyncOrCopyFile st rsyncparams src dest p =-	-- If multiple threads reach this at the same time, they-	-- will both try CoW, which is acceptable.-	ifM (liftIO $ isEmptyMVar copycowtried)-		( do-			ok <- docopycow-			void $ liftIO $ tryPutMVar copycowtried ok-			pure ok <||> dorsync-		, ifM (liftIO $ readMVar copycowtried)-			( docopycow <||> dorsync-			, dorsync-			)-		)-  where-	copycowtried = case st of-		State _ _ (CopyCoWTried v) _ _ -> v-	dorsync = do-		-- dest may already exist, so make sure rsync can write to it-		void $ liftIO $ tryIO $ allowWrite (toRawFilePath dest)-		oh <- mkOutputHandlerQuiet-		Ssh.rsyncHelper oh (Just p) $-			rsyncparams ++ [File src, File dest]-	docopycow = docopywith copyCoW-#endif-	docopywith a = liftIO $ watchFileSize dest p $-		a CopyTimeStamps src dest- commitOnCleanup :: Git.Repo -> Remote -> State -> Annex a -> Annex a commitOnCleanup repo r st a = go `after` a   where@@ -871,20 +827,23 @@ -- -- When a hard link is created, returns Verified; the repo being linked -- from is implicitly trusted, so no expensive verification needs to be--- done.-type Copier = FilePath -> FilePath -> MeterUpdate -> Annex Bool -> Annex (Bool, Verification)+-- done. Also returns Verified if the key's content is verified while+-- copying it.+type Copier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification) -mkCopier :: Bool -> State -> [CommandParam] -> Annex Copier-mkCopier remotewanthardlink st rsyncparams = do-	let copier = \src dest p check -> unVerified $-		rsyncOrCopyFile st rsyncparams src dest p <&&> check+mkCopier :: Bool -> State -> Annex Copier+mkCopier remotewanthardlink st = do+	let copier = fileCopier st 	localwanthardlink <- wantHardLink 	let linker = \src dest -> createLink src dest >> return True 	if remotewanthardlink || localwanthardlink-		then return $ \src dest p check ->+		then return $ \src dest k p check verifyconfig -> 			ifM (liftIO (catchBoolIO (linker src dest)))-				( return (True, Verified)-				, copier src dest p check+				( ifM check+					( return (True, Verified)+					, return (False, UnVerified)+					)+				, copier src dest k p check verifyconfig 				) 		else return copier @@ -942,3 +901,129 @@ 				)  			return (duc, getrepo)++-- To avoid the overhead of trying copy-on-write every time, it's tried+-- once and if it fails, is not tried again.+newtype CopyCoWTried = CopyCoWTried (MVar Bool)++newCopyCoWTried :: IO CopyCoWTried+newCopyCoWTried = CopyCoWTried <$> newEmptyMVar++{- Copys a file. Uses copy-on-write if it is supported. Otherwise,+ - copies the file itself. If the destination already exists,+ - an interruped copy will resume where it left off.+ -+ - When copy-on-write is used, returns UnVerified, because the content of+ - the file has not been verified to be correct. When the file has to be+ - read to copy it, a hash is calulated at the same time.+ -+ - Note that, when the destination file already exists, it's read both+ - to start calculating the hash, and also to verify that its content is+ - the same as the start of the source file. It's possible that the+ - destination file was created from some other source file,+ - (eg when isStableKey is false), and doing this avoids getting a+ - corrupted file in such cases.+ -}+fileCopier :: State -> Copier+#ifdef mingw32_HOST_OS+fileCopier _st src dest k meterupdate check verifyconfig = docopy+  where+#else+fileCopier st src dest k meterupdate check verifyconfig =+	-- If multiple threads reach this at the same time, they+	-- will both try CoW, which is acceptable.+	ifM (liftIO $ isEmptyMVar copycowtried)+		( do+			ok <- docopycow+			void $ liftIO $ tryPutMVar copycowtried ok+			if ok+				then unVerified check+				else docopy+		, ifM (liftIO $ readMVar copycowtried)+			( do+				ok <- docopycow+				if ok+					then unVerified check+					else docopy+			, docopy+			)+		)+  where+	copycowtried = case st of+		State _ _ (CopyCoWTried v) _ _ -> v+	docopycow = liftIO $ watchFileSize dest meterupdate $+		copyCoW CopyTimeStamps src dest+#endif++	dest' = toRawFilePath dest++	docopy = do+		iv <- startVerifyKeyContentIncrementally verifyconfig k++		-- The file might have had the write bit removed,+		-- so make sure we can write to it.+		void $ liftIO $ tryIO $ allowWrite dest'++		liftIO $ withBinaryFile dest ReadWriteMode $ \hdest ->+			withBinaryFile src ReadMode $ \hsrc -> do+				sofar <- compareexisting iv hdest hsrc zeroBytesProcessed+				docopy' iv hdest hsrc sofar++		-- Copy src mode and mtime.+		mode <- liftIO $ fileMode <$> getFileStatus src+		mtime <- liftIO $ utcTimeToPOSIXSeconds <$> getModificationTime src+		liftIO $ setFileMode dest mode+		liftIO $ touch dest' mtime False++		ifM check+			( case iv of+				Just x -> ifM (liftIO $ finalizeIncremental x)+					( return (True, Verified)+					, return (False, UnVerified)+					)+				Nothing -> return (True, UnVerified)+			, return (False, UnVerified)+			)+	+	docopy' iv hdest hsrc sofar = do+		s <- S.hGet hsrc defaultChunkSize+		if s == S.empty+			then return ()+			else do+				let sofar' = addBytesProcessed sofar (S.length s)+				S.hPut hdest s+				maybe noop (flip updateIncremental s) iv+				meterupdate sofar'+				docopy' iv hdest hsrc sofar'++	-- Leaves hdest and hsrc seeked to wherever the two diverge,+	-- so typically hdest will be seeked to end, and hsrc to the same+	-- position.+	compareexisting iv hdest hsrc sofar = do+		s <- S.hGet hdest defaultChunkSize+		if s == S.empty+			then return sofar+			else do+				s' <- getnoshort (S.length s) hsrc+				if s == s'+					then do+						maybe noop (flip updateIncremental s) iv+						let sofar' = addBytesProcessed sofar (S.length s)+						meterupdate sofar'+						compareexisting iv hdest hsrc sofar'+					else do+						seekbefore hdest s+						seekbefore hsrc s'+						return sofar+	+	seekbefore h s = hSeek h RelativeSeek (fromIntegral (-1*S.length s))+	+	-- Like hGet, but never returns less than the requested number of+	-- bytes, unless it reaches EOF.+	getnoshort n h = do+		s <- S.hGet h n+		if S.length s == n || S.empty == s+			then return s+			else do+				s' <- getnoshort (n - S.length s) h+				return (s <> s')

@@ -9,6 +9,7 @@  import qualified Data.Map as M import qualified Data.Text as T+import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L  import Annex.Common@@ -168,7 +169,7 @@ 			{ std_in = CreatePipe } 		in liftIO $ withCreateProcess cmd (go' cmd) 	go' cmd (Just hin) _ _ pid = do-		meteredWrite p hin b+		meteredWrite p (S.hPut hin) b 		hClose hin 		forceSuccessProcess cmd pid 	go' _ _ _ _ _ = error "internal"

@@ -20,16 +20,19 @@ ) where  import Annex.Common+import qualified Annex import Utility.DataUnits import Types.StoreRetrieve import Types.Remote import Types.ProposedAccepted import Logs.Chunk import Utility.Metered-import Crypto (EncKey)+import Crypto import Backend (isStableKey) import Annex.SpecialRemote.Config+import qualified Utility.RawFilePath as R +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L  data ChunkConfig@@ -109,16 +112,19 @@  - writes a whole L.ByteString at a time.  -} storeChunks-	:: UUID+	:: LensGpgEncParams encc+	=> UUID 	-> ChunkConfig 	-> EncKey 	-> Key 	-> FilePath 	-> MeterUpdate+	-> Maybe (Cipher, EncKey)+	-> encc 	-> Storer 	-> CheckPresent 	-> Annex ()-storeChunks u chunkconfig encryptor k f p storer checker = +storeChunks u chunkconfig encryptor k f p enc encc storer checker =  	case chunkconfig of 		-- Only stable keys are safe to store chunked, 		-- because an unstable key can have multiple different@@ -129,9 +135,9 @@ 				h <- liftIO $ openBinaryFile f ReadMode 				go chunksize h 				liftIO $ hClose h-			, storer k (FileContent f) p+			, storechunk k (FileContent f) p 			)-		_ -> storer k (FileContent f) p+		_ -> storechunk k (FileContent f) p   where 	go chunksize h = do 		let chunkkeys = chunkKeyStream k chunksize@@ -152,7 +158,7 @@ 			| otherwise = do 				liftIO $ meterupdate' zeroBytesProcessed 				let (chunkkey, chunkkeys') = nextChunkKeyStream chunkkeys-				storer chunkkey (ByteContent chunk) meterupdate'+				storechunk chunkkey (ByteContent chunk) meterupdate' 				let bytesprocessed' = addBytesProcessed bytesprocessed (L.length chunk) 				loop bytesprocessed' (splitchunk bs) chunkkeys' 		  where@@ -163,6 +169,15 @@ 			 - in previous chunks. -} 			meterupdate' = offsetMeterUpdate meterupdate bytesprocessed +	storechunk ck content meterupdate = case enc of+		Nothing -> storer ck content meterupdate+		(Just (cipher, enck)) -> do+			cmd <- gpgCmd <$> Annex.getGitConfig+			withBytes content $ \b ->+				encrypt cmd encc cipher (feedBytes b) $+					readBytes $ \encb ->+						storer (enck ck) (ByteContent encb) meterupdate+ {- Check if any of the chunk keys are present. If found, seek forward  - in the Handle, so it will be read starting at the first missing chunk.  - Returns the ChunkKeyStream truncated to start at the first missing@@ -219,28 +234,31 @@  -  - When the remote is chunked, tries each of the options returned by  - chunkKeys until it finds one where the retriever successfully- - gets the first chunked key. The content of that key, and any- - other chunks in the list is fed to the sink.+ - gets the first chunked key.  -  - If retrival of one of the subsequent chunks throws an exception,- - gives up. Note that partial data may have been written to the sink+ - gives up. Note that partial data may have been written to the file  - in this case.  -  - Resuming is supported when using chunks. When the destination file  - already exists, it skips to the next chunked key that would be needed  - to resume.+ -+ - Handles decrypting the content when encryption is used.  -} retrieveChunks -	:: Retriever+	:: LensGpgEncParams encc+	=> Retriever 	-> UUID 	-> ChunkConfig 	-> EncKey 	-> Key 	-> FilePath 	-> MeterUpdate-	-> (Maybe Handle -> Maybe MeterUpdate -> ContentSource -> Annex ())+	-> Maybe (Cipher, EncKey)+	-> encc 	-> Annex ()-retrieveChunks retriever u chunkconfig encryptor basek dest basep sink+retrieveChunks retriever u chunkconfig encryptor basek dest basep enc encc 	| noChunks chunkconfig = 		-- Optimisation: Try the unchunked key first, to avoid 		-- looking in the git-annex branch for chunk counts@@ -271,7 +289,7 @@ 			v <- tryNonAsync $ 				retriever (encryptor k) p $ \content -> 					bracketIO (maybe opennew openresume offset) hClose $ \h -> do-						tosink (Just h) p content+						retrieved (Just h) p content 						let sz = toBytesProcessed $ 							fromMaybe 0 $ fromKey keyChunkSize k 						getrest p h sz sz ks@@ -285,10 +303,10 @@ 	getrest p h sz bytesprocessed (k:ks) = do 		let p' = offsetMeterUpdate p bytesprocessed 		liftIO $ p' zeroBytesProcessed-		retriever (encryptor k) p' $ tosink (Just h) p'+		retriever (encryptor k) p' $ retrieved (Just h) p' 		getrest p h sz (addBytesProcessed bytesprocessed sz) ks -	getunchunked = retriever (encryptor basek) basep $ tosink Nothing basep+	getunchunked = retriever (encryptor basek) basep $ retrieved Nothing basep  	opennew = openBinaryFile dest WriteMode @@ -305,15 +323,61 @@ 	 - 	 - However, if the Retriever generates a lazy ByteString, 	 - it is not responsible for updating progress (often it cannot).-	 - Instead, the sink is passed a meter to update as it consumes-	 - the ByteString.+	 - Instead, writeRetrievedContent is passed a meter to update+	 - as it consumes the ByteString. 	 -}-	tosink h p content = sink h p' content+	retrieved h p content = writeRetrievedContent dest enc encc h p' content 	  where 		p' 			| isByteContent content = Just p 			| otherwise = Nothing +{- Writes retrieved file content into the provided Handle, decrypting it+ - first if necessary.+ - + - If the remote did not store the content using chunks, no Handle+ - will be provided, and it's up to us to open the destination file.+ -+ - Note that when neither chunking nor encryption is used, and the remote+ - provides FileContent, that file only needs to be renamed+ - into place. (And it may even already be in the right place..)+ -}+writeRetrievedContent+	:: LensGpgEncParams encc+	=> FilePath+	-> Maybe (Cipher, EncKey)+	-> encc+	-> Maybe Handle+	-> Maybe MeterUpdate+	-> ContentSource+	-> Annex ()+writeRetrievedContent dest enc encc mh mp content = case (enc, mh, content) of+	(Nothing, Nothing, FileContent f)+		| f == dest -> noop+		| otherwise -> liftIO $ moveFile f dest+	(Just (cipher, _), _, ByteContent b) -> do+		cmd <- gpgCmd <$> Annex.getGitConfig+		decrypt cmd encc cipher (feedBytes b) $+			readBytes write+	(Just (cipher, _), _, FileContent f) -> do+		cmd <- gpgCmd <$> Annex.getGitConfig+		withBytes content $ \b ->+			decrypt cmd encc cipher (feedBytes b) $+				readBytes write+		liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)+	(Nothing, _, FileContent f) -> do+		withBytes content write+		liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)+	(Nothing, _, ByteContent b) -> write b+  where+	write b = case mh of+		Just h -> liftIO $ b `streamto` h+		Nothing -> liftIO $ bracket opendest hClose (b `streamto`)+	streamto b h = case mp of+		Just p -> meteredWrite p (S.hPut h) b+		Nothing -> L.hPut h b+	opendest = openBinaryFile dest WriteMode+ {- Can resume when the chunk's offset is at or before the end of  - the dest file. -} resumeOffset :: Maybe Integer -> Key -> Maybe Integer@@ -455,3 +519,7 @@ ensureChunksAreLogged u k (SpeculativeChunkKeys (chunkmethod, chunkcount) _) =  	chunksStored u k chunkmethod chunkcount ensureChunksAreLogged _ _ (ChunkKeys _) = return ()++withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a+withBytes (ByteContent b) a = a b+withBytes (FileContent f) a = a =<< liftIO (L.readFile f)

@@ -11,6 +11,7 @@ import Remote.Helper.Chunked import Utility.Metered +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L  {- This is an extension that's added to the usual file (or whatever)@@ -117,4 +118,4 @@ meteredWriteFileChunks meterupdate dest chunks feeder = 	withBinaryFile dest WriteMode $ \h -> 		forM_ chunks $-			meteredWrite meterupdate h <=< feeder+			meteredWrite meterupdate (S.hPut h) <=< feeder

@@ -1,6 +1,6 @@ {- Helpers for remotes using the git-annex P2P protocol.  -- - Copyright 2016-2020 Joey Hess <id@joeyh.name>+ - Copyright 2016-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -17,6 +17,7 @@ import Messages.Progress import Utility.Metered import Types.NumCopies+import Backend  import Control.Concurrent @@ -39,10 +40,11 @@ 			Just False -> giveup "transfer failed" 			Nothing -> remoteUnavail -retrieve :: (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification-retrieve runner k af dest p =+retrieve :: VerifyConfig -> (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification+retrieve verifyconfig runner k af dest p = do+	iv <- startVerifyKeyContentIncrementally verifyconfig k 	metered (Just p) k $ \m p' -> -		runner p' (P2P.get dest k af m p') >>= \case+		runner p' (P2P.get dest k iv af m p') >>= \case 			Just (True, v) -> return v 			Just (False, _) -> giveup "transfer failed" 			Nothing -> remoteUnavail

@@ -35,11 +35,9 @@ ) where  import Annex.Common-import qualified Annex import Annex.SpecialRemote.Config import Types.StoreRetrieve import Types.Remote-import Crypto import Annex.UUID import Config import Config.Cost@@ -51,7 +49,6 @@ import qualified Git import qualified Git.Construct import Git.Types-import qualified Utility.RawFilePath as R  import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L@@ -213,25 +210,16 @@ 	storeKeyGen k p enc = sendAnnex k rollback $ \src -> 		displayprogress p k (Just src) $ \p' -> 			storeChunks (uuid baser) chunkconfig enck k src p'-				(storechunk enc)-				checkpresent+				enc encr storer checkpresent 	  where 		rollback = void $ removeKey encr k 		enck = maybe id snd enc -	storechunk Nothing k content p = storer k content p-	storechunk (Just (cipher, enck)) k content p = do-		cmd <- gpgCmd <$> Annex.getGitConfig-		withBytes content $ \b ->-			encrypt cmd encr cipher (feedBytes b) $-				readBytes $ \encb ->-					storer (enck k) (ByteContent encb) p- 	-- call retriever to get chunks; decrypt them; stream to dest file 	retrieveKeyFileGen k dest p enc = do 		displayprogress p k Nothing $ \p' -> 			retrieveChunks retriever (uuid baser) chunkconfig-				enck k dest p' (sink dest enc encr)+				enck k dest p' enc encr 		return UnVerified 	  where 		enck = maybe id snd enc@@ -252,52 +240,6 @@ 		| displayProgress cfg = 			metered (Just p) (KeySizer k (pure (fmap toRawFilePath srcfile))) (const a) 		| otherwise = a p--{- Sink callback for retrieveChunks. Stores the file content into the- - provided Handle, decrypting it first if necessary.- - - - If the remote did not store the content using chunks, no Handle- - will be provided, and it's up to us to open the destination file.- -- - Note that when neither chunking nor encryption is used, and the remote- - provides FileContent, that file only needs to be renamed- - into place. (And it may even already be in the right place..)- -}-sink-	:: LensGpgEncParams c-	=> FilePath-	-> Maybe (Cipher, EncKey)-	-> c-	-> Maybe Handle-	-> Maybe MeterUpdate-	-> ContentSource-	-> Annex ()-sink dest enc c mh mp content = case (enc, mh, content) of-	(Nothing, Nothing, FileContent f)-		| f == dest -> noop-		| otherwise -> liftIO $ moveFile f dest-	(Just (cipher, _), _, ByteContent b) -> do-		cmd <- gpgCmd <$> Annex.getGitConfig-		decrypt cmd c cipher (feedBytes b) $-			readBytes write-	(Just (cipher, _), _, FileContent f) -> do-		cmd <- gpgCmd <$> Annex.getGitConfig-		withBytes content $ \b ->-			decrypt cmd c cipher (feedBytes b) $-				readBytes write-		liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)-	(Nothing, _, FileContent f) -> do-		withBytes content write-		liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)-	(Nothing, _, ByteContent b) -> write b-  where-	write b = case mh of-		Just h -> liftIO $ b `streamto` h-		Nothing -> liftIO $ bracket opendest hClose (b `streamto`)-	streamto b h = case mp of-		Just p -> meteredWrite p h b-		Nothing -> L.hPut h b-	opendest = openBinaryFile dest WriteMode  withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a withBytes (ByteContent b) a = a b

@@ -13,6 +13,7 @@ import Annex.Common import qualified Annex import qualified P2P.Protocol as P2P+import qualified Annex.Content import P2P.Address import P2P.Annex import P2P.IO@@ -56,7 +57,7 @@ 		, cost = cst 		, name = Git.repoDescribe r 		, storeKey = store (const protorunner)-		, retrieveKeyFile = retrieve (const protorunner)+		, retrieveKeyFile = retrieve (Annex.Content.RemoteVerify this) (const protorunner) 		, retrieveKeyFileCheap = Nothing 		, retrievalSecurityPolicy = RetrievalAllKeysSecure 		, removeKey = remove protorunner

@@ -147,7 +147,9 @@ retrieve :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Verification retrieve rs hdl k _f d _p = do 	go =<< getCapability rs k-	return UnVerified+	-- Tahoe verifies the content it retrieves using cryptographically+	-- secure methods.+	return Verified   where 	go Nothing = giveup "tahoe capability is not known" 	go (Just cap) = unlessM (liftIO $ requestTahoe hdl "get" [Param cap, File d]) $

@@ -2,7 +2,7 @@  -  - Most things should not need this, using Types instead  -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -11,16 +11,21 @@  import Types.Key import Types.KeySource- import Utility.Metered import Utility.FileSystemEncoding +import Data.ByteString (ByteString)+ data BackendA a = Backend 	{ backendVariety :: KeyVariety 	, genKey :: Maybe (KeySource -> MeterUpdate -> a Key)-	-- Verifies the content of a key using a hash. This does not need-	-- to be cryptographically secure.+	-- Verifies the content of a key, stored in a file, using a hash.+	-- This does not need to be cryptographically secure. 	, verifyKeyContent :: Maybe (Key -> RawFilePath -> a Bool)+	-- Incrementally verifies the content of a key, using the same+	-- hash as verifyKeyContent, but with the content provided+	-- incrementally a peice at a time, until finalized.+	, verifyKeyContentIncrementally :: Maybe (Key -> a IncrementalVerifier) 	-- Checks if a key can be upgraded to a better form. 	, canUpgradeKey :: Maybe (Key -> Bool) 	-- Checks if there is a fast way to migrate a key to a different@@ -38,3 +43,11 @@  instance Eq (BackendA a) where 	a == b = backendVariety a == backendVariety b++data IncrementalVerifier = IncrementalVerifier+	{ updateIncremental :: ByteString -> IO ()+	-- ^ Called repeatedly on each peice of the content.+	, finalizeIncremental :: IO Bool+	-- ^ Called once the full content has been sent, returns true+	-- if the hash verified.+	}

@@ -1,14 +1,17 @@ {- git-annex command data types  -- - Copyright 2010-2019 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE RankNTypes #-}+ module Types.Command where  import Data.Ord import Options.Applicative.Types (Parser)+import Options.Applicative.Builder (InfoMod)  import Types import Types.DeferredParse@@ -82,6 +85,8 @@ 	-- ^ description of command for usage 	, cmdparser :: CommandParser 	-- ^ command line parser+	, cmdinfomod :: forall a. InfoMod a+	-- ^ command-specific modifier for ParserInfo 	, cmdglobaloptions :: [GlobalOption] 	-- ^ additional global options 	, cmdnorepo :: Maybe (Parser (IO ()))@@ -115,6 +120,7 @@ 	| SectionUtility 	| SectionPlumbing 	| SectionTesting+	| SectionAddOn 	deriving (Eq, Ord, Enum, Bounded)  descSection :: CommandSection -> String@@ -126,3 +132,4 @@ descSection SectionUtility = "Utility commands" descSection SectionPlumbing = "Plumbing commands" descSection SectionTesting = "Testing commands"+descSection SectionAddOn = "Addon commands"

@@ -205,7 +205,7 @@ 	, annexRetryDelay = Seconds 		<$> getmayberead (annexConfig "retrydelay") 	, annexStallDetection =-		either (const Nothing) Just . parseStallDetection+		either (const Nothing) id . parseStallDetection 			=<< getmaybe (annexConfig "stalldetection") 	, annexAllowedUrlSchemes = S.fromList $ map mkScheme $ 		maybe ["http", "https", "ftp"] words $@@ -377,7 +377,7 @@ 		, remoteAnnexRetryDelay = Seconds 			<$> getmayberead "retrydelay" 		, remoteAnnexStallDetection =-			either (const Nothing) Just . parseStallDetection+			either (const Nothing) id . parseStallDetection 				=<< getmaybe "stalldetection" 		, remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ 			getmaybe ("security-allow-unverified-downloads")

@@ -197,7 +197,9 @@ 	-- ok, so if verification is disabled, don't verify it 	| Verified 	-- ^ Content was verified during transfer, so don't verify it-	-- again.+	-- again. The verification does not need to use a+	-- cryptographically secure hash, but the hash does need to+	-- have preimage resistance. 	| MustVerify 	-- ^ Content likely to have been altered during transfer, 	-- verify even if verification is normally disabled

@@ -1,6 +1,6 @@ {- types for stall detection  -- - Copyright 2020 Joey Hess <id@joeyh.name>+ - Copyright 2020-2021 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -10,20 +10,33 @@ import Utility.DataUnits import Utility.HumanTime import Utility.Misc+import Git.Config --- Unless the given number of bytes have been sent over the given--- amount of time, there's a stall.-data StallDetection = StallDetection ByteSize Duration+data StallDetection+	= StallDetection ByteSize Duration+	-- ^ Unless the given number of bytes have been sent over the given+	-- amount of time, there's a stall.+	| ProbeStallDetection+	-- ^ Used when unsure how frequently transfer progress is updated,+	-- or how fast data can be sent.+	| StallDetectionDisabled 	deriving (Show)  -- Parse eg, "0KiB/60s"-parseStallDetection :: String -> Either String StallDetection-parseStallDetection s = -	let (bs, ds) = separate (== '/') s-	in do+--+-- Also, it can be set to "true" (or other git config equivilants)+-- to enable ProbeStallDetection. +-- And "false" (and other git config equivilants) explicitly+-- disable stall detection.+parseStallDetection :: String -> Either String (Maybe StallDetection)+parseStallDetection s = case isTrueFalse s of+	Nothing -> do+		let (bs, ds) = separate (== '/') s 		b <- maybe  			(Left $ "Unable to parse stall detection amount " ++ bs) 			Right 			(readSize dataUnits bs) 		d <- parseDuration ds-		return (StallDetection b d)+		return (Just (StallDetection b d))+	Just True -> Right (Just ProbeStallDetection)+	Just False -> Right (Just StallDetectionDisabled)

@@ -57,7 +57,7 @@ getBatchCommandMaker :: IO BatchCommandMaker getBatchCommandMaker = do #ifndef mingw32_HOST_OS-	nicers <- filterM (inPath . fst)+	nicers <- filterM (inSearchPath . fst) 		[ ("nice", []) 		, ("ionice", ["-c3"]) 		, ("nocache", [])

@@ -133,7 +133,7 @@ 	mapM_ Posix.closeFd $ M.keys toremove 	return rest   where-	(toremove, rest) = M.partition (dirContains dir . dirName) dirmap+	(toremove, rest) = M.partition (dirContains (toRawFilePath dir) . toRawFilePath . dirName) dirmap  findDirContents :: DirMap -> FilePath -> [FilePath] findDirContents dirmap dir = concatMap absolutecontents $ search

@@ -411,7 +411,7 @@  - is returned.  -} testHarness :: FilePath -> GpgCmd -> IO a -> IO (Maybe a)-testHarness tmpdir cmd a = ifM (inPath (unGpgCmd cmd))+testHarness tmpdir cmd a = ifM (inSearchPath (unGpgCmd cmd)) 	( bracket (eitherToMaybe <$> tryNonAsync setup) cleanup go 	, return Nothing 	)@@ -439,7 +439,7 @@ 	-- other daemons. Stop them when done. This only affects 	-- daemons started for the GNUPGHOME that was used. 	-- Older gpg may not support this, so ignore failure.-	stopgpgagent = whenM (inPath "gpgconf") $+	stopgpgagent = whenM (inSearchPath "gpgconf") $ 		void $ boolSystem "gpgconf" [Param "--kill", Param "all"]  	go (Just _) = Just <$> a

@@ -2,29 +2,57 @@  module Utility.Hash ( 	sha1,+	sha1_context, 	sha2_224,+	sha2_224_context, 	sha2_256,+	sha2_256_context, 	sha2_384,+	sha2_384_context, 	sha2_512,+	sha2_512_context, 	sha3_224,+	sha3_224_context, 	sha3_256,+	sha3_256_context, 	sha3_384,+	sha3_384_context, 	sha3_512,+	sha3_512_context, 	skein256,+	skein256_context, 	skein512,+	skein512_context, 	blake2s_160,+	blake2s_160_context, 	blake2s_224,+	blake2s_224_context, 	blake2s_256,+	blake2s_256_context, 	blake2sp_224,+	blake2sp_224_context, 	blake2sp_256,+	blake2sp_256_context, 	blake2b_160,+	blake2b_160_context, 	blake2b_224,+	blake2b_224_context, 	blake2b_256,+	blake2b_256_context, 	blake2b_384,+	blake2b_384_context, 	blake2b_512,+	blake2b_512_context, 	blake2bp_512,+	blake2bp_512_context, 	md5,+	md5_context, 	md5s,+	hashUpdate,+	hashFinalize,+	Digest,+	HashAlgorithm,+	Context, 	props_hashes_stable, 	Mac(..), 	calcMac,@@ -35,77 +63,146 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import qualified Data.Text.Encoding as T-import "cryptonite" Crypto.MAC.HMAC+import "cryptonite" Crypto.MAC.HMAC hiding (Context) import "cryptonite" Crypto.Hash  sha1 :: L.ByteString -> Digest SHA1 sha1 = hashlazy +sha1_context :: Context SHA1+sha1_context = hashInit+ sha2_224 :: L.ByteString -> Digest SHA224 sha2_224 = hashlazy +sha2_224_context :: Context SHA224+sha2_224_context = hashInit+ sha2_256 :: L.ByteString -> Digest SHA256 sha2_256 = hashlazy +sha2_256_context :: Context SHA256+sha2_256_context = hashInit+ sha2_384 :: L.ByteString -> Digest SHA384 sha2_384 = hashlazy +sha2_384_context :: Context SHA384+sha2_384_context = hashInit+ sha2_512 :: L.ByteString -> Digest SHA512 sha2_512 = hashlazy +sha2_512_context :: Context SHA512+sha2_512_context = hashInit+ sha3_224 :: L.ByteString -> Digest SHA3_224 sha3_224 = hashlazy +sha3_224_context :: Context SHA3_224+sha3_224_context = hashInit+ sha3_256 :: L.ByteString -> Digest SHA3_256 sha3_256 = hashlazy +sha3_256_context :: Context SHA3_256+sha3_256_context = hashInit+ sha3_384 :: L.ByteString -> Digest SHA3_384 sha3_384 = hashlazy +sha3_384_context :: Context SHA3_384+sha3_384_context = hashInit+ sha3_512 :: L.ByteString -> Digest SHA3_512 sha3_512 = hashlazy +sha3_512_context :: Context SHA3_512+sha3_512_context = hashInit+ skein256 :: L.ByteString -> Digest Skein256_256 skein256 = hashlazy +skein256_context :: Context Skein256_256+skein256_context = hashInit+ skein512 :: L.ByteString -> Digest Skein512_512 skein512 = hashlazy +skein512_context :: Context Skein512_512+skein512_context = hashInit+ blake2s_160 :: L.ByteString -> Digest Blake2s_160 blake2s_160 = hashlazy +blake2s_160_context :: Context Blake2s_160+blake2s_160_context = hashInit+ blake2s_224 :: L.ByteString -> Digest Blake2s_224 blake2s_224 = hashlazy +blake2s_224_context :: Context Blake2s_224+blake2s_224_context = hashInit+ blake2s_256 :: L.ByteString -> Digest Blake2s_256 blake2s_256 = hashlazy +blake2s_256_context :: Context Blake2s_256+blake2s_256_context = hashInit+ blake2sp_224 :: L.ByteString -> Digest Blake2sp_224 blake2sp_224 = hashlazy +blake2sp_224_context :: Context Blake2sp_224+blake2sp_224_context = hashInit+ blake2sp_256 :: L.ByteString -> Digest Blake2sp_256 blake2sp_256 = hashlazy +blake2sp_256_context :: Context Blake2sp_256+blake2sp_256_context = hashInit+ blake2b_160 :: L.ByteString -> Digest Blake2b_160 blake2b_160 = hashlazy +blake2b_160_context :: Context Blake2b_160+blake2b_160_context = hashInit+ blake2b_224 :: L.ByteString -> Digest Blake2b_224 blake2b_224 = hashlazy +blake2b_224_context :: Context Blake2b_224+blake2b_224_context = hashInit+ blake2b_256 :: L.ByteString -> Digest Blake2b_256 blake2b_256 = hashlazy +blake2b_256_context :: Context Blake2b_256+blake2b_256_context = hashInit+ blake2b_384 :: L.ByteString -> Digest Blake2b_384 blake2b_384 = hashlazy +blake2b_384_context :: Context Blake2b_384+blake2b_384_context = hashInit+ blake2b_512 :: L.ByteString -> Digest Blake2b_512 blake2b_512 = hashlazy +blake2b_512_context :: Context Blake2b_512+blake2b_512_context = hashInit+ blake2bp_512 :: L.ByteString -> Digest Blake2bp_512 blake2bp_512 = hashlazy +blake2bp_512_context :: Context Blake2bp_512+blake2bp_512_context = hashInit+ md5 ::  L.ByteString -> Digest MD5 md5 = hashlazy++md5_context :: Context MD5+md5_context = hashInit  md5s ::  S.ByteString -> Digest MD5 md5s = hash

@@ -169,4 +169,4 @@ 			ExitFailure _ -> False  isInstalled :: IO Bool-isInstalled = inPath "wormhole"+isInstalled = inSearchPath "wormhole"

@@ -10,7 +10,7 @@  - Is forgiving about misplaced closing parens, so "foo and (bar or baz"  - will be handled, as will "foo and ( bar or baz ) )"  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -57,7 +57,7 @@  {- Converts a list of Tokens into a Matcher. -} generate :: [Token op] -> Matcher op-generate = simplify . process MAny . tokenGroups+generate = simplify . process MAny . implicitAnd . tokenGroups   where 	process m [] = m 	process m ts = uncurry process $ consume m ts@@ -108,6 +108,16 @@ 			in go (Group (reverse c') : c) ts' 		dispatch _ = go (One t:c) ts +implicitAnd :: [TokenGroup op] -> [TokenGroup op]+implicitAnd [] = []+implicitAnd [v] = [v]+implicitAnd (a:b:rest) | need a && need b = a : One And : implicitAnd (b:rest)+  where+	need (One (Operation _)) = True+	need (Group _) = True+	need _ = False+implicitAnd (a:rest) = a : implicitAnd rest+ {- Checks if a Matcher matches, using a supplied function to check  - the value of Operations. -} match :: (op -> v -> Bool) -> Matcher op -> v -> Bool@@ -153,27 +163,56 @@ introspect = any  prop_matcher_sane :: Bool-prop_matcher_sane = all (\m -> match dummy m ()) $ map generate-	[ [Operation True]-	, []-	, [Operation False, Or, Operation True, Or, Operation False]-	, [Operation True, Or, Operation True]-	, [Operation True, And, Operation True]-	, [Not, Open, Operation True, And, Operation False, Close]-	, [Not, Open, Not, Open, Not, Operation False, Close, Close]-	, [Not, Open, Not, Open, Not, Open, Not, Operation True, Close, Close]-	, [Operation True, And, Not, Operation False]-	, [Operation True, Not, Operation False]-	, [Operation True, Not, Not, Not, Operation False]-	, [Operation True, Not, Not, Not, Operation False, And, Operation True]-	, [Operation True, Not, Not, Not, Operation False, Operation True]-	, [Not, Open, Operation True, And, Operation False, Close, -		And, Open, -			Open, Operation True, And, Operation False, Close,-			Or,-			Open, Operation True, And, Open, Not, Operation False, Close, Close,-		Close, And,-			Open, Not, Operation False, Close]+prop_matcher_sane = and+	[ all (\m -> match (\b _ -> b) m ()) (map generate evaltrue)+	, all (\(x,y) -> generate x == generate y) evalsame 	]   where-	dummy b _ = b+	evaltrue =+		[ [Operation True]+		, []+		, [Operation False, Or, Operation True, Or, Operation False]+		, [Operation True, Or, Operation True]+		, [Operation True, And, Operation True]+		, [Not, Open, Operation True, And, Operation False, Close]+		, [Not, Open, Not, Open, Not, Operation False, Close, Close]+		, [Not, Open, Not, Open, Not, Open, Not, Operation True, Close, Close]+		, [Operation True, And, Not, Operation False]+		, [Operation True, Not, Operation False]+		, [Operation True, Not, Not, Not, Operation False]+		, [Operation True, Not, Not, Not, Operation False, And, Operation True]+		, [Operation True, Not, Not, Not, Operation False, Operation True]+		, [Not, Open, Operation True, And, Operation False, Close, +			And, Open, +				Open, Operation True, And, Operation False, Close,+				Or,+				Open, Operation True, And, Open, Not, Operation False, Close, Close,+			Close, And,+				Open, Not, Operation False, Close]+		]+	evalsame =+		[+			( [Operation "foo", Open, Operation "bar", Or, Operation "baz", Close]+			, [Operation "foo", And, Open, Operation "bar", Or, Operation "baz", Close]+			)+		,+			( [Operation "foo", Not, Open, Operation "bar", Or, Operation "baz", Close]+			, [Operation "foo", And, Not, Open, Operation "bar", Or, Operation "baz", Close]+			)+		,+			( [Open, Operation "bar", Or, Operation "baz", Close, Operation "foo"]+			, [Open, Operation "bar", Or, Operation "baz", Close, And, Operation "foo"]+			)+		,+			( [Open, Operation "bar", Or, Operation "baz", Close, Not, Operation "foo"]+			, [Open, Operation "bar", Or, Operation "baz", Close, And, Not, Operation "foo"]+			)+		,+			( [Operation "foo", Operation "bar"]+			, [Operation "foo", And, Operation "bar"]+			)+		,+			( [Operation "foo", Not, Operation "bar"]+			, [Operation "foo", And, Not, Operation "bar"]+			)+		]

@@ -1,6 +1,6 @@ {- Metered IO and actions  -- - Copyright 2012-2020 Joey Hess <id@joeyh.name>+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -118,23 +118,24 @@ withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h -> 	hGetContentsMetered h meterupdate >>= a -{- Writes a ByteString to a Handle, updating a meter as it's written. -}-meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO ()-meteredWrite meterupdate h = void . meteredWrite' meterupdate h+{- Calls the action repeatedly with chunks from the lazy ByteString.+ - Updates the meter after each chunk is processed. -}+meteredWrite :: MeterUpdate -> (S.ByteString -> IO ()) -> L.ByteString -> IO ()+meteredWrite meterupdate a = void . meteredWrite' meterupdate a -meteredWrite' :: MeterUpdate -> Handle -> L.ByteString -> IO BytesProcessed-meteredWrite' meterupdate h = go zeroBytesProcessed . L.toChunks +meteredWrite' :: MeterUpdate -> (S.ByteString -> IO ()) -> L.ByteString -> IO BytesProcessed+meteredWrite' meterupdate a = go zeroBytesProcessed . L.toChunks    where 	go sofar [] = return sofar 	go sofar (c:cs) = do-		S.hPut h c+		a c 		let !sofar' = addBytesProcessed sofar $ S.length c 		meterupdate sofar' 		go sofar' cs  meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO () meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h ->-	meteredWrite meterupdate h b+	meteredWrite meterupdate (S.hPut h) b  {- Applies an offset to a MeterUpdate. This can be useful when  - performing a sequence of actions, such as multiple meteredWriteFiles,

@@ -18,11 +18,12 @@ 	segmentPaths', 	runSegmentPaths, 	runSegmentPaths',-	inPath,-	searchPath, 	dotfile, 	splitShortExtensions, 	relPathDirToFileAbs,+	inSearchPath,+	searchPath,+	searchPathContents, ) where  import System.FilePath.ByteString@@ -30,11 +31,13 @@ import qualified Data.ByteString as B import Data.List import Data.Maybe+import Control.Monad import Control.Applicative import Prelude  import Utility.Monad import Utility.SystemDirectory+import Utility.Exception  #ifdef mingw32_HOST_OS import Data.Char@@ -136,33 +139,6 @@ runSegmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[r]] runSegmentPaths' si c a paths = segmentPaths' si c paths <$> a paths -{- Checks if a command is available in PATH.- -- - The command may be fully-qualified, in which case, this succeeds as- - long as it exists. -}-inPath :: String -> IO Bool-inPath command = isJust <$> searchPath command--{- Finds a command in PATH and returns the full path to it.- -- - The command may be fully qualified already, in which case it will- - be returned if it exists.- -- - Note that this will find commands in PATH that are not executable.- -}-searchPath :: String -> IO (Maybe FilePath)-searchPath command-	| P.isAbsolute command = check command-	| otherwise = P.getSearchPath >>= getM indir-  where-	indir d = check $ d P.</> command-	check f = firstM doesFileExist-#ifdef mingw32_HOST_OS-		[f, f ++ ".exe"]-#else-		[f]-#endif- {- Checks if a filename is a unix dotfile. All files inside dotdirs  - count as dotfiles. -} dotfile :: RawFilePath -> Bool@@ -213,3 +189,44 @@ #ifdef mingw32_HOST_OS 	normdrive = map toLower . takeWhile (/= ':') . fromRawFilePath . takeDrive #endif++{- Checks if a command is available in PATH.+ -+ - The command may be fully-qualified, in which case, this succeeds as+ - long as it exists. -}+inSearchPath :: String -> IO Bool+inSearchPath command = isJust <$> searchPath command++{- Finds a command in PATH and returns the full path to it.+ -+ - The command may be fully qualified already, in which case it will+ - be returned if it exists.+ -+ - Note that this will find commands in PATH that are not executable.+ -}+searchPath :: String -> IO (Maybe FilePath)+searchPath command+	| P.isAbsolute command = check command+	| otherwise = P.getSearchPath >>= getM indir+  where+	indir d = check $ d P.</> command+	check f = firstM doesFileExist+#ifdef mingw32_HOST_OS+		[f, f ++ ".exe"]+#else+		[f]+#endif++{- Finds commands in PATH that match a predicate. Note that the predicate+ - matches on the basename of the command, but the full path to it is+ - returned.+ -+ - Note that this will find commands in PATH that are not executable.+ -}+searchPathContents :: (FilePath -> Bool) -> IO [FilePath]+searchPathContents p =+	filterM doesFileExist +		=<< (concat <$> (P.getSearchPath >>= mapM go))+  where+	go d = map (d P.</>) . filter p+		<$> catchDefaultIO [] (getDirectoryContents d)

@@ -46,11 +46,11 @@ 			[] -> defcmd 			(c:ps) -> do 				let ps' = map Param ps ++ [File f]-				-- If the command is not inPath,+				-- If the command is not inSearchPath, 				-- take the base of it, and run eg "sh" 				-- which in some cases on windows will work-				-- despite it not being inPath.-				ok <- inPath c+				-- despite it not being inSearchPath.+				ok <- inSearchPath c 				return (if ok then c else takeFileName c, ps') 		_ -> defcmd #endif

@@ -71,7 +71,7 @@ #ifndef mingw32_HOST_OS mkSuCommand cmd ps = do 	pwd <- getCurrentDirectory-	firstM (\(SuCommand _ p _) -> inPath p) =<< selectcmds pwd+	firstM (\(SuCommand _ p _) -> inSearchPath p) =<< selectcmds pwd   where 	selectcmds pwd = ifM (inx <||> (not <$> atconsole)) 		( return (graphicalcmds pwd ++ consolecmds pwd)

@@ -191,4 +191,4 @@ varLibDir = "/var/lib"  torIsInstalled :: IO Bool-torIsInstalled = inPath "tor"+torIsInstalled = inSearchPath "tor"

@@ -0,0 +1,3 @@+int init_kqueue();+void addfds_kqueue(const int kq, const int fdcnt, const int *fdlist);+signed int waitchange_kqueue(const int kq);

@@ -105,15 +105,17 @@  # IMPORTING FROM A DIRECTORY -When run with a path, `git annex import` moves files from somewhere outside-the git working copy, and adds them to the annex.+When run with a path, `git annex import` **moves** files from somewhere outside+the git working copy, and adds them to the annex. In contrast to importing +from a special directory remote, imported files are **deleted from the given path**.  This is a legacy interface. It is still supported, but please consider switching to importing from a directory special remote instead, using the interface documented above.  Individual files to import can be specified. If a directory is specified,-the entire directory is imported.+the entire directory is imported. Please note that the following instruction+will **delete all files from the source directory**.               	git annex import /media/camera/DCIM/* 

@@ -741,6 +741,12 @@      See [[git-annex-benchmark]](1) for details. +# ADDON COMMANDS++In addition to all the commands listed above, more commands can be added to+git-annex by dropping commands named like "git-annex-foo" into a directory+in the PATH.+ # COMMON OPTIONS  These common options are accepted by all git-annex commands, and@@ -1416,17 +1422,27 @@  * `remote.<name>.annex-stalldetecton`, `annex.stalldetection` -  This lets stalled or too-slow transfers be detected, and dealt with, so-  rather than getting stuck, git-annex will cancel the stalled operation.-  When this happens, the transfer will be considered to have failed, so+  Configuring this lets stalled or too-slow transfers be detected, and+  dealt with, so rather than getting stuck, git-annex will cancel the+  stalled operation. The transfer will be considered to have failed, so   settings like annex.retry will control what it does next. -  The value specifies how much data git-annex should expect to see-  flowing, minimum, when it's not stalled, over a given period of time.-  The format is "$amount/$timeperiod". +  By default, git-annex detects transfers that have probably stalled,+  and suggests configuring this. If it is incorrectly detecting+  stalls, setting this to "false" will avoid that. +  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+  the form "$amount/$timeperiod" to specify how much data git-annex should+  expect to see flowing, minimum, over a given period of time.+   For example, to detect outright stalls where no data has been transferred-  after 30 seconds: `git config annex.stalldetection "0/30s"`+  after 30 seconds: `git config annex.stalldetection "1KB/30s"`    Or, if you have a remote on a USB drive that is normally capable of   several megabytes per second, but has bad sectors where it gets

@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20210127+Version: 8.20210223 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -249,6 +249,7 @@   templates/repolist.hamlet   templates/controlmenu.hamlet   templates/notifications/longpolling.julius+  Utility/libkqueue.h  Flag Assistant   Description: Enable git-annex assistant and watch command@@ -661,6 +662,7 @@     Annex.SpecialRemote     Annex.SpecialRemote.Config     Annex.Ssh+    Annex.StallDetection     Annex.TaggedPush     Annex.Tmp     Annex.Transfer@@ -669,9 +671,10 @@     Annex.UpdateInstead     Annex.UUID     Annex.Url+    Annex.VariantFile     Annex.VectorClock     Annex.VectorClock.Utility-    Annex.VariantFile+    Annex.Verify     Annex.Version     Annex.View     Annex.View.ViewedFile