git-annex 7.20190615 → 7.20190626

raw patch · 110 files changed

+1204/−841 lines, 110 files

Files

• Annex.hs +2/−2
• Annex/Action.hs +7/−13
• Annex/Concurrent.hs +117/−4
• Annex/Content.hs +3/−1
• Annex/Direct.hs +2/−1
• Annex/Drop.hs +2/−2
• Annex/Import.hs +6/−5
• Annex/Ingest.hs +14/−13
• Annex/Init.hs +1/−1
• Annex/Transfer.hs +4/−2
• Assistant/Threads/Committer.hs +2/−1
• Backend.hs +4/−3
• Backend/Hash.hs +19/−12
• Backend/URL.hs +1/−1
• Backend/WORM.hs +3/−2
• CHANGELOG +25/−0
• CmdLine.hs +1/−3
• CmdLine/Action.hs +161/−125
• CmdLine/Seek.hs +0/−1
• Command.hs +25/−15
• Command/Add.hs +19/−17
• Command/AddUrl.hs +13/−15
• Command/Adjust.hs +2/−2
• Command/CalcKey.hs +2/−1
• Command/Commit.hs +4/−4
• Command/Config.hs +11/−15
• Command/Copy.hs +1/−1
• Command/Dead.hs +2/−3
• Command/Describe.hs +2/−2
• Command/Direct.hs +11/−12
• Command/Drop.hs +9/−8
• Command/DropKey.hs +2/−3
• Command/EnableRemote.hs +13/−15
• Command/EnableTor.hs +2/−3
• Command/Expire.hs +13/−16
• Command/Export.hs +21/−23
• Command/Find.hs +5/−7
• Command/Fix.hs +1/−3
• Command/Forget.hs +2/−3
• Command/FromKey.hs +4/−5
• Command/Fsck.hs +7/−11
• Command/GCryptSetup.hs +2/−2
• Command/Get.hs +3/−5
• Command/Group.hs +6/−5
• Command/GroupWanted.hs +4/−5
• Command/Import.hs +13/−14
• Command/ImportFeed.hs +27/−24
• Command/Indirect.hs +3/−12
• Command/Init.hs +2/−3
• Command/InitRemote.hs +2/−3
• Command/Inprogress.hs +5/−11
• Command/Lock.hs +4/−5
• Command/Map.hs +2/−2
• Command/Merge.hs +5/−7
• Command/MetaData.hs +6/−8
• Command/Migrate.hs +4/−4
• Command/Mirror.hs +2/−2
• Command/Move.hs +16/−16
• Command/Multicast.hs +39/−44
• Command/NumCopies.hs +4/−7
• Command/P2P.hs +7/−9
• Command/P2PStdIO.hs +2/−2
• Command/PreCommit.hs +7/−8
• Command/ReKey.hs +2/−3
• Command/RegisterUrl.hs +7/−7
• Command/Reinit.hs +2/−3
• Command/Reinject.hs +18/−18
• Command/RenameRemote.hs +2/−3
• Command/Repair.hs +2/−1
• Command/ResolveMerge.hs +2/−3
• Command/RmUrl.hs +3/−3
• Command/Schedule.hs +8/−9
• Command/SetKey.hs +2/−3
• Command/SetPresentKey.hs +2/−3
• Command/Smudge.hs +2/−1
• Command/Sync.hs +49/−45
• Command/TestRemote.hs +3/−4
• Command/TransferKey.hs +3/−3
• Command/Trust.hs +1/−2
• Command/Unannex.hs +6/−6
• Command/Undo.hs +2/−3
• Command/Ungroup.hs +2/−2
• Command/Unlock.hs +10/−11
• Command/Unused.hs +4/−5
• Command/Upgrade.hs +2/−3
• Command/VAdd.hs +3/−4
• Command/VCycle.hs +3/−4
• Command/VFilter.hs +2/−3
• Command/VPop.hs +3/−4
• Command/View.hs +8/−9
• Command/Wanted.hs +8/−9
• Command/Whereis.hs +1/−3
• Git/FilePath.hs +1/−0
• Logs/UUID.hs +10/−5
• Messages.hs +31/−10
• Messages/Progress.hs +45/−17
• Remote/Helper/P2P.hs +3/−3
• Remote/Helper/Special.hs +2/−1
• Test/Framework.hs +7/−6
• Types/ActionItem.hs +33/−6
• Types/Backend.hs +3/−2
• Types/Command.hs +46/−14
• Types/Concurrency.hs +3/−0
• Types/Messages.hs +0/−2
• Types/WorkerPool.hs +125/−14
• Utility/InodeCache.hs +4/−0
• Utility/Url.hs +2/−2
• doc/git-annex-add.mdwn +4/−0
• doc/git-annex-drop.mdwn +10/−6
• git-annex.cabal +3/−2

@@ -142,7 +142,7 @@ 	, tempurls :: M.Map Key URLString 	, existinghooks :: M.Map Git.Hook.Hook Bool 	, desktopnotify :: DesktopNotify-	, workers :: WorkerPool AnnexState+	, workers :: Maybe (TMVar (WorkerPool AnnexState)) 	, activekeys :: TVar (M.Map Key ThreadId) 	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer) 	, keysdbhandle :: Maybe Keys.DbHandle@@ -199,7 +199,7 @@ 		, tempurls = M.empty 		, existinghooks = M.empty 		, desktopnotify = mempty-		, workers = UnallocatedWorkerPool+		, workers = Nothing 		, activekeys = emptyactivekeys 		, activeremotes = emptyactiveremotes 		, keysdbhandle = Nothing

@@ -7,7 +7,12 @@  {-# LANGUAGE CPP #-} -module Annex.Action where+module Annex.Action (+	startup,+	shutdown,+	stopCoProcesses,+	reapZombies,+) where  import qualified Data.Map as M #ifndef mingw32_HOST_OS@@ -18,10 +23,7 @@ import Annex.Common import qualified Annex import Annex.Content-import Annex.CatFile-import Annex.CheckAttr-import Annex.HashObject-import Annex.CheckIgnore+import Annex.Concurrent  {- Actions to perform each time ran. -} startup :: Annex ()@@ -34,14 +36,6 @@ 	sequence_ =<< M.elems <$> Annex.getState Annex.cleanup 	stopCoProcesses 	liftIO reapZombies -- zombies from long-running git processes--{- Stops all long-running git query processes. -}-stopCoProcesses :: Annex ()-stopCoProcesses = do-	catFileStop-	checkAttrStop-	hashObjectStop-	checkIgnoreStop  {- Reaps any zombie processes that may be hanging around.  -

@@ -1,6 +1,6 @@ {- git-annex concurrent state  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -9,10 +9,15 @@  import Annex import Annex.Common-import Annex.Action import qualified Annex.Queue+import Annex.CatFile+import Annex.CheckAttr+import Annex.HashObject+import Annex.CheckIgnore import Types.WorkerPool +import Control.Concurrent+import Control.Concurrent.STM import qualified Data.Map as M  {- Allows forking off a thread that uses a copy of the current AnnexState@@ -43,9 +48,8 @@ dupState = do 	st <- Annex.getState id 	return $ st-		{ Annex.workers = UnallocatedWorkerPool 		-- each thread has its own repoqueue-		, Annex.repoqueue = Nothing+		{ Annex.repoqueue = Nothing 		-- avoid sharing eg, open file handles 		, Annex.catfilehandles = M.empty 		, Annex.checkattrhandle = Nothing@@ -61,3 +65,112 @@ 		uncurry addCleanup 	Annex.Queue.mergeFrom st' 	changeState $ \s -> s { errcounter = errcounter s + errcounter st' }++{- Stops all long-running git query processes. -}+stopCoProcesses :: Annex ()+stopCoProcesses = do+	catFileStop+	checkAttrStop+	hashObjectStop+	checkIgnoreStop++{- 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 newstage+		let restore = maybe noop (void . changeStageTo mytid tv)+		bracket set restore (const a)++{- 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) -> WorkerStage -> Annex (Maybe WorkerStage)+changeStageTo mytid tv newstage = liftIO $+	replaceidle >>= maybe+		(return Nothing)+		(either waitidle (return . Just))+  where+	replaceidle = atomically $ do+		pool <- takeTMVar tv+		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, 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, oldstage) = atomically $ do+		pool <- waitIdleWorkerSlot newstage =<< takeTMVar tv+		putTMVar tv $ addWorkerPool (ActiveWorker myaid newstage) pool+		return (Just oldstage)++-- | Waits until there's an idle worker in the worker pool+-- for its initial stage, removes it from the pool, and returns its state.+--+-- If the worker pool is not already allocated, returns Nothing.+waitInitialWorkerSlot :: TMVar (WorkerPool Annex.AnnexState) -> STM (Maybe (Annex.AnnexState, WorkerStage))+waitInitialWorkerSlot tv = do+	pool <- takeTMVar tv+	let stage = initialStage (usedStages pool)+	st <- go stage pool+	return $ Just (st, stage)+  where+	go wantstage pool = case spareVals pool of+		[] -> retry+		(v:vs) -> do+			let pool' = pool { spareVals = vs }+			putTMVar tv =<< waitIdleWorkerSlot wantstage 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

@@ -90,6 +90,8 @@ import Utility.InodeCache import Annex.Content.LowLevel import Annex.Content.PointerFile+import Annex.Concurrent+import Types.WorkerPool  {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool@@ -387,7 +389,7 @@ 		) 	(_, MustVerify) -> verify   where-	verify = verifysize <&&> verifycontent+	verify = enteringStage VerifyStage $ verifysize <&&> verifycontent 	verifysize = case keySize k of 		Nothing -> return True 		Just size -> do

@@ -40,6 +40,7 @@ import Annex.GitOverlay import Annex.LockFile import Annex.InodeSentinal+import Utility.Metered  {- Uses git ls-files to find files that need to be committed, and stages  - them into the index. Returns True if some changes were staged. -}@@ -130,7 +131,7 @@ 		, contentLocation = file 		, inodeCache = Just cache 		}-	got =<< genKey source =<< chooseBackend file+	got =<< genKey source nullMeterUpdate=<< chooseBackend file   where 	got Nothing = do 		showEndFail

@@ -47,8 +47,8 @@  - In direct mode, all associated files are checked, and only if all  - of them are unwanted are they dropped.  -- - The runner is used to run commands, and so can be either callCommand- - or commandAction.+ - The runner is used to run CommandStart sequentially, it's typically + - callCommandAction.  -} handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex () handleDropsFrom locs rs reason fromhere key afile preverified runner = do

@@ -42,6 +42,7 @@ import Types.KeySource import Messages.Progress import Utility.DataUnits+import Utility.Metered import Logs.Export import Logs.Location import Logs.PreferredContent@@ -326,11 +327,11 @@ 		(k:_) -> return $ Left $ Just (loc, k) 		[] -> do 			job <- liftIO $ newEmptyTMVarIO-			let downloadaction = do-				showStart ("import " ++ Remote.name remote) (fromImportLocation loc)+			let ai = ActionItemOther (Just (fromImportLocation loc))+			let downloadaction = starting ("import " ++ Remote.name remote) ai $ do 				when oldversion $ 					showNote "old version"-				next $ tryNonAsync (download cidmap db i) >>= \case+				tryNonAsync (download cidmap db i) >>= \case 					Left e -> next $ do 						warning (show e) 						liftIO $ atomically $@@ -359,7 +360,7 @@ 				Nothing -> return Nothing 		checkDiskSpaceToGet tmpkey Nothing $ 			withTmp tmpkey $ \tmpfile ->-				metered Nothing tmpkey (return Nothing) $+				metered Nothing tmpkey $ 					const (rundownload tmpfile) 	  where 		ia = Remote.importActions remote@@ -373,7 +374,7 @@ 			, contentLocation = tmpfile 			, inodeCache = Nothing 			}-		fmap fst <$> genKey ks backend+		fmap fst <$> genKey ks nullMeterUpdate backend  	locworktreefilename loc = asTopFilePath $ case importtreeconfig of 		ImportTree -> fromImportLocation loc

@@ -1,6 +1,6 @@ {- git-annex content ingestion  -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -44,6 +44,7 @@ import Utility.Tmp import Utility.CopyFile import Utility.Touch+import Utility.Metered import Git.FilePath import Annex.InodeSentinal import Annex.AdjustedBranch@@ -123,13 +124,13 @@  {- Ingests a locked down file into the annex. Updates the work tree and  - index. -}-ingestAdd :: Maybe LockedDown -> Annex (Maybe Key)-ingestAdd ld = ingestAdd' ld Nothing+ingestAdd :: MeterUpdate -> Maybe LockedDown -> Annex (Maybe Key)+ingestAdd meterupdate ld = ingestAdd' meterupdate ld Nothing -ingestAdd' :: Maybe LockedDown -> Maybe Key -> Annex (Maybe Key)-ingestAdd' Nothing _ = return Nothing-ingestAdd' ld@(Just (LockedDown cfg source)) mk = do-	(mk', mic) <- ingest ld mk+ingestAdd' :: MeterUpdate -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key)+ingestAdd' _ Nothing _ = return Nothing+ingestAdd' meterupdate ld@(Just (LockedDown cfg source)) mk = do+	(mk', mic) <- ingest meterupdate ld mk 	case mk' of 		Nothing -> return Nothing 		Just k -> do@@ -148,16 +149,16 @@  {- Ingests a locked down file into the annex. Does not update the working  - tree or the index. -}-ingest :: Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache)-ingest ld mk = ingest' Nothing ld mk (Restage True)+ingest :: MeterUpdate -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache)+ingest meterupdate ld mk = ingest' Nothing meterupdate ld mk (Restage True) -ingest' :: Maybe Backend -> Maybe LockedDown -> Maybe Key -> Restage -> Annex (Maybe Key, Maybe InodeCache)-ingest' _ Nothing _ _ = return (Nothing, Nothing)-ingest' preferredbackend (Just (LockedDown cfg source)) mk restage = withTSDelta $ \delta -> do+ingest' :: Maybe Backend -> MeterUpdate -> Maybe LockedDown -> Maybe Key -> Restage -> Annex (Maybe Key, Maybe InodeCache)+ingest' _ _ Nothing _ _ = return (Nothing, Nothing)+ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage = withTSDelta $ \delta -> do 	k <- case mk of 		Nothing -> do 			backend <- maybe (chooseBackend $ keyFilename source) (return . Just) preferredbackend-			fmap fst <$> genKey source backend+			fmap fst <$> genKey source meterupdate backend 		Just k -> return (Just k) 	let src = contentLocation source 	ms <- liftIO $ catchMaybeIO $ getFileStatus src

@@ -92,7 +92,7 @@ 	u <- getUUID 	{- Avoid overwriting existing description with a default 	 - description. -}-	whenM (pure (isJust mdescription) <||> not . M.member u <$> uuidDescMap) $+	whenM (pure (isJust mdescription) <||> not . M.member u <$> uuidDescMapRaw) $ 		describeUUID u =<< genDescription mdescription  -- Everything except for uuid setup, shared clone setup, and initial

@@ -1,6 +1,6 @@ {- git-annex transfers  -- - Copyright 2012-2018 Joey Hess <id@joeyh.name>+ - Copyright 2012-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -30,7 +30,9 @@ import Annex.LockPool import Types.Key import qualified Types.Remote as Remote+import Annex.Concurrent import Types.Concurrency+import Types.WorkerPool  import Control.Concurrent import qualified Data.Map.Strict as M@@ -77,7 +79,7 @@ alwaysRunTransfer = runTransfer' True  runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v-runTransfer' ignorelock t afile retrydecider transferaction = debugLocks $ checkSecureHashes t $ do+runTransfer' ignorelock t afile retrydecider transferaction = enteringStage TransferStage $ debugLocks $ checkSecureHashes t $ do 	shouldretry <- retrydecider 	info <- liftIO $ startTransferInfo afile 	(meter, tfile, createtfile, metervar) <- mkProgressUpdater t info

@@ -41,6 +41,7 @@ import qualified Command.Sync import qualified Git.Branch import Utility.Tuple+import Utility.Metered  import Data.Time.Clock import qualified Data.Set as S@@ -331,7 +332,7 @@ 		doadd = sanitycheck ks $ do 			(mkey, mcache) <- liftAnnex $ do 				showStart "add" $ keyFilename ks-				ingest (Just $ LockedDown lockdownconfig ks) Nothing+				ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing 			maybe (failedingest change) (done change mcache $ keyFilename ks) mkey 	add _ _ = return Nothing 

@@ -22,6 +22,7 @@ import Types.Key import Types.KeySource import qualified Types.Backend as B+import Utility.Metered  -- When adding a new backend, import it here and add it to the list. import qualified Backend.Hash@@ -50,10 +51,10 @@ 	lookupname = lookupBackendVariety . parseKeyVariety . encodeBS  {- Generates a key for a file. -}-genKey :: KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend))-genKey source preferredbackend = do+genKey :: KeySource -> MeterUpdate -> Maybe Backend -> Annex (Maybe (Key, Backend))+genKey source meterupdate preferredbackend = do 	b <- maybe defaultBackend return preferredbackend-	B.getKey b source >>= return . \case+	B.getKey b source meterupdate >>= return . \case 		Nothing -> Nothing 		Just k -> Just (makesane k, b)   where

@@ -19,11 +19,14 @@ import Types.Backend import Types.KeySource import Utility.Hash+import Utility.Metered  import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Char+import Control.DeepSeq+import Control.Exception (evaluate)  data Hash 	= MD5Hash@@ -86,11 +89,11 @@ #endif  {- A key is a hash of its contents. -}-keyValue :: Hash -> KeySource -> Annex (Maybe Key)-keyValue hash source = do+keyValue :: Hash -> KeySource -> MeterUpdate -> Annex (Maybe Key)+keyValue hash source meterupdate = do 	let file = contentLocation source 	filesize <- liftIO $ getFileSize file-	s <- hashFile hash file+	s <- hashFile hash file meterupdate 	return $ Just $ stubKey 		{ keyName = encodeBS s 		, keyVariety = hashKeyVariety hash (HasExt False)@@ -98,8 +101,9 @@ 		}  {- Extension preserving keys. -}-keyValueE :: Hash -> KeySource -> Annex (Maybe Key)-keyValueE hash source = keyValue hash source >>= maybe (return Nothing) addE+keyValueE :: Hash -> KeySource -> MeterUpdate -> Annex (Maybe Key)+keyValueE hash source meterupdate =+	keyValue hash source meterupdate >>= maybe (return Nothing) addE   where 	addE k = do 		maxlen <- annexMaxExtensionLength <$> Annex.getGitConfig@@ -132,7 +136,7 @@ 	case (exists, fast) of 		(True, False) -> do 			showAction "checksum"-			check <$> hashFile hash file+			check <$> hashFile hash file nullMeterUpdate 		_ -> return True   where 	expected = decodeBS (keyHash key)@@ -204,11 +208,14 @@ 	oldvariety = keyVariety oldkey 	newvariety = backendVariety newbackend -hashFile :: Hash -> FilePath -> Annex String-hashFile hash file = liftIO $ do-	h <- hasher <$> L.readFile file-	-- Force full evaluation so file is read and closed.-	return (length h `seq` h)+hashFile :: Hash -> FilePath -> MeterUpdate -> Annex String+hashFile hash file meterupdate = +	liftIO $ withMeteredFile file meterupdate $ \b -> do+		let h = hasher 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@@ -286,7 +293,7 @@ testKeyBackend :: Backend testKeyBackend =  	let b = genBackendE (SHA2Hash (HashSize 256))-	in b { getKey = (fmap addE) <$$> getKey b } +	in b { getKey = \ks p -> (fmap addE) <$> getKey b ks p }    where 	addE k = k { keyName = keyName k <> longext } 	longext = ".this-is-a-test-key"

@@ -21,7 +21,7 @@ backend :: Backend backend = Backend 	{ backendVariety = URLKey-	, getKey = const $ return Nothing+	, getKey = \_ _ -> return Nothing 	, verifyKeyContent = Nothing 	, canUpgradeKey = Nothing 	, fastMigrate = Nothing

@@ -13,6 +13,7 @@ import Types.KeySource import Backend.Utilities import Git.FilePath+import Utility.Metered  import qualified Data.ByteString.Char8 as S8 @@ -32,8 +33,8 @@ {- The key includes the file size, modification time, and the  - original filename relative to the top of the git repository.  -}-keyValue :: KeySource -> Annex (Maybe Key)-keyValue source = do+keyValue :: KeySource -> MeterUpdate -> Annex (Maybe Key)+keyValue source _ = do 	let f = contentLocation source 	stat <- liftIO $ getFileStatus f 	sz <- liftIO $ getFileSize' f stat

@@ -1,3 +1,28 @@+git-annex (7.20190626) upstream; urgency=medium++  * get, move, copy, sync: When -J or annex.jobs has enabled concurrency,+    checksum verification uses a separate job pool than is used for+    downloads, to keep bandwidth saturated.+  * Other commands also run their cleanup phase using a separate job pool+    than their perform phase, which may make some of them somewhat faster+    when running concurrently as well.+  * When downloading an url and the destination file exists but is empty,+    avoid using http range to resume, since a range "bytes=0-" is an unusual+    edge case that it's best to avoid relying on working. This is known to+    fix a case where importfeed downloaded a partial feed from such a server.+  * importfeed: When there's a problem parsing the feed, --debug will+    output the feed content that was downloaded.+  * init: Fix a reversion in the last release that prevented automatically+    generating and setting a description for the repository.+  * add: Display progress meter when hashing files.+  * add: Support --json-progress option.+  * The Linux standalone arm build now works again on CPU versions below+    arm6. Thanks to Emanuele Olivetti, Ilias Tsitsimpis, Bernhard+    Übelacker, and Adrian Bunk for fixing ghc in Debian (bug #928882).+  * OSX dmg: Put git-annex's version in the Info.plist file.++ -- Joey Hess <id@joeyh.name>  Wed, 26 Jun 2019 12:29:46 -0400+ git-annex (7.20190615) upstream; urgency=medium    * Fixed bug that caused git-annex to fail to add a file when another

@@ -122,10 +122,8 @@  prepRunCommand :: Command -> GlobalSetter -> Annex () prepRunCommand cmd globalconfig = do-	when (cmdnomessages cmd) $ do+	when (cmdnomessages cmd) $ 		Annex.setOutput QuietOutput-		Annex.changeState $ \s -> s -			{ Annex.output = (Annex.output s) { implicitMessages = False } } 	getParsed globalconfig 	whenM (annexDebug <$> Annex.getGitConfig) $ 		liftIO enableDebugOutput

@@ -1,11 +1,11 @@-{- git-annex command-line actions+{- git-annex command-line actions and concurrency  -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, BangPatterns #-}  module CmdLine.Action where @@ -22,9 +22,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM-import Control.Exception (throwIO) import GHC.Conc-import Data.Either import qualified Data.Map.Strict as M import qualified System.Console.Regions as Regions @@ -43,164 +41,196 @@ 	showerrcount 0 = noop 	showerrcount cnt = giveup $ name ++ ": " ++ show cnt ++ " failed" +commandActions :: [CommandStart] -> Annex ()+commandActions = mapM_ commandAction+ {- Runs one of the actions needed to perform a command.  - Individual actions can fail without stopping the whole command,  - including by throwing non-async exceptions.  -   - When concurrency is enabled, a thread is forked off to run the action- - in the background, as soon as a free slot is available.+ - in the background, as soon as a free worker slot is available.    - This should only be run in the seek stage.  -} commandAction :: CommandStart -> Annex ()-commandAction a = Annex.getState Annex.concurrency >>= \case-	NonConcurrent -> run-	Concurrent n -> runconcurrent n-	ConcurrentPerCpu -> runconcurrent =<< liftIO getNumProcessors+commandAction start = Annex.getState Annex.concurrency >>= \case+	NonConcurrent -> runnonconcurrent+	Concurrent _ -> runconcurrent+	ConcurrentPerCpu -> runconcurrent   where-	run = void $ includeCommandAction a--	runconcurrent n = do-		ws <- liftIO . drainTo (n-1) =<< Annex.getState Annex.workers-		(st, ws') <- case ws of-			UnallocatedWorkerPool -> do-				-- Generate the remote list now, to avoid-				-- each thread generating it, which would-				-- be more expensive and could cause-				-- threads to contend over eg, calls to-				-- setConfig.-				_ <- remoteList-				st <- dupState-				return (st, allocateWorkerPool st (n-1))-			WorkerPool l -> findFreeSlot l-		w <- liftIO $ async $ snd <$> Annex.run st-			(inOwnConsoleRegion (Annex.output st) run)-		Annex.changeState $ \s -> s-			{ Annex.workers = addWorkerPool ws' (Right w) }+	runnonconcurrent = void $ includeCommandAction start+	runconcurrent = Annex.getState Annex.workers >>= \case+		Nothing -> runnonconcurrent+		Just tv -> +			liftIO (atomically (waitInitialWorkerSlot tv)) >>=+				maybe runnonconcurrent (runconcurrent' tv)+	runconcurrent' tv (workerst, workerstage) = do+		aid <- liftIO $ async $ snd <$> Annex.run workerst+			(concurrentjob workerst)+		liftIO $ atomically $ do+			pool <- takeTMVar tv+			let !pool' = addWorkerPool (ActiveWorker aid workerstage) pool+			putTMVar tv pool'+		void $ liftIO $ forkIO $ debugLocks $ do+			-- accountCommandAction will usually catch+			-- exceptions. Just in case, fall back to the+			-- original workerst.+			workerst' <- either (const workerst) id+				<$> waitCatch aid+			atomically $ do+				pool <- takeTMVar tv+				let !pool' = deactivateWorker pool aid workerst'+				putTMVar tv pool'+	+	concurrentjob workerst = start >>= \case+		Nothing -> noop+		Just (startmsg, perform) ->+			concurrentjob' workerst startmsg perform+	+	concurrentjob' workerst startmsg perform = case mkActionItem startmsg of+		OnlyActionOn k _ -> ensureOnlyActionOn k $+			-- If another job performed the same action while we+			-- waited, there may be nothing left to do, so re-run+			-- the start stage to see if it still wants to do+			-- something.+			start >>= \case+				Just (startmsg', perform') ->+					case mkActionItem startmsg' of+						OnlyActionOn k' _ | k' /= k ->+							concurrentjob' workerst startmsg' perform'+						_ -> mkjob workerst startmsg' perform'+				Nothing -> noop+		_ -> mkjob workerst startmsg perform+	+	mkjob workerst startmsg perform = +		inOwnConsoleRegion (Annex.output workerst) $+			void $ accountCommandAction startmsg $+				performconcurrent startmsg perform -commandActions :: [CommandStart] -> Annex ()-commandActions = mapM_ commandAction+	-- Like performCommandAction' but the worker thread's stage+	-- is changed before starting the cleanup action.+	performconcurrent startmsg perform = do+		showStartMessage startmsg+		perform >>= \case+			Just cleanup -> enteringStage CleanupStage $ do+				r <- cleanup+				showEndMessage startmsg r+				return r+			Nothing -> do+				showEndMessage startmsg False+				return False -{- Waits for any forked off command actions to finish.- -- - Merge together the cleanup actions of all the AnnexStates used by- - threads, into the current Annex's state, so they'll run at shutdown.- -- - Also merge together the errcounters of the AnnexStates.+{- Waits for all worker threads to finish and merges their AnnexStates+ - back into the current Annex's state.  -} finishCommandActions :: Annex ()-finishCommandActions = do-	ws <- Annex.getState Annex.workers-	Annex.changeState $ \s -> s { Annex.workers = UnallocatedWorkerPool }-	ws' <- liftIO $ drainTo 0 ws-	forM_ (idleWorkers ws') mergeState--{- Wait for jobs from the WorkerPool to complete, until- - the number of running jobs is not larger than the specified number.- -- - If a job throws an exception, it is propigated, but first- - all other jobs are waited for, to allow for a clean shutdown.- -}-drainTo :: Int -> WorkerPool t -> IO (WorkerPool t)-drainTo _ UnallocatedWorkerPool = pure UnallocatedWorkerPool-drainTo sz (WorkerPool l)-	| null as || sz >= length as = pure (WorkerPool l)-	| otherwise = do-		(done, ret) <- waitAnyCatch as-		let as' = filter (/= done) as-		case ret of-			Left e -> do-				void $ drainTo 0 $ WorkerPool $-					map Left sts ++ map Right as'-				throwIO e-			Right st -> do-				drainTo sz $ WorkerPool $-					map Left (st:sts) ++ map Right as'-  where-	(sts, as) = partitionEithers l--findFreeSlot :: [Worker Annex.AnnexState] -> Annex (Annex.AnnexState, WorkerPool Annex.AnnexState)-findFreeSlot = go []-  where-	go c [] = do-		st <- dupState-		return (st, WorkerPool c)-	go c (Left st:rest) = return (st, WorkerPool (c ++ rest))-	go c (v:rest) = go (v:c) rest+finishCommandActions = Annex.getState Annex.workers >>= \case+	Nothing -> noop+	Just tv -> do+		Annex.changeState $ \s -> s { Annex.workers = Nothing }+		sts <- liftIO $ atomically $ do+			pool <- readTMVar tv+			if allIdle pool+				then return (spareVals pool)+				else retry+		mapM_ mergeState sts  {- Like commandAction, but without the concurrency. -} includeCommandAction :: CommandStart -> CommandCleanup-includeCommandAction a = account =<< tryNonAsync (callCommandAction a)-  where-	account (Right True) = return True-	account (Right False) = incerr-	account (Left err) = case fromException err of+includeCommandAction start =+	start >>= \case+		Nothing -> return True+		Just (startmsg, perform) -> do+			showStartMessage startmsg+			accountCommandAction startmsg $+				performCommandAction' startmsg perform++accountCommandAction :: StartMessage -> CommandCleanup -> CommandCleanup+accountCommandAction startmsg cleanup = tryNonAsync cleanup >>= \case+	Right True -> return True+	Right False -> incerr+	Left err -> case fromException err of 		Just exitcode -> liftIO $ exitWith exitcode 		Nothing -> do 			toplevelWarning True (show err)-			implicitMessage showEndFail+			showEndMessage startmsg False 			incerr+  where 	incerr = do 		Annex.incError 		return False  {- Runs a single command action through the start, perform and cleanup- - stages, without catching errors. Useful if one command wants to run- - part of another command. -}+ - stages, without catching errors and without incrementing error counter.+ - Useful if one command wants to run part of another command. -} callCommandAction :: CommandStart -> CommandCleanup callCommandAction = fromMaybe True <$$> callCommandAction'   {- Like callCommandAction, but returns Nothing when the command did not  - perform any action. -} callCommandAction' :: CommandStart -> Annex (Maybe Bool)-callCommandAction' a = callCommandActionQuiet a >>= \case-	Nothing -> return Nothing-	Just r -> implicitMessage (showEndResult r) >> return (Just r)+callCommandAction' start = +	start >>= \case+		Nothing -> return Nothing+		Just (startmsg, perform) -> do+			showStartMessage startmsg+			Just <$> performCommandAction' startmsg perform -callCommandActionQuiet :: CommandStart -> Annex (Maybe Bool)-callCommandActionQuiet = start-  where-	start   = stage $ maybe skip perform-	perform = stage $ maybe failure cleanup-	cleanup = stage $ status-	stage = (=<<)-	skip = return Nothing-	failure = return (Just False)-	status = return . Just+performCommandAction' :: StartMessage -> CommandPerform -> CommandCleanup+performCommandAction' startmsg perform = +	perform >>= \case+		Nothing -> do+			showEndMessage startmsg False+			return False+		Just cleanup -> do+			r <- cleanup+			showEndMessage startmsg r+			return r -{- Do concurrent output when that has been requested. -}-allowConcurrentOutput :: Annex a -> Annex a-allowConcurrentOutput a = do+{- Start concurrency when that has been requested.+ - Should be run wrapping the seek stage of a command.+ -+ - Note that a duplicate of the Annex state is made here, and worker+ - threads use that state. While the worker threads are not actually+ - started here, that has the same effect.+ -}+startConcurrency :: UsedStages -> Annex a -> Annex a+startConcurrency usedstages a = do 	fromcmdline <- Annex.getState Annex.concurrency 	fromgitcfg <- annexJobs <$> Annex.getGitConfig 	let usegitcfg = Annex.changeState $  		\c -> c { Annex.concurrency = fromgitcfg } 	case (fromcmdline, fromgitcfg) of 		(NonConcurrent, NonConcurrent) -> a-		(Concurrent n, _) -> do-			raisecapabilitiesto n-			goconcurrent-		(ConcurrentPerCpu, _) -> goconcurrent+		(Concurrent n, _) ->+			goconcurrent n+		(ConcurrentPerCpu, _) ->+			goconcurrentpercpu 		(NonConcurrent, Concurrent n) -> do 			usegitcfg-			raisecapabilitiesto n-			goconcurrent+			goconcurrent n 		(NonConcurrent, ConcurrentPerCpu) -> do 			usegitcfg-			goconcurrent+			goconcurrentpercpu   where-	goconcurrent = do+	goconcurrent n = do+		raisecapabilitiesto n 		withMessageState $ \s -> case outputType s of 			NormalOutput -> ifM (liftIO concurrentOutputSupported) 				( Regions.displayConsoleRegions $-					goconcurrent' True-				, goconcurrent' False+					goconcurrent' n True+				, goconcurrent' n False 				)-			_ -> goconcurrent' False-	goconcurrent' b = bracket_ (setup b) cleanup a+			_ -> goconcurrent' n False+	goconcurrent' n b = bracket_ (setup n b) cleanup a -	setup = setconcurrentoutputenabled+	goconcurrentpercpu = goconcurrent =<< liftIO getNumProcessors +	setup n b = do+		setconcurrentoutputenabled b+		initworkerpool n+ 	cleanup = do 		finishCommandActions 		setconcurrentoutputenabled False@@ -212,20 +242,26 @@ 		c <- liftIO getNumCapabilities 		when (n > c) $ 			liftIO $ setNumCapabilities n+	+	initworkerpool n = do+		-- Generate the remote list now, to avoid each thread+		-- generating it, which would be more expensive and+		-- could cause threads to contend over eg, calls to+		-- setConfig.+		_ <- remoteList+		tv <- liftIO newEmptyTMVarIO+		Annex.changeState $ \s -> s { Annex.workers = Just tv }+		st <- dupState+		liftIO $ atomically $ putTMVar tv $+			allocateWorkerPool st (max n 1) usedstages  {- Ensures that only one thread processes a key at a time.- - Other threads will block until it's done. -}-onlyActionOn :: Key -> CommandStart -> CommandStart-onlyActionOn k a = onlyActionOn' k run-  where-	-- Run whole action, not just start stage, so other threads-	-- block until it's done.-	run = callCommandActionQuiet a >>= \case-		Nothing -> return Nothing-		Just r' -> return $ Just $ return $ Just $ return r'--onlyActionOn' :: Key -> Annex a -> Annex a-onlyActionOn' k a = go =<< Annex.getState Annex.concurrency+ - Other threads will block until it's done.+ -+ - May be called repeatedly by the same thread without blocking. -}+ensureOnlyActionOn :: Key -> Annex a -> Annex a+ensureOnlyActionOn k a = debugLocks $+	go =<< Annex.getState Annex.concurrency   where 	go NonConcurrent = a 	go (Concurrent _) = goconcurrent@@ -240,7 +276,7 @@ 			case M.lookup k m of 				Just tid 					| tid /= mytid -> retry-					| otherwise -> return (return ())+					| otherwise -> return $ return () 				Nothing -> do 					writeTVar tv $! M.insert k mytid m 					return $ liftIO $ atomically $

@@ -24,7 +24,6 @@ import CmdLine.GitAnnex.Options import Logs.Location import Logs.Unused-import Types.ActionItem import Types.Transfer import Logs.Transfer import Remote.List

@@ -1,6 +1,6 @@ {- git-annex command infrastructure  -- - Copyright 2010-2016 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -22,14 +22,13 @@ import CmdLine.GitAnnex.Options as ReExported import CmdLine.Batch as ReExported import Options.Applicative as ReExported hiding (command)-import qualified Annex import qualified Git import Annex.Init import Config import Utility.Daemon import Types.Transfer import Types.ActionItem-import Types.Messages+import Types.WorkerPool as ReExported  {- Generates a normal Command -} command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command@@ -61,19 +60,11 @@  - starting or stopping processing a file or other item. Unless --json mode  - is enabled, this also enables quiet output mode, so only things  - explicitly output by the command are shown and not progress messages- - etc. -}+ - etc.+ -} noMessages :: Command -> Command noMessages c = c { cmdnomessages = True } -{- Undoes noMessages -}-allowMessages :: Annex ()-allowMessages = do-	outputType <$> Annex.getState Annex.output >>= \case-		QuietOutput -> Annex.setOutput NormalOutput-		_ -> noop-	Annex.changeState $ \s -> s-		{ Annex.output = (Annex.output s) { implicitMessages = True } }- {- Adds a fallback action to a command, that will be run if it's used  - outside a git repository. -} noRepo :: (String -> Parser (IO ())) -> Command -> Command@@ -83,11 +74,30 @@ withGlobalOptions :: [[GlobalOption]] -> Command -> Command withGlobalOptions os c = c { cmdglobaloptions = cmdglobaloptions c ++ concat os } -{- For start and perform stages to indicate what step to run next. -}+{- For start stage to indicate what will be done. -}+starting:: MkActionItem t => String -> t -> CommandPerform -> CommandStart+starting msg t a = next (StartMessage msg (mkActionItem t), a)++{- Use when noMessages was used but the command is going to output+ - usual messages after all. -}+startingUsualMessages :: MkActionItem t => String -> t -> CommandPerform -> CommandStart+startingUsualMessages msg t a = next (StartUsualMessages msg (mkActionItem t), a)++{- When no message should be displayed at start/end, but messages can still + - be displayed when using eg includeCommandAction. -}+startingNoMessage :: MkActionItem t => t -> CommandPerform -> CommandStart+startingNoMessage t a = next (StartNoMessage (mkActionItem t), a)++{- For commands that do not display usual start or end messages, + - but have some other custom output. -}+startingCustomOutput :: MkActionItem t => t -> CommandPerform -> CommandStart+startingCustomOutput t a = next (CustomOutput (mkActionItem t), a)++{- For perform stage to indicate what step to run next. -} next :: a -> Annex (Maybe a) next a = return $ Just a -{- Or to indicate nothing needs to be done. -}+{- For start and perform stage to indicate nothing needs to be done. -} stop :: Annex (Maybe a) stop = return Nothing 

@@ -20,11 +20,12 @@ import Annex.Link import Annex.Version import Annex.Tmp+import Messages.Progress import Git.FilePath  cmd :: Command cmd = notBareRepo $ -	withGlobalOptions [jobsOption, jsonOptions, fileMatchingOptions] $+	withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, fileMatchingOptions] $ 		command "add" SectionCommon "add files to annex" 			paramPaths (seek <$$> optParser) @@ -50,7 +51,7 @@ 		)  seek :: AddOptions -> CommandSeek-seek o = allowConcurrentOutput $ do+seek o = startConcurrency commandStages $ do 	matcher <- largeFilesMatcher 	let gofile file = ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force) 		( start file@@ -78,9 +79,8 @@  {- Pass file off to git-add. -} startSmall :: FilePath -> CommandStart-startSmall file = do-	showStart "add" file-	next $ next $ addSmall file+startSmall file = starting "add" (ActionItemWorkTreeFile file) $+	next $ addSmall file  addSmall :: FilePath -> Annex Bool addSmall file = do@@ -107,11 +107,11 @@ 		Nothing -> stop 		Just s  			| not (isRegularFile s) && not (isSymbolicLink s) -> stop-			| otherwise -> do-				showStart "add" file-				next $ if isSymbolicLink s-					then next $ addFile file-					else perform file+			| otherwise -> +				starting "add" (ActionItemWorkTreeFile file) $+					if isSymbolicLink s+						then next $ addFile file+						else perform file 	addpresent key = ifM versionSupportsUnlockedPointers 		( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case 			Just s | isSymbolicLink s -> fixuplink key@@ -124,18 +124,16 @@ 			, fixuplink key 			) 		)-	fixuplink key = do+	fixuplink key = starting "add" (ActionItemWorkTreeFile file) $ do 		-- the annexed symlink is present but not yet added to git-		showStart "add" file 		liftIO $ removeFile file 		addLink file key Nothing-		next $ next $+		next $ 			cleanup key =<< inAnnex key-	fixuppointer key = do+	fixuppointer key = starting "add" (ActionItemWorkTreeFile file) $ do 		-- the pointer file is present, but not yet added to git-		showStart "add" file 		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)-		next $ next $ addFile file+		next $ addFile file  perform :: FilePath -> CommandPerform perform file = withOtherTmp $ \tmpdir -> do@@ -144,7 +142,11 @@ 		{ lockingFile = lockingfile 		, hardlinkFileTmpDir = Just tmpdir 		}-	lockDown cfg file >>= ingestAdd >>= finish+	ld <- lockDown cfg file+	let sizer = keySource <$> ld+	v <- metered Nothing sizer $ \_meter meterupdate ->+		ingestAdd meterupdate ld+	finish v   where 	finish (Just key) = next $ cleanup key True 	finish Nothing = stop

@@ -93,7 +93,7 @@ 		else pure Nothing  seek :: AddUrlOptions -> CommandSeek-seek o = allowConcurrentOutput $ do+seek o = startConcurrency commandStages $ do 	forM_ (addUrls o) (\u -> go (o, u)) 	case batchOption o of 		Batch fmt -> batchInput fmt (parseBatchInput o) go@@ -124,10 +124,9 @@ 		(Remote.checkUrl r)   where -	go _ (Left e) = void $ commandAction $ do-		showStartAddUrl u o+	go _ (Left e) = void $ commandAction $ startingAddUrl u o $ do 		warning (show e)-		next $ next $ return False+		next $ return False 	go deffile (Right (UrlContents sz mf)) = do 		let f = adjustFile o (fromMaybe (maybe deffile fromSafeFilePath mf) (fileOption (downloadOptions o))) 		void $ commandAction $ startRemote r o f u sz@@ -151,10 +150,10 @@ startRemote r o file uri sz = do 	pathmax <- liftIO $ fileNameLengthLimit "." 	let file' = joinPath $ map (truncateFilePath pathmax) $ splitDirectories file-	showStartAddUrl uri o-	showNote $ "from " ++ Remote.name r -	showDestinationFile file'-	next $ performRemote r o uri file' sz+	startingAddUrl uri o $ do+		showNote $ "from " ++ Remote.name r +		showDestinationFile file'+		performRemote r o uri file' sz  performRemote :: Remote -> AddUrlOptions -> URLString -> FilePath -> Maybe Integer -> CommandPerform performRemote r o uri file sz = ifAnnexed file adduri geturi@@ -194,8 +193,7 @@   where 	bad = fromMaybe (giveup $ "bad url " ++ urlstring) $ 		Url.parseURIRelaxed $ urlstring-	go url = do-		showStartAddUrl urlstring o+	go url = startingAddUrl urlstring o $ do 		pathmax <- liftIO $ fileNameLengthLimit "." 		urlinfo <- if relaxedOption (downloadOptions o) 			then pure Url.assumeUrlExists@@ -212,7 +210,7 @@ 						( pure $ url2file url (pathdepthOption o) pathmax 						, pure f 						)-		next $ performWeb o urlstring file urlinfo+		performWeb o urlstring file urlinfo  performWeb :: AddUrlOptions -> URLString -> FilePath -> Url.UrlInfo -> CommandPerform performWeb o url file urlinfo = ifAnnexed file addurl geturl@@ -323,12 +321,12 @@ {- The destination file is not known at start time unless the user provided  - a filename. It's not displayed then for output consistency,   - but is added to the json when available. -}-showStartAddUrl :: URLString -> AddUrlOptions -> Annex ()-showStartAddUrl url o = do-	showStart' "addurl" (Just url)+startingAddUrl :: URLString -> AddUrlOptions -> CommandPerform -> CommandStart+startingAddUrl url o p = starting "addurl" (ActionItemOther (Just url)) $ do 	case fileOption (downloadOptions o) of 		Nothing -> noop 		Just file -> maybeShowJSON $ JSONChunk [("file", file)]+	p  showDestinationFile :: FilePath -> Annex () showDestinationFile file = do@@ -374,7 +372,7 @@ 		, contentLocation = tmp 		, inodeCache = Nothing 		}-	genKey source backend >>= \case+	genKey source nullMeterUpdate backend >>= \case 		Nothing -> return Nothing 		Just (key, _) -> do 			addWorkTree u url file key (Just tmp)

@@ -47,5 +47,5 @@ start :: Adjustment -> CommandStart start adj = do 	checkVersionSupported-	showStart' "adjust" Nothing-	next $ next $ enterAdjustedBranch adj+	starting "adjust" (ActionItemOther Nothing) $+		next $ enterAdjustedBranch adj

@@ -10,6 +10,7 @@ import Command import Backend (genKey) import Types.KeySource+import Utility.Metered  cmd :: Command cmd = noCommit $ noMessages $ dontCheck repoExists $@@ -19,7 +20,7 @@ 		(batchable run (pure ()))  run :: () -> String -> Annex Bool-run _ file = genKey (KeySource file file Nothing) Nothing >>= \case+run _ file = genKey (KeySource file file Nothing) nullMeterUpdate Nothing >>= \case 	Just (k, _) -> do 		liftIO $ putStrLn $ serializeKey k 		return True

@@ -20,10 +20,10 @@ seek = withNothing (commandAction start)  start :: CommandStart-start = next $ next $ do-	Annex.Branch.commit =<< Annex.Branch.commitMessage-	_ <- runhook <=< inRepo $ Git.hookPath "annex-content"-	return True+start = starting "commit" (ActionItemOther (Just "git-annex")) $ do+		Annex.Branch.commit =<< Annex.Branch.commitMessage+		_ <- runhook <=< inRepo $ Git.hookPath "annex-content"+		next $ return True   where 	runhook (Just hook) = liftIO $ boolSystem hook [] 	runhook Nothing = return True

@@ -48,23 +48,19 @@ 		)  seek :: Action -> CommandSeek-seek (SetConfig name val) = commandAction $ do-	allowMessages-	showStart' name (Just val)-	next $ next $ do+seek (SetConfig name val) = commandAction $+	startingUsualMessages name (ActionItemOther (Just val)) $ do 		setGlobalConfig name val 		setConfig (ConfigKey name) val-		return True-seek (UnsetConfig name) = commandAction $ do-	allowMessages-	showStart' name (Just "unset")-	next $ next $ do+		next $ return True+seek (UnsetConfig name) = commandAction $+	startingUsualMessages name (ActionItemOther (Just "unset")) $do 		unsetGlobalConfig name 		unsetConfig (ConfigKey name)-		return True+		next $ return True seek (GetConfig name) = commandAction $-	getGlobalConfig name >>= \case-		Nothing -> stop-		Just v -> do-			liftIO $ putStrLn v-			stop+	startingCustomOutput (ActionItemOther Nothing) $ do+		getGlobalConfig name >>= \case+			Nothing -> return ()+			Just v -> liftIO $ putStrLn v+		next $ return True

@@ -44,7 +44,7 @@ 		<*> pure (batchOption v)  seek :: CopyOptions -> CommandSeek-seek o = allowConcurrentOutput $ do+seek o = startConcurrency commandStages $ do 	let go = whenAnnexed $ start o 	case batchOption o of 		Batch fmt -> batchFilesMatching fmt go

@@ -32,10 +32,9 @@ seek (DeadKeys ks) = commandActions $ map startKey ks  startKey :: Key -> CommandStart-startKey key = do-	showStart' "dead" (Just $ serializeKey key)+startKey key = starting "dead" (mkActionItem key) $ 	keyLocations key >>= \case-		[] -> next $ performKey key+		[] -> performKey key 		_ -> giveup "This key is still known to be present in some locations; not marking as dead." 		 performKey :: Key -> CommandPerform

@@ -22,9 +22,9 @@  start :: [String] -> CommandStart start (name:description) | not (null description) = do-	showStart' "describe" (Just name) 	u <- Remote.nameToUUID name-	next $ perform u $ unwords description+	starting "describe" (ActionItemOther (Just name)) $+		perform u $ unwords description start _ = giveup "Specify a repository and a description."	  perform :: UUID -> String -> CommandPerform

@@ -25,20 +25,22 @@  start :: CommandStart start = ifM versionSupportsDirectMode-	( ifM isDirect ( stop , next perform )+	( ifM isDirect+		( stop +		, starting "direct" (ActionItemOther Nothing)+			perform+		) 	, giveup "Direct mode is not supported by this repository version. Use git-annex unlock instead." 	)  perform :: CommandPerform perform = do-	showStart' "commit" Nothing 	showOutput 	_ <- inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit 		[ Param "-a" 		, Param "-m" 		, Param "commit before switching to direct mode" 		]-	showEndOk  	top <- fromRepo Git.repoPath 	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]@@ -49,20 +51,17 @@ 	go = whenAnnexed $ \f k -> do 		toDirectGen k f >>= \case 			Nothing -> noop-			Just a -> do-				showStart "direct" f-				tryNonAsync a >>= \case-					Left e -> warnlocked e-					Right _ -> showEndOk+			Just a -> tryNonAsync a >>= \case+				Left e -> warnlocked f e+				Right _ -> return () 		return Nothing -	warnlocked :: SomeException -> Annex ()-	warnlocked e = do-		warning $ show e+	warnlocked :: FilePath -> SomeException -> Annex ()+	warnlocked f e = do+		warning $ f ++ ": " ++ show e 		warning "leaving this file as-is; correct this problem and run git annex fsck on it"  cleanup :: CommandCleanup cleanup = do-	showStart' "direct" Nothing 	setDirect True 	return True

@@ -52,7 +52,7 @@ 	)  seek :: DropOptions -> CommandSeek-seek o = allowConcurrentOutput $+seek o = startConcurrency transferStages $ 	case batchOption o of 		Batch fmt -> batchFilesMatching fmt go 		NoBatch -> withKeyOptions (keyOptions o) (autoMode o)@@ -69,7 +69,7 @@ 	ai = mkActionItem (key, afile)  start' :: DropOptions -> Key -> AssociatedFile -> ActionItem -> CommandStart-start' o key afile ai = onlyActionOn key $ do+start' o key afile ai = do 	from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o) 	checkDropAuto (autoMode o) from afile key $ \numcopies -> 		stopUnless (want from) $@@ -89,14 +89,15 @@ startKeys o (key, ai) = start' o key (AssociatedFile Nothing) ai  startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart-startLocal afile ai numcopies key preverified = stopUnless (inAnnex key) $ do-	showStartKey "drop" key ai-	next $ performLocal key afile numcopies preverified+startLocal afile ai numcopies key preverified =+	stopUnless (inAnnex key) $+		starting "drop" (OnlyActionOn key ai) $+			performLocal key afile numcopies preverified  startRemote :: AssociatedFile -> ActionItem -> NumCopies -> Key -> Remote -> CommandStart-startRemote afile ai numcopies key remote = do-	showStartKey ("drop " ++ Remote.name remote) key ai-	next $ performRemote key afile numcopies remote+startRemote afile ai numcopies key remote = +	starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) $+		performRemote key afile numcopies remote  performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform performLocal key afile numcopies preverified = lockContentForRemoval key $ \contentlock -> do

@@ -41,9 +41,8 @@ 	parsekey = maybe (Left "bad key") Right . deserializeKey  start :: Key -> CommandStart-start key = do-	showStartKey "dropkey" key (mkActionItem key)-	next $ perform key+start key = starting "dropkey" (mkActionItem key) $+	perform key  perform :: Key -> CommandPerform perform key = ifM (inAnnex key)

@@ -54,13 +54,11 @@ -- the remote uuid. startNormalRemote :: Git.RemoteName -> [String] -> Git.Repo -> CommandStart startNormalRemote name restparams r-	| null restparams = do-		showStart' "enableremote" (Just name)-		next $ next $ do-			setRemoteIgnore r False-			r' <- Remote.Git.configRead False r-			u <- getRepoUUID r'-			return $ u /= NoUUID+	| null restparams = starting "enableremote" (ActionItemOther (Just name)) $ do+		setRemoteIgnore r False+		r' <- Remote.Git.configRead False r+		u <- getRepoUUID r'+		next $ return $ u /= NoUUID 	| otherwise = giveup $ 		"That is a normal git remote; passing these parameters does not make sense: " ++ unwords restparams @@ -73,14 +71,14 @@ 			startSpecialRemote name config $ 				Just (u, fromMaybe M.empty (M.lookup u confm)) 		_ -> unknownNameError "Unknown remote name."-startSpecialRemote name config (Just (u, c)) = do-	let fullconfig = config `M.union` c	-	t <- either giveup return (Annex.SpecialRemote.findType fullconfig)-	showStart' "enableremote" (Just name)-	gc <- maybe (liftIO dummyRemoteGitConfig) -		(return . Remote.gitconfig)-		=<< Remote.byUUID u-	next $ performSpecialRemote t u c fullconfig gc+startSpecialRemote name config (Just (u, c)) =+	starting "enableremote" (ActionItemOther (Just name)) $ do+		let fullconfig = config `M.union` c	+		t <- either giveup return (Annex.SpecialRemote.findType fullconfig)+		gc <- maybe (liftIO dummyRemoteGitConfig) +			(return . Remote.gitconfig)+			=<< Remote.byUUID u+		performSpecialRemote t u c fullconfig gc  performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> CommandPerform performSpecialRemote t u oldc c gc = do

@@ -51,15 +51,14 @@ 		then case readish =<< headMaybe os of 			Nothing -> giveup "Need user-id parameter." 			Just userid -> go uuid userid-		else do-			showStart' "enable-tor" Nothing+		else starting "enable-tor" (ActionItemOther Nothing) $ do 			gitannex <- liftIO readProgramFile 			let ps = [Param (cmdname cmd), Param (show curruserid)] 			sucommand <- liftIO $ mkSuCommand gitannex ps 			maybe noop showLongNote 				(describePasswordPrompt' sucommand) 			ifM (liftIO $ runSuCommand sucommand)-				( next $ next checkHiddenService+				( next checkHiddenService 				, giveup $ unwords $ 					[ "Failed to run as root:" , gitannex ] ++ toCommand ps 				)

@@ -58,16 +58,18 @@ start :: Expire -> Bool -> Log Activity -> UUIDDescMap -> UUID -> CommandStart start (Expire expire) noact actlog descs u = 	case lastact of-		Just ent | notexpired ent -> checktrust (== DeadTrusted) $ do-			showStart' "unexpire" (Just desc)-			showNote =<< whenactive-			unless noact $-				trustSet u SemiTrusted-		_ -> checktrust (/= DeadTrusted) $ do-			showStart' "expire" (Just desc)-			showNote =<< whenactive-			unless noact $-				trustSet u DeadTrusted+		Just ent | notexpired ent -> checktrust (== DeadTrusted) $+			starting "unexpire" (ActionItemOther (Just desc)) $ do+				showNote =<< whenactive+				unless noact $+					trustSet u SemiTrusted+				next $ return True+		_ -> checktrust (/= DeadTrusted) $+			starting "expire" (ActionItemOther (Just desc)) $ do+				showNote =<< whenactive+				unless noact $+					trustSet u DeadTrusted+				next $ return True   where 	lastact = changed <$> M.lookup u actlog 	whenactive = case lastact of@@ -83,12 +85,7 @@ 			_ -> True 	lookupexpire = headMaybe $ catMaybes $ 		map (`M.lookup` expire) [Just u, Nothing]-	checktrust want a = ifM (want <$> lookupTrust u)-		( do-			void a-			next $ next $ return True-		, stop-		)+	checktrust want = stopUnless (want <$> lookupTrust u)  data Expire = Expire (M.Map (Maybe UUID) (Maybe POSIXTime)) 

@@ -249,14 +249,14 @@ startExport :: Remote -> ExportHandle -> MVar FileUploaded -> MVar AllFilled -> Git.LsTree.TreeItem -> CommandStart startExport r db cvar allfilledvar ti = do 	ek <- exportKey (Git.LsTree.sha ti)-	stopUnless (notrecordedpresent ek) $ do-		showStart ("export " ++ name r) f-		ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))-			( next $ next $ cleanupExport r db ek loc False-			, do-				liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True))-				next $ performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar-			)+	stopUnless (notrecordedpresent ek) $+		starting ("export " ++ name r) (ActionItemOther (Just f)) $+			ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))+				( next $ cleanupExport r db ek loc False+				, do+					liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True))+					performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar+				)   where 	loc = mkExportLocation f 	f = getTopFilePath (Git.LsTree.file ti)@@ -313,17 +313,15 @@ 	eks <- forM (filter (/= nullSha) shas) exportKey 	if null eks 		then stop-		else do-			showStart ("unexport " ++ name r) f'-			next $ performUnexport r db eks loc+		else starting ("unexport " ++ name r) (ActionItemOther (Just f')) $+			performUnexport r db eks loc   where 	loc = mkExportLocation f' 	f' = getTopFilePath f  startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart-startUnexport' r db f ek = do-	showStart ("unexport " ++ name r) f'-	next $ performUnexport r db [ek] loc+startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just f')) $+	performUnexport r db [ek] loc   where 	loc = mkExportLocation f' 	f' = getTopFilePath f@@ -365,17 +363,17 @@ 	| otherwise = do 		ek <- exportKey sha 		let loc = exportTempName ek-		showStart ("unexport " ++ name r) (fromExportLocation loc)-		liftIO $ removeExportedLocation db (asKey ek) oldloc-		next $ performUnexport r db [ek] loc+		starting ("unexport " ++ name r) (ActionItemOther (Just (fromExportLocation loc))) $ do+			liftIO $ removeExportedLocation db (asKey ek) oldloc+			performUnexport r db [ek] loc   where 	oldloc = mkExportLocation oldf' 	oldf' = getTopFilePath oldf  startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart-startMoveToTempName r db f ek = do-	showStart ("rename " ++ name r) (f' ++ " -> " ++ fromExportLocation tmploc)-	next $ performRename r db ek loc tmploc+startMoveToTempName r db f ek = starting ("rename " ++ name r) +	(ActionItemOther $ Just $ f' ++ " -> " ++ fromExportLocation tmploc)+	(performRename r db ek loc tmploc)   where 	loc = mkExportLocation f' 	f' = getTopFilePath f@@ -384,9 +382,9 @@ startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart startMoveFromTempName r db ek f = do 	let tmploc = exportTempName ek-	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ do-		showStart ("rename " ++ name r) (fromExportLocation tmploc ++ " -> " ++ f')-		next $ performRename r db ek tmploc loc+	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $+		starting ("rename " ++ name r) (ActionItemOther (Just (fromExportLocation tmploc ++ " -> " ++ f'))) $+			performRename r db ek tmploc loc   where 	loc = mkExportLocation f' 	f' = getTopFilePath f

@@ -14,7 +14,6 @@ import Annex.Content import Limit import Types.Key-import Types.ActionItem import Git.FilePath import qualified Utility.Format import Utility.DataUnits@@ -65,12 +64,11 @@ -- only files inAnnex are shown, unless the user has requested -- others via a limit start :: FindOptions -> FilePath -> Key -> CommandStart-start o file key = ifM (limited <||> inAnnex key)-	( do-		showFormatted (formatOption o) file $ ("file", file) : keyVars key-		next $ next $ return True-	, stop-	)+start o file key =+	stopUnless (limited <||> inAnnex key) $+		startingCustomOutput key $ do+			showFormatted (formatOption o) file $ ("file", file) : keyVars key+			next $ return True  startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = 

@@ -54,9 +54,7 @@ 			FixAll -> fixthin 			FixSymlinks -> stop   where-	fixby a = do-		showStart "fix" file-		next a+	fixby = starting "fix" (mkActionItem (key, file)) 	fixthin = do 		obj <- calcRepo $ gitAnnexLocation key 		stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do

@@ -33,14 +33,13 @@ seek = commandAction . start  start :: ForgetOptions -> CommandStart-start o = do-	showStart' "forget" (Just "git-annex")+start o = starting "forget" (ActionItemOther (Just "git-annex")) $ do 	c <- liftIO currentVectorClock 	let basets = addTransition c ForgetGitHistory noTransitions 	let ts = if dropDead o 		then addTransition c ForgetDeadRemotes basets 		else basets-	next $ perform ts =<< Annex.getState Annex.force+	perform ts =<< Annex.getState Annex.force  perform :: Transitions -> Bool -> CommandPerform perform ts True = do

@@ -51,9 +51,8 @@ 		in if not (null keyname) && not (null file) 			then Right $ go file (mkKey keyname) 			else Left "Expected pairs of key and filename"-	go file key = do-		showStart "fromkey" file-		next $ perform key file+	go file key = starting "fromkey" (mkActionItem (key, file)) $+		perform key file  start :: Bool -> (String, FilePath) -> CommandStart start force (keyname, file) = do@@ -62,8 +61,8 @@ 		inbackend <- inAnnex key 		unless inbackend $ giveup $ 			"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"-	showStart "fromkey" file-	next $ perform key file+	starting "fromkey" (mkActionItem (key, file)) $+		perform key file  -- From user input to a Key. -- User can input either a serialized key, or an url.

@@ -88,7 +88,7 @@ 			))  seek :: FsckOptions -> CommandSeek-seek o = allowConcurrentOutput $ do+seek o = startConcurrency commandStages $ do 	from <- maybe (pure Nothing) (Just <$$> getParsed) (fsckFromOption o) 	u <- maybe getUUID (pure . Remote.uuid) from 	checkDeadRepo u@@ -586,16 +586,12 @@ 		(_, False) -> "failed to drop from" ++ Remote.name remote  runFsck :: Incremental -> ActionItem -> Key -> Annex Bool -> CommandStart-runFsck inc ai key a = ifM (needFsck inc key)-	( do-		showStartKey "fsck" key ai-		next $ do-			ok <- a-			when ok $-				recordFsckTime inc key-			next $ return ok-	, stop-	)+runFsck inc ai key a = stopUnless (needFsck inc key) $+	starting "fsck" ai $ do+		ok <- a+		when ok $+			recordFsckTime inc key+		next $ return ok  {- Check if a key needs to be fscked, with support for incremental fscks. -} needFsck :: Incremental -> Key -> Annex Bool

@@ -22,7 +22,7 @@ seek = withStrings (commandAction . start)  start :: String -> CommandStart-start gcryptid = next $ next $ do+start gcryptid = starting "gcryptsetup" (ActionItemOther Nothing) $ do 	u <- getUUID 	when (u /= NoUUID) $ 		giveup "gcryptsetup refusing to run; this repository already has a git-annex uuid!"@@ -34,6 +34,6 @@ 		then if Git.repoIsLocalBare g 			then do 				void $ Remote.GCrypt.setupRepo gcryptid g-				return True+				next $ return True 			else giveup "cannot use gcrypt in a non-bare repository" 		else giveup "gcryptsetup uuid mismatch"

@@ -38,7 +38,7 @@ 	<*> parseBatchOption  seek :: GetOptions -> CommandSeek-seek o = allowConcurrentOutput $ do+seek o = startConcurrency transferStages $ do 	from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) 	let go = whenAnnexed $ start o from 	case batchOption o of@@ -63,7 +63,7 @@ 	start' (return True) from key (AssociatedFile Nothing) ai  start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart-start' expensivecheck from key afile ai = onlyActionOn key $+start' expensivecheck from key afile ai = 	stopUnless (not <$> inAnnex key) $ stopUnless expensivecheck $ 		case from of 			Nothing -> go $ perform key afile@@ -71,9 +71,7 @@ 				stopUnless (Command.Move.fromOk src key) $ 					go $ Command.Move.fromPerform src Command.Move.RemoveNever key afile   where-	go a = do-		showStartKey "get" key ai-		next a+	go = starting "get" (OnlyActionOn key ai)  perform :: Key -> AssociatedFile -> CommandPerform perform key afile = stopUnless (getKey key afile) $

@@ -23,14 +23,15 @@  start :: [String] -> CommandStart start (name:g:[]) = do-	allowMessages-	showStart' "group" (Just name) 	u <- Remote.nameToUUID name-	next $ setGroup u (toGroup g)+	startingUsualMessages "group" (ActionItemOther (Just name)) $+		setGroup u (toGroup g) start (name:[]) = do 	u <- Remote.nameToUUID name-	liftIO . putStrLn . unwords . map fmt . S.toList =<< lookupGroups u-	stop+	startingCustomOutput (ActionItemOther Nothing) $ do+		liftIO . putStrLn . unwords . map fmt . S.toList+			=<< lookupGroups u+		next $ return True   where 	fmt (Group g) = decodeBS g start _ = giveup "Specify a repository and a group."

@@ -22,9 +22,8 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start (g:[]) = next $ performGet groupPreferredContentMapRaw (toGroup g)-start (g:expr:[]) = do-	allowMessages-	showStart' "groupwanted" (Just g)-	next $ performSet groupPreferredContentSet expr (toGroup g)+start (g:[]) = startingCustomOutput (ActionItemOther Nothing) $+	performGet groupPreferredContentMapRaw (toGroup g)+start (g:expr:[]) = startingUsualMessages "groupwanted" (ActionItemOther (Just g)) $+	performSet groupPreferredContentSet expr (toGroup g) start _ = giveup "Specify a group."

@@ -32,6 +32,7 @@ import Git.Types import Git.Branch import Types.Import+import Utility.Metered  import Control.Concurrent.STM @@ -96,7 +97,7 @@ 		)  seek :: ImportOptions -> CommandSeek-seek o@(LocalImportOptions {}) = allowConcurrentOutput $ do+seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do 	repopath <- liftIO . absPath =<< fromRepo Git.repoPath 	inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o) 	unless (null inrepops) $ do@@ -104,7 +105,7 @@ 	largematcher <- largeFilesMatcher 	(commandAction . startLocal largematcher (duplicateMode o)) 		`withPathContents` importFiles o-seek o@(RemoteImportOptions {}) = allowConcurrentOutput $ do+seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do 	r <- getParsed (importFromRemote o) 	unlessM (Remote.isImportSupported r) $ 		giveup "That remote does not support imports."@@ -117,9 +118,8 @@ startLocal :: GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart startLocal largematcher mode (srcfile, destfile) = 	ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile)-		( do-			showStart "import" destfile-			next pickaction+		( starting "import" (ActionItemWorkTreeFile destfile)+			pickaction 		, stop 		)   where@@ -199,7 +199,7 @@ 				} 			} 		ifM (checkFileMatcher largematcher destfile)-			( ingestAdd' (Just ld') (Just k)+			( ingestAdd' nullMeterUpdate (Just ld') (Just k) 				>>= maybe 					stop 					(\addedk -> next $ Command.Add.cleanup addedk True)@@ -220,7 +220,7 @@ 		case v of 			Just ld -> do 				backend <- chooseBackend destfile-				v' <- genKey (keySource ld) backend+				v' <- genKey (keySource ld) nullMeterUpdate backend 				case v' of 					Just (k, _) -> a (ld, k) 					Nothing -> giveup "failed to generate a key"@@ -280,7 +280,8 @@ 				, ". Re-run command to resume import." 				] 			Just imported -> void $-				includeCommandAction $ commitimport imported+				includeCommandAction $ +					commitimport imported   where 	importmessage = "import from " ++ Remote.name remote @@ -289,9 +290,8 @@ 	fromtrackingbranch a = inRepo $ a (fromRemoteTrackingBranch tb)  listContents :: Remote -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart-listContents remote tvar = do-	showStart' "list" (Just (Remote.name remote))-	next $ listImportableContents remote >>= \case+listContents remote tvar = starting "list" (ActionItemOther (Just (Remote.name remote))) $+	listImportableContents remote >>= \case 		Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote 		Just importable -> do 			importable' <- makeImportMatcher remote >>= \case@@ -302,9 +302,8 @@ 				return True  commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents Key -> CommandStart-commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable = do-	showStart' "update" (Just $ fromRef $ fromRemoteTrackingBranch tb)-	next $ do+commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable =+	starting "update" (ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb)) $ do 		importcommit <- buildImportCommit remote importtreeconfig importcommitconfig importable 		next $ updateremotetrackingbranch importcommit 		

@@ -21,6 +21,7 @@ import System.Locale #endif import qualified Data.Text as T+import System.Log.Logger  import Command import qualified Annex@@ -66,32 +67,34 @@ seek :: ImportFeedOptions -> CommandSeek seek o = do 	cache <- getCache (templateOption o)-	withStrings (commandAction . start o cache) (feedUrls o)--start :: ImportFeedOptions -> Cache -> URLString -> CommandStart-start opts cache url = do-	showStart' "importfeed" (Just url)-	next $ perform opts cache url+	forM_ (feedUrls o) (getFeed o cache) -perform :: ImportFeedOptions -> Cache -> URLString -> CommandPerform-perform opts cache url = go =<< downloadFeed url+getFeed :: ImportFeedOptions -> Cache -> URLString -> CommandSeek+getFeed opts cache url = do+	showStart "importfeed" url+	downloadFeed url >>= \case+		Nothing -> showEndResult =<< feedProblem url+			"downloading the feed failed"+		Just feedcontent -> case parseFeedString feedcontent of+			Nothing -> debugfeedcontent feedcontent "parsing the feed failed"+			Just f -> case findDownloads url f of+				[] -> debugfeedcontent feedcontent "bad feed content; no enclosures to download"+				l -> do+					showEndOk+					ifM (and <$> mapM (performDownload opts cache) l)+						( clearFeedProblem url+						, void $ feedProblem url +							"problem downloading some item(s) from feed"+						)   where-	go Nothing = next $ feedProblem url "downloading the feed failed"-	go (Just feedcontent) = case parseFeedString feedcontent of-		Nothing -> next $ feedProblem url "parsing the feed failed"-		Just f -> case findDownloads url f of-			[] -> next $-				feedProblem url "bad feed content; no enclosures to download"-			l -> do-				showOutput-				ok <- and <$> mapM (performDownload opts cache) l-				next $ cleanup url ok--cleanup :: URLString -> Bool -> CommandCleanup-cleanup url True = do-	clearFeedProblem url-	return True-cleanup url False = feedProblem url "problem downloading some item(s) from feed"+	debugfeedcontent feedcontent msg = do+		liftIO $ debugM "feed content" $ unlines+			[ "start of feed content"+			, feedcontent+			, "end of feed content"+			]+		showEndResult =<< feedProblem url+			(msg ++ " (use --debug to see the feed content that was downloaded)")  data ToDownload = ToDownload 	{ feed :: Feed

@@ -36,20 +36,19 @@ 			giveup "Git is configured to not use symlinks, so you must use direct mode." 		whenM probeCrippledFileSystem $ 			giveup "This repository seems to be on a crippled filesystem, you must use direct mode."-		next perform+		starting "indirect" (ActionItemOther Nothing) +			perform 	, stop 	)  perform :: CommandPerform perform = do-	showStart' "commit" Nothing 	whenM stageDirect $ do 		showOutput 		void $ inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit 			[ Param "-m" 			, Param "commit before switching to indirect mode" 			]-	showEndOk  	-- Note that we set indirect mode early, so that we can use 	-- moveAnnex in indirect mode.@@ -59,7 +58,7 @@ 	(l, clean) <- inRepo $ Git.LsFiles.stagedOthersDetails [top] 	forM_ l go 	void $ liftIO clean-	next cleanup+	next $ return True   where 	{- Walk tree from top and move all present direct mode files into 	 - the annex, replacing with symlinks. Also delete direct mode@@ -80,7 +79,6 @@ 	go _ = noop  	fromdirect f k = do-		showStart "indirect" f 		removeInodeCache k 		removeAssociatedFiles k 		whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do@@ -92,14 +90,7 @@ 				Right False -> warnlocked "Failed to move file to annex" 				Left e -> catchNonAsync (restoreFile f k e) $ 					warnlocked . show-		showEndOk  	warnlocked msg = do 		warning msg 		warning "leaving this file as-is; correct this problem and run git annex add on it"-	-cleanup :: CommandCleanup-cleanup = do-	showStart' "indirect" Nothing-	showEndOk-	return True

@@ -46,9 +46,8 @@ seek = commandAction . start  start :: InitOptions -> CommandStart-start os = do-	showStart' "init" (Just $ initDesc os)-	next $ perform os+start os = starting "init" (ActionItemOther (Just $ initDesc os)) $+	perform os  perform :: InitOptions -> CommandPerform perform os = do

@@ -37,9 +37,8 @@ 			, do 				let c = newConfig name 				t <- either giveup return (findType config)--				showStart' "initremote" (Just name)-				next $ perform t name $ M.union config c+				starting "initremote" (ActionItemOther (Just name)) $+					perform t name $ M.union config c 			) 	)   where

@@ -45,17 +45,11 @@ start :: S.Set Key -> FilePath -> Key -> CommandStart start s _file k 	| S.member k s = start' k-	| otherwise = notInprogress+	| otherwise = stop  start' :: Key -> CommandStart-start' k = do+start' k = startingCustomOutput k $ do 	tmpf <- fromRepo $ gitAnnexTmpObjectLocation k-	ifM (liftIO $ doesFileExist tmpf)-		( next $ next $ do-			liftIO $ putStrLn tmpf-			return True-		, notInprogress-		)--notInprogress :: CommandStart-notInprogress = stop+	whenM (liftIO $ doesFileExist tmpf) $+		liftIO $ putStrLn tmpf+	next $ return True

@@ -41,8 +41,7 @@ startNew :: FilePath -> Key -> CommandStart startNew file key = ifM (isJust <$> isAnnexLink file) 	( stop-	, do-		showStart "lock" file+	, starting "lock" (mkActionItem (key, file)) $ 		go =<< liftIO (isPointerFile file) 	)   where@@ -57,7 +56,7 @@ 				, errorModified 				) 			)-	cont = next $ performNew file key+	cont = performNew file key  performNew :: FilePath -> Key -> CommandPerform performNew file key = do@@ -106,10 +105,10 @@  startOld :: FilePath -> CommandStart startOld file = do-	showStart "lock" file 	unlessM (Annex.getState Annex.force) 		errorModified-	next $ performOld file+	starting "lock" (ActionItemWorkTreeFile file) $+		performOld file  performOld :: FilePath -> CommandPerform performOld file = do

@@ -40,7 +40,7 @@ seek = withNothing (commandAction start)  start :: CommandStart-start = do+start = startingNoMessage (ActionItemOther Nothing) $ do 	rs <- combineSame <$> (spider =<< gitRepo)  	umap <- uuidDescMap@@ -49,7 +49,7 @@ 	file <- (</>) <$> fromRepo gitAnnexDir <*> pure "map.dot"  	liftIO $ writeFile file (drawMap rs trustmap umap)-	next $ next $+	next $ 		ifM (Annex.getState Annex.fast) 			( runViewer file [] 			, runViewer file

@@ -23,13 +23,11 @@ 	commandAction mergeSynced  mergeBranch :: CommandStart-mergeBranch = do-	showStart' "merge" (Just "git-annex")-	next $ do-		Annex.Branch.update-		-- commit explicitly, in case no remote branches were merged-		Annex.Branch.commit =<< Annex.Branch.commitMessage-		next $ return True+mergeBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do+	Annex.Branch.update+	-- commit explicitly, in case no remote branches were merged+	Annex.Branch.commit =<< Annex.Branch.commitMessage+	next $ return True  mergeSynced :: CommandStart mergeSynced = do

@@ -99,14 +99,13 @@  startKeys :: VectorClock -> MetaDataOptions -> (Key, ActionItem) -> CommandStart startKeys c o (k, ai) = case getSet o of-	Get f -> do+	Get f -> startingCustomOutput k $ do 		l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k 		liftIO $ forM_ l $ 			B8.putStrLn . fromMetaValue-		stop-	_ -> do-		showStartKey "metadata" k ai-		next $ perform c o k+		next $ return True+	_ -> starting "metadata" ai $+		perform c o k  perform :: VectorClock -> MetaDataOptions -> Key -> CommandPerform perform c o k = case getSet o of@@ -168,8 +167,7 @@ 			Nothing -> giveup $ "not an annexed file: " ++ f 	Right k -> go k (mkActionItem k)   where-	go k ai = do-		showStartKey "metadata" k ai+	go k ai = starting "metadata" ai $ do 		let o = MetaDataOptions 			{ forFiles = [] 			, getSet = if MetaData m == emptyMetaData@@ -187,7 +185,7 @@ 		-- probably less expensive than cleaner methods, 		-- such as taking from a list of increasing timestamps. 		liftIO $ threadDelay 1-		next $ perform t o k+		perform t o k 	mkModMeta (f, s) 		| S.null s = DelMeta f Nothing 		| otherwise = SetMeta f s

@@ -17,6 +17,7 @@ import qualified Annex import Logs.MetaData import Logs.Web+import Utility.Metered  cmd :: Command cmd = notDirect $ withGlobalOptions [annexedMatchingOptions] $@@ -38,9 +39,8 @@ 			newbackend <- maybe defaultBackend return  				=<< chooseBackend file 			if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists-				then do-					showStart "migrate" file-					next $ perform file key oldbackend newbackend+				then starting "migrate" (mkActionItem (key, file)) $+					perform file key oldbackend newbackend 				else stop  {- Checks if a key is upgradable to a newer representation.@@ -89,7 +89,7 @@ 			, contentLocation = content 			, inodeCache = Nothing 			}-		v <- genKey source (Just newbackend)+		v <- genKey source nullMeterUpdate (Just newbackend) 		return $ case v of 			Just (newkey, _) -> Just (newkey, False) 			_ -> Nothing

@@ -41,7 +41,7 @@ 		<*> pure (keyOptions v)  seek :: MirrorOptions -> CommandSeek-seek o = allowConcurrentOutput $ +seek o = startConcurrency transferStages $  	withKeyOptions (keyOptions o) False 		(commandAction . startKey o (AssociatedFile Nothing)) 		(withFilesInGit (commandAction . (whenAnnexed $ start o)))@@ -54,7 +54,7 @@ 	ai = mkActionItem (k, afile)  startKey :: MirrorOptions -> AssociatedFile -> (Key, ActionItem) -> CommandStart-startKey o afile (key, ai) = onlyActionOn key $ case fromToOptions o of+startKey o afile (key, ai) = case fromToOptions o of 	ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key) 		( Command.Move.toStart Command.Move.RemoveNever afile key ai =<< getParsed r 		, do

@@ -54,7 +54,7 @@ 	deriving (Show, Eq)  seek :: MoveOptions -> CommandSeek-seek o = allowConcurrentOutput $ do+seek o = startConcurrency transferStages $ do 	let go = whenAnnexed $ start (fromToOptions o) (removeWhen o) 	case batchOption o of 		Batch fmt -> batchFilesMatching fmt go@@ -74,7 +74,7 @@ 	uncurry $ start' fromto removewhen (AssociatedFile Nothing)  start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart-start' fromto removewhen afile key ai = onlyActionOn key $+start' fromto removewhen afile key ai = 	case fromto of 		Right (FromRemote src) -> 			checkFailedTransferDirection ai Download $@@ -86,9 +86,9 @@ 			checkFailedTransferDirection ai Download $ 				toHereStart removewhen afile key ai -showMoveAction :: RemoveWhen -> Key -> ActionItem -> Annex ()-showMoveAction RemoveNever = showStartKey "copy"-showMoveAction _ = showStartKey "move"+describeMoveAction :: RemoveWhen -> String+describeMoveAction RemoveNever = "copy"+describeMoveAction _ = "move"  toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart toStart removewhen afile key ai dest = do@@ -108,9 +108,9 @@ 			) 		else go False (Remote.hasKey dest key)   where-	go fastcheck isthere = do-		showMoveAction removewhen key ai-		next $ toPerform dest removewhen key afile fastcheck =<< isthere+	go fastcheck isthere =+		starting (describeMoveAction removewhen) (OnlyActionOn key ai) $+			toPerform dest removewhen key afile fastcheck =<< isthere  expectedPresent :: Remote -> Key -> Annex Bool expectedPresent dest key = do@@ -182,9 +182,9 @@ 	RemoveNever -> stopUnless (not <$> inAnnex key) go 	RemoveSafe -> go   where-	go = stopUnless (fromOk src key) $ do-		showMoveAction removewhen key ai-		next $ fromPerform src removewhen key afile+	go = stopUnless (fromOk src key) $+		starting (describeMoveAction removewhen) (OnlyActionOn key ai) $+			fromPerform src removewhen key afile  fromOk :: Remote -> Key -> Annex Bool fromOk src key @@ -247,13 +247,13 @@ 	RemoveNever -> stopUnless (not <$> inAnnex key) go 	RemoveSafe -> go   where-	go = do+	go = startingNoMessage (OnlyActionOn key ai) $ do 		rs <- Remote.keyPossibilities key 		forM_ rs $ \r ->-			includeCommandAction $ do-				showMoveAction removewhen key ai-				next $ fromPerform r removewhen key afile-		stop+			includeCommandAction $+				starting (describeMoveAction removewhen) ai $+					fromPerform r removewhen key afile+		next $ return True  {- The goal of this command is to allow the user maximum freedom to move  - files as they like, while avoiding making bad situations any worse

@@ -79,8 +79,7 @@ seek (MultiCastOptions Receive _ _) = giveup "Cannot specify list of files with --receive; this receives whatever files the sender chooses to send."  genAddress :: CommandStart-genAddress = do-	showStart' "gen-address" Nothing+genAddress = starting "gen-address" (ActionItemOther Nothing) $ do 	k <- uftpKey 	(s, ok) <- case k of 		KeyContainer s -> liftIO $ genkey (Param s)@@ -91,7 +90,7 @@ 	case (ok, parseFingerprint s) of 		(False, _) -> giveup $ "uftp_keymgt failed: " ++ s 		(_, Nothing) -> giveup $ "Failed to find fingerprint in uftp_keymgt output: " ++ s-		(True, Just fp) -> next $ next $ do+		(True, Just fp) -> next $ do 			recordFingerprint fp =<< getUUID 			return True   where@@ -123,7 +122,7 @@ 		in length os == 20 	 send :: [CommandParam] -> [FilePath] -> CommandStart-send ups fs = withTmpFile "send" $ \t h -> do+send ups fs = do 	-- Need to be able to send files with the names of git-annex 	-- keys, and uftp does not allow renaming the files that are sent. 	-- In a direct mode repository, the annex objects do not have@@ -131,47 +130,43 @@ 	-- expensive. 	whenM isDirect $ 		giveup "Sorry, multicast send cannot be done from a direct mode repository."-	-	showStart' "generating file list" Nothing-	fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs-	matcher <- Limit.getMatcher-	let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $-		liftIO $ hPutStrLn h o-	forM_ fs' $ \f -> do-		mk <- lookupFile f-		case mk of-			Nothing -> noop-			Just k -> withObjectLoc k (addlist f) (const noop)-	liftIO $ hClose h-	showEndOk--	showStart' "sending files" Nothing-	showOutput-	serverkey <- uftpKey-	u <- getUUID-	withAuthList $ \authlist -> do-		let ps =-			-- Force client authentication.-			[ Param "-c"-			, Param "-Y", Param "aes256-cbc"-			, Param "-h", Param "sha512"-			-- Picked ecdh_ecdsa for perfect forward secrecy,-			-- and because a EC key exchange algorithm is-			-- needed since all keys are EC.-			, Param "-e", Param "ecdh_ecdsa"-			, Param "-k", uftpKeyParam serverkey-			, Param "-U", Param (uftpUID u)-			-- only allow clients on the authlist-			, Param "-H", Param ("@"++authlist)-			-- pass in list of files to send-			, Param "-i", File t-			] ++ ups-		liftIO (boolSystem "uftp" ps) >>= showEndResult-	stop+	starting "sending files" (ActionItemOther Nothing) $+		withTmpFile "send" $ \t h -> do+			fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs+			matcher <- Limit.getMatcher+			let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $+				liftIO $ hPutStrLn h o+			forM_ fs' $ \f -> do+				mk <- lookupFile f+				case mk of+					Nothing -> noop+					Just k -> withObjectLoc k (addlist f) (const noop)+			liftIO $ hClose h+			+			serverkey <- uftpKey+			u <- getUUID+			withAuthList $ \authlist -> do+				let ps =+					-- Force client authentication.+					[ Param "-c"+					, Param "-Y", Param "aes256-cbc"+					, Param "-h", Param "sha512"+					-- Picked ecdh_ecdsa for perfect forward secrecy,+					-- and because a EC key exchange algorithm is+					-- needed since all keys are EC.+					, Param "-e", Param "ecdh_ecdsa"+					, Param "-k", uftpKeyParam serverkey+					, Param "-U", Param (uftpUID u)+					-- only allow clients on the authlist+					, Param "-H", Param ("@"++authlist)+					-- pass in list of files to send+					, Param "-i", File t+					] ++ ups+				liftIO (boolSystem "uftp" ps) >>= showEndResult+			next $ return True  receive :: [CommandParam] -> CommandStart-receive ups = do-	showStart' "receiving multicast files" Nothing+receive ups = starting "receiving multicast files" (ActionItemOther Nothing) $ do 	showNote "Will continue to run until stopped by ctrl-c" 	 	showOutput@@ -204,7 +199,7 @@ 				`after` boolSystemEnv "uftpd" ps (Just environ) 		mapM_ storeReceived . lines =<< liftIO (hGetContents statush) 		showEndResult =<< liftIO (wait runner)-	stop+	next $ return True  storeReceived :: FilePath -> Annex () storeReceived f = do

@@ -33,7 +33,7 @@ start _ = giveup "Specify a single number."  startGet :: CommandStart-startGet = next $ next $ do+startGet = startingCustomOutput (ActionItemOther Nothing) $ next $ do 	v <- getGlobalNumCopies 	case v of 		Just n -> liftIO $ putStrLn $ show $ fromNumCopies n@@ -46,9 +46,6 @@ 	return True  startSet :: Int -> CommandStart-startSet n = do-	allowMessages-	showStart' "numcopies" (Just $ show n)-	next $ next $ do-		setGlobalNumCopies $ NumCopies n-		return True+startSet n = startingUsualMessages "numcopies" (ActionItemOther (Just $ show n)) $ do+	setGlobalNumCopies $ NumCopies n+	next $ return True

@@ -96,9 +96,8 @@  -- Address is read from stdin, to avoid leaking it in shell history. linkRemote :: RemoteName -> CommandStart-linkRemote remotename = do-	showStart' "p2p link" (Just remotename)-	next $ next promptaddr+linkRemote remotename = starting "p2p link" (ActionItemOther (Just remotename)) $+	next promptaddr   where 	promptaddr = do 		liftIO $ putStrLn ""@@ -122,12 +121,11 @@  startPairing :: RemoteName -> [P2PAddress] -> CommandStart startPairing _ [] = giveup "No P2P networks are currrently available."-startPairing remotename addrs = do-	showStart' "p2p pair" (Just remotename)-	ifM (liftIO Wormhole.isInstalled)-		( next $ performPairing remotename addrs-		, giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/"-		) +startPairing remotename addrs = ifM (liftIO Wormhole.isInstalled)+	( starting "p2p pair" (ActionItemOther (Just remotename)) $+		performPairing remotename addrs+	, giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/"+	)   performPairing :: RemoteName -> [P2PAddress] -> CommandPerform performPairing remotename addrs = do

@@ -27,7 +27,7 @@ seek _ = giveup "missing UUID parameter"  start :: UUID -> CommandStart-start theiruuid = do+start theiruuid = startingCustomOutput (ActionItemOther Nothing) $ do 	servermode <- liftIO $ do 		ro <- Checks.checkEnvSet Checks.readOnlyEnv 		ao <- Checks.checkEnvSet Checks.appendOnlyEnv@@ -47,4 +47,4 @@ 		Left (ProtoFailureIOError e) | isEOFError e -> done 		Left e -> giveup (describeProtoFailure e)   where-	done = next $ next $ return True+	done = next $ return True

@@ -84,23 +84,22 @@ 	  startInjectUnlocked :: FilePath -> CommandStart-startInjectUnlocked f = next $ do+startInjectUnlocked f = startingCustomOutput (ActionItemOther Nothing) $ do 	unlessM (callCommandAction $ Command.Add.start f) $ 		error $ "failed to add " ++ f ++ "; canceling commit" 	next $ return True  startDirect :: [String] -> CommandStart-startDirect _ = next $ next preCommitDirect+startDirect _ = startingCustomOutput (ActionItemOther Nothing) $ +	next preCommitDirect  addViewMetaData :: View -> ViewedFile -> Key -> CommandStart-addViewMetaData v f k = do-	showStart "metadata" f-	next $ next $ changeMetaData k $ fromView v f+addViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $+	next $ changeMetaData k $ fromView v f  removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart-removeViewMetaData v f k = do-	showStart "metadata" f-	next $ next $ changeMetaData k $ unsetMetaData $ fromView v f+removeViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $+	next $ changeMetaData k $ unsetMetaData $ fromView v f  changeMetaData :: Key -> MetaData -> CommandCleanup changeMetaData k metadata = do

@@ -60,9 +60,8 @@   where 	go oldkey 		| oldkey == newkey = stop-		| otherwise = do-			showStart "rekey" file-			next $ perform file oldkey newkey+		| otherwise = starting "rekey" (ActionItemWorkTreeFile file) $+			perform file oldkey newkey  perform :: FilePath -> Key -> Key -> CommandPerform perform file oldkey newkey = do

@@ -39,16 +39,16 @@ 	(NoBatch, ps) -> withWords (commandAction . start) ps  start :: [String] -> CommandStart-start (keyname:url:[]) = do-	let key = mkKey keyname-	showStart' "registerurl" (Just url)-	next $ perform key url+start (keyname:url:[]) = +	starting "registerurl" (ActionItemOther (Just url)) $ do+		let key = mkKey keyname+		perform key url start _ = giveup "specify a key and an url"  startMass :: BatchFormat -> CommandStart-startMass fmt = do-	showStart' "registerurl" (Just "stdin")-	next (massAdd fmt)+startMass fmt = +	starting "registerurl" (ActionItemOther (Just "stdin")) $+		massAdd fmt  massAdd :: BatchFormat -> CommandPerform massAdd fmt = go True =<< map (separate (== ' ')) <$> batchLines fmt

@@ -24,9 +24,8 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start ws = do-	showStart' "reinit" (Just s)-	next $ perform s+start ws = starting "reinit" (ActionItemOther (Just s)) $+	perform s   where 	s = unwords ws 

@@ -12,6 +12,7 @@ import Annex.Content import Backend import Types.KeySource+import Utility.Metered  cmd :: Command cmd = command "reinject" SectionUtility @@ -41,28 +42,27 @@ startSrcDest :: [FilePath] -> CommandStart startSrcDest (src:dest:[]) 	| src == dest = stop-	| otherwise = notAnnexed src $ do-		showStart "reinject" dest-		next $ ifAnnexed dest go stop+	| otherwise = notAnnexed src $ ifAnnexed dest go stop   where-	go key = ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)-		( perform src key-		, giveup $ src ++ " does not have expected content of " ++ dest-		)+	go key = starting "reinject" (ActionItemOther (Just src)) $+		ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)+			( perform src key+			, giveup $ src ++ " does not have expected content of " ++ dest+			) startSrcDest _ = giveup "specify a src file and a dest file"  startKnown :: FilePath -> CommandStart-startKnown src = notAnnexed src $ do-	showStart "reinject" src-	mkb <- genKey (KeySource src src Nothing) Nothing-	case mkb of-		Nothing -> error "Failed to generate key"-		Just (key, _) -> ifM (isKnownKey key)-			( next $ perform src key-			, do-				warning "Not known content; skipping"-				next $ next $ return True-			)+startKnown src = notAnnexed src $+	starting "reinject" (ActionItemOther (Just src)) $ do+		mkb <- genKey (KeySource src src Nothing) nullMeterUpdate Nothing+		case mkb of+			Nothing -> error "Failed to generate key"+			Just (key, _) -> ifM (isKnownKey key)+				( perform src key+				, do+					warning "Not known content; skipping"+					next $ return True+				)  notAnnexed :: FilePath -> CommandStart -> CommandStart notAnnexed src = ifAnnexed src $

@@ -40,9 +40,8 @@ 				Nothing -> giveup "That is not a special remote." 				Just cfg -> go u cfg   where-	go u cfg = do-		showStart' "rename" Nothing-		next $ perform u cfg newname+	go u cfg = starting "rename" (ActionItemOther Nothing) $+		perform u cfg newname start _ = giveup "Specify an old name (or uuid or description) and a new name."  perform :: UUID -> R.RemoteConfig -> String -> CommandPerform

@@ -25,7 +25,8 @@ seek = withNothing (commandAction start)  start :: CommandStart-start = next $ next $ runRepair =<< Annex.getState Annex.force+start = starting "repair" (ActionItemOther Nothing) $ +	next $ runRepair =<< Annex.getState Annex.force  runRepair :: Bool -> Annex Bool runRepair forced = do

@@ -22,8 +22,7 @@ seek = withNothing (commandAction start)  start :: CommandStart-start = do-	showStart' "resolvemerge" Nothing+start = starting "resolvemerge" (ActionItemOther Nothing) $ do 	us <- fromMaybe nobranch <$> inRepo Git.Branch.current 	d <- fromRepo Git.localGitDir 	let merge_head = d </> "MERGE_HEAD"@@ -32,7 +31,7 @@ 	ifM (resolveMerge (Just us) them False) 		( do 			void $ commitResolvedMerge Git.Branch.ManualCommit-			next $ next $ return True+			next $ return True 		, giveup "Merge conflict could not be automatically resolved." 		)   where

@@ -42,9 +42,9 @@ 		| otherwise -> Right (reverse rf, reverse ru)  start :: (FilePath, URLString) -> CommandStart-start (file, url) = flip whenAnnexed file $ \_ key -> do-	showStart "rmurl" file-	next $ next $ cleanup url key+start (file, url) = flip whenAnnexed file $ \_ key ->+	starting "rmurl" (mkActionItem (key, AssociatedFile (Just file))) $+		next $ cleanup url key  cleanup :: String -> Key -> CommandCleanup cleanup url key = do

@@ -25,16 +25,15 @@ start :: [String] -> CommandStart start = parse   where-	parse (name:[]) = go name performGet-	parse (name:expr:[]) = go name $ \uuid -> do-		allowMessages-		showStart' "schedule" (Just name)-		performSet expr uuid-	parse _ = giveup "Specify a repository."--	go name a = do+	parse (name:[]) = do 		u <- Remote.nameToUUID name-		next $ a u+		startingCustomOutput (ActionItemOther Nothing) $+			performGet u+	parse (name:expr:[]) = do+		u <- Remote.nameToUUID name+		startingUsualMessages "schedule" (ActionItemOther (Just name)) $+			performSet expr u+	parse _ = giveup "Specify a repository."  performGet :: UUID -> CommandPerform performGet uuid = do

@@ -20,9 +20,8 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start (keyname:file:[]) = do-	showStart "setkey" file-	next $ perform file (mkKey keyname)+start (keyname:file:[]) = starting "setkey" (ActionItemOther (Just file)) $+	perform file (mkKey keyname) start _ = giveup "specify a key and a content file"  mkKey :: String -> Key

@@ -47,9 +47,8 @@ parseKeyStatus _ = Left "Bad input. Expected: key uuid value"  start :: KeyStatus -> CommandStart-start (KeyStatus k u s) = do-	showStartKey "setpresentkey" k (mkActionItem k)-	next $ perform k u s+start (KeyStatus k u s) = starting "setpresentkey" (mkActionItem k) $+	perform k u s  perform :: Key -> UUID -> LogStatus -> CommandPerform perform k u s = next $ do

@@ -21,6 +21,7 @@ import qualified Git import qualified Git.Ref import Backend+import Utility.Metered  import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L@@ -122,7 +123,7 @@ 		let norestage = Restage False 		liftIO . emitPointer 			=<< postingest-			=<< (\ld -> ingest' oldbackend ld Nothing norestage)+			=<< (\ld -> ingest' oldbackend nullMeterUpdate ld Nothing norestage) 			=<< lockDown cfg file  	postingest (Just k, _) = do

@@ -162,9 +162,12 @@ 		<*> pure (resolveMergeOverride v)  seek :: SyncOptions -> CommandSeek-seek o = allowConcurrentOutput $ do+seek o = do 	prepMerge-+	startConcurrency transferStages (seek' o)+	+seek' :: SyncOptions -> CommandSeek+seek' o = do 	let withbranch a = a =<< getCurrentBranch  	remotes <- syncRemotes (syncWith o)@@ -280,11 +283,10 @@ 	fastest = fromMaybe [] . headMaybe . Remote.byCost  commit :: SyncOptions -> CommandStart-commit o = stopUnless shouldcommit $ next $ next $ do+commit o = stopUnless shouldcommit $ starting "commit" (ActionItemOther Nothing) $ do 	commitmessage <- maybe commitMsg return (messageOption o)-	showStart' "commit" Nothing 	Annex.Branch.commit =<< Annex.Branch.commitMessage-	ifM isDirect+	next $ ifM isDirect 		( do 			void stageDirect 			void preCommitDirect@@ -321,20 +323,19 @@  mergeLocal :: [Git.Merge.MergeConfig] -> ResolveMergeOverride -> CurrBranch -> CommandStart mergeLocal mergeconfig resolvemergeoverride currbranch@(Just _, _) =-	go =<< needMerge currbranch-  where-	go Nothing = stop-	go (Just syncbranch) = do-		showStart' "merge" (Just $ Git.Ref.describe syncbranch)-		next $ next $ merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit syncbranch+	needMerge currbranch >>= \case+		Nothing -> stop+		Just syncbranch ->+			starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $+				next $ merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit syncbranch mergeLocal _ _ (Nothing, madj) = do 	b <- inRepo Git.Branch.currentUnsafe-	ifM (isJust <$> needMerge (b, madj))-		( do-			warning $ "There are no commits yet in the currently checked out branch, so cannot merge any remote changes into it."-			next $ next $ return False-		, stop-		)+	needMerge (b, madj) >>= \case+		Nothing -> stop+		Just syncbranch ->+			starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $ do+				warning $ "There are no commits yet in the currently checked out branch, so cannot merge any remote changes into it."+				next $ return False  -- Returns the branch that should be merged, if any. needMerge :: CurrBranch -> Annex (Maybe Git.Branch)@@ -395,12 +396,13 @@ 		] g  pullRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandStart-pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $ do-	showStart' "pull" (Just (Remote.name remote))-	next $ do+pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $+	starting "pull" (ActionItemOther (Just (Remote.name remote))) $ do 		showOutput-		stopUnless fetch $-			next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o)+		ifM fetch+			( next $ mergeRemote remote branch mergeconfig (resolveMergeOverride o)+			, next $ return True+			)   where 	fetch = do 		repo <- Remote.getRepo remote@@ -451,9 +453,8 @@  pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart pushRemote _o _remote (Nothing, _) = stop-pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $ do-	showStart' "push" (Just (Remote.name remote))-	next $ next $ do+pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $+	starting "push" (ActionItemOther (Just (Remote.name remote))) $ next $ do 		repo <- Remote.getRepo remote 		showOutput 		ok <- inRepoWithSshOptionsTo repo gc $@@ -628,10 +629,14 @@ 	 	gokey mvar bloom (k, _) = go (Left bloom) mvar (AssociatedFile Nothing) k -	go ebloom mvar af k = commandAction $ do-		whenM (syncFile ebloom rs af k) $-			void $ liftIO $ tryPutMVar mvar ()-		return Nothing+	go ebloom mvar af k = do+		-- Run syncFile as a command action so file transfers run+		-- concurrently.+		let ai = OnlyActionOn k (ActionItemKey k)+		commandAction $ startingNoMessage ai $ do+			whenM (syncFile ebloom rs af k) $+				void $ liftIO $ tryPutMVar mvar ()+			next $ return True  {- If it's preferred content, and we don't have it, get it from one of the  - listed remotes (preferring the cheaper earlier ones).@@ -647,7 +652,7 @@  - Returns True if any file transfers were made.  -} syncFile :: Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool-syncFile ebloom rs af k = onlyActionOn' k $ do+syncFile ebloom rs af k = do 	inhere <- inAnnex k 	locs <- map Remote.uuid <$> Remote.keyPossibilities k 	let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs@@ -689,9 +694,9 @@ 		( return [ get have ] 		, return [] 		)-	get have = includeCommandAction $ do-		showStartKey "get" k ai-		next $ next $ getKey' k af have+	get have = includeCommandAction $ starting "get" ai $+		stopUnless (getKey' k af have) $+			next $ return True  	wantput r 		| Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False@@ -764,24 +769,23 @@  cleanupLocal :: CurrBranch -> CommandStart cleanupLocal (Nothing, _) = stop-cleanupLocal (Just currb, _) = do-	showStart' "cleanup" (Just "local")-	next $ next $ do-		delbranch $ syncBranch currb-		delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name-		mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r)-			=<< listTaggedBranches-		return True+cleanupLocal (Just currb, _) = +	starting "cleanup" (ActionItemOther (Just "local")) $ +		next $ do+			delbranch $ syncBranch currb+			delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name+			mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r)+				=<< listTaggedBranches+			return True   where 	delbranch b = whenM (inRepo $ Git.Ref.exists $ Git.Ref.branchRef b) $ 		inRepo $ Git.Branch.delete b  cleanupRemote :: Remote -> CurrBranch -> CommandStart cleanupRemote _ (Nothing, _) = stop-cleanupRemote remote (Just b, _) = do-	showStart' "cleanup" (Just (Remote.name remote))-	next $ next $-		inRepo $ Git.Command.runBool+cleanupRemote remote (Just b, _) =+	starting "cleanup" (ActionItemOther (Just (Remote.name remote))) $+		next $ inRepo $ Git.Command.runBool 			[ Param "push" 			, Param "--quiet" 			, Param "--delete"

@@ -66,8 +66,7 @@ seek = commandAction . start   start :: TestRemoteOptions -> CommandStart-start o = do-	showStart' "testremote" (Just (testRemote o))+start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do 	fast <- Annex.getState Annex.fast 	r <- either giveup disableExportTree =<< Remote.byName' (testRemote o) 	ks <- case testReadonlyFile o of@@ -89,7 +88,7 @@ 	exportr <- if Remote.readonly r' 		then return Nothing 		else exportTreeVariant r'-	next $ perform rs unavailrs exportr ks+	perform rs unavailrs exportr ks   where 	basesz = fromInteger $ sizeOption o @@ -321,7 +320,7 @@ 		, inodeCache = Nothing 		} 	k <- fromMaybe (error "failed to generate random key")-		<$> Backend.getKey Backend.Hash.testKeyBackend ks+		<$> Backend.getKey Backend.Hash.testKeyBackend ks nullMeterUpdate 	_ <- moveAnnex k f 	return k 

@@ -45,9 +45,9 @@ seek o = withKeys (commandAction . start o) (keyOptions o)  start :: TransferKeyOptions -> Key -> CommandStart-start o key = case fromToOptions o of-	ToRemote dest -> next $ toPerform key (fileOption o) =<< getParsed dest-	FromRemote src -> next $ fromPerform key (fileOption o) =<< getParsed src+start o key = startingCustomOutput key $ case fromToOptions o of+	ToRemote dest -> toPerform key (fileOption o) =<< getParsed dest+	FromRemote src -> fromPerform key (fileOption o) =<< getParsed src  toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform toPerform key file remote = go Upload file $

@@ -27,9 +27,8 @@   where 	start ws = do 		let name = unwords ws-		showStart' c (Just name) 		u <- Remote.nameToUUID name-		next $ perform u+		starting c (ActionItemOther (Just name)) (perform u) 	perform uuid = do 		trustSet uuid level 		when (level == DeadTrusted) $

@@ -66,12 +66,12 @@ 		)  start :: FilePath -> Key -> CommandStart-start file key = stopUnless (inAnnex key) $ do-	showStart "unannex" file-	next $ ifM isDirect-		( performDirect file key-		, performIndirect file key-		)+start file key = stopUnless (inAnnex key) $+	starting "unannex" (mkActionItem (key, file)) $+		ifM isDirect+			( performDirect file key+			, performIndirect file key+			)  performIndirect :: FilePath -> Key -> CommandPerform performIndirect file key = do

@@ -46,9 +46,8 @@ 	withStrings (commandAction . start) ps  start :: FilePath -> CommandStart-start p = do-	showStart "undo" p-	next $ perform p+start p = starting "undo" (ActionItemOther (Just p)) $+	perform p  perform :: FilePath -> CommandPerform perform p = do

@@ -23,9 +23,9 @@  start :: [String] -> CommandStart start (name:g:[]) = do-	showStart' "ungroup" (Just name) 	u <- Remote.nameToUUID name-	next $ perform u (toGroup g)+	starting "ungroup" (ActionItemOther (Just name)) $+		perform u (toGroup g) start _ = giveup "Specify a repository and a group."  perform :: UUID -> Group -> CommandPerform

@@ -37,11 +37,10 @@  - to a pointer. -} start :: FilePath -> Key -> CommandStart start file key = ifM (isJust <$> isAnnexLink file)-	( do-		showStart "unlock" file+	( starting "unlock" (mkActionItem (key, AssociatedFile (Just file))) $ 		ifM versionSupportsUnlockedPointers-			( next $ performNew file key-			, startOld file key+			( performNew file key+			, performOld file key 			) 	, stop 	)@@ -67,22 +66,22 @@ 	Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath dest) 	return True -startOld :: FilePath -> Key -> CommandStart-startOld file key = +performOld :: FilePath -> Key -> CommandPerform+performOld file key =  	ifM (inAnnex key) 		( ifM (isJust <$> catKeyFileHEAD file)-			( next $ performOld file key+			( performOld' file key 			, do 				warning "this has not yet been committed to git; cannot unlock it"-				next $ next $ return False+				next $ return False 			) 		, do 			warning "content not present; cannot unlock"-			next $ next $ return False+			next $ return False 		) -performOld :: FilePath -> Key -> CommandPerform-performOld dest key = ifM (checkDiskSpace Nothing key 0 True)+performOld' :: FilePath -> Key -> CommandPerform+performOld' dest key = ifM (checkDiskSpace Nothing key 0 True) 	( do 		src <- calcRepo $ gitAnnexLocation key 		tmpdest <- fromRepo $ gitAnnexTmpObjectLocation key

@@ -70,8 +70,7 @@ 		Just "." -> (".", checkUnused refspec) 		Just "here" -> (".", checkUnused refspec) 		Just n -> (n, checkRemoteUnused n refspec)-	showStart' "unused" (Just name)-	next perform+	starting "unused" (ActionItemOther (Just name)) perform  checkUnused :: RefSpec -> CommandPerform checkUnused refspec = chain 0@@ -335,6 +334,6 @@ 	search ((m, a):rest) = 		case M.lookup n m of 			Nothing -> search rest-			Just key -> do-				showStart' message (Just $ show n)-				next $ a key+			Just key -> starting message+				(ActionItemOther $ Just $ show n)+				(a key)

@@ -22,9 +22,8 @@ seek = withNothing (commandAction start)  start :: CommandStart-start = do-	showStart' "upgrade" Nothing+start = starting "upgrade" (ActionItemOther Nothing) $ do 	whenM (isNothing <$> getVersion) $ do 		initialize Nothing Nothing 	r <- upgrade False latestVersion-	next $ next $ return r+	next $ return r

@@ -22,16 +22,15 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start params = do-	showStart' "vadd" Nothing+start params = starting "vadd" (ActionItemOther Nothing) $  	withCurrentView $ \view -> do 		let (view', change) = refineView view $ 			map parseViewParam $ reverse params 		case change of 			Unchanged -> do 				showNote "unchanged"-				next $ next $ return True-			Narrowing -> next $ next $ do+				next $ return True+			Narrowing -> next $ do 				if visibleViewSize view' == visibleViewSize view 					then giveup "That would not add an additional level of directory structure to the view. To filter the view, use vfilter instead of vadd." 					else checkoutViewBranch view' narrowView

@@ -26,14 +26,13 @@ start = go =<< currentView   where 	go Nothing = giveup "Not in a view."-	go (Just v) = do-		showStart' "vcycle" Nothing+	go (Just v) = starting "vcycle" (ActionItemOther Nothing) $ do 		let v' = v { viewComponents = vcycle [] (viewComponents v) } 		if v == v' 			then do 				showNote "unchanged"-				next $ next $ return True-			else next $ next $ checkoutViewBranch v' narrowView+				next $ return True+			else next $ checkoutViewBranch v' narrowView  	vcycle rest (c:cs) 		| viewVisible c = rest ++ cs ++ [c]

@@ -20,11 +20,10 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start params = do-	showStart' "vfilter" Nothing+start params = starting "vfilter" (ActionItemOther Nothing) $ 	withCurrentView $ \view -> do 		let view' = filterView view $ 			map parseViewParam $ reverse params-		next $ next $ if visibleViewSize view' > visibleViewSize view+		next $ if visibleViewSize view' > visibleViewSize view 			then giveup "That would add an additional level of directory structure to the view, rather than filtering it. If you want to do that, use vadd instead of vfilter." 			else checkoutViewBranch view' narrowView

@@ -27,17 +27,16 @@ start ps = go =<< currentView   where 	go Nothing = giveup "Not in a view."-	go (Just v) = do-		showStart' "vpop" (Just $ show num)+	go (Just v) = starting "vpop" (ActionItemOther (Just $ show num)) $ do 		removeView v 		(oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v) 			<$> recentViews 		mapM_ removeView oldvs 		case vs of-			(oldv:_) -> next $ next $ do+			(oldv:_) -> next $ do 				showOutput 				checkoutViewBranch oldv (return . branchView)-			_ -> next $ next $ do+			_ -> next $ do 				showOutput 				inRepo $ Git.Command.runBool 					[ Param "checkout"

@@ -29,16 +29,15 @@  start :: [String] -> CommandStart start [] = giveup "Specify metadata to include in view"-start ps = do-	showStart' "view" Nothing-	ifM safeToEnterView-		( do-			view <- mkView ps-			go view  =<< currentView-		, giveup "Not safe to enter view."-		)+start ps = ifM safeToEnterView+	( do+		view <- mkView ps+		go view  =<< currentView+	, giveup "Not safe to enter view."+	)   where-	go view Nothing = next $ perform view+	go view Nothing = starting "view" (ActionItemOther Nothing) $+		perform view 	go view (Just v) 		| v == view = stop 		| otherwise = giveup "Already in a view. Use the vfilter and vadd commands to further refine this view."

@@ -32,16 +32,15 @@  	seek = withWords (commandAction . start) -	start (rname:[]) = go rname (performGet getter)-	start (rname:expr:[]) = go rname $ \uuid -> do-		allowMessages-		showStart' name (Just rname)-		performSet setter expr uuid-	start _ = giveup "Specify a repository."-		-	go rname a = do+	start (rname:[]) = do 		u <- Remote.nameToUUID rname-		next $ a u+		startingCustomOutput (ActionItemOther Nothing) $+			performGet getter u+	start (rname:expr:[]) = do+		u <- Remote.nameToUUID rname+		startingUsualMessages name (ActionItemOther (Just rname)) $+			performSet setter expr u+	start _ = giveup "Specify a repository."  performGet :: Ord a => Annex (M.Map a PreferredContentExpression) -> a -> CommandPerform performGet getter a = do

@@ -53,9 +53,7 @@ 	afile = AssociatedFile (Just file)  startKeys :: M.Map UUID Remote -> (Key, ActionItem) -> CommandStart-startKeys remotemap (key, ai) = do-	showStartKey "whereis" key ai-	next $ perform remotemap key+startKeys remotemap (key, ai) = starting "whereis" ai $ perform remotemap key  perform :: M.Map UUID Remote -> Key -> CommandPerform perform remotemap key = do

@@ -37,6 +37,7 @@  {- A file in a branch or other treeish. -} data BranchFilePath = BranchFilePath Ref TopFilePath+	deriving (Show, Eq, Ord)  {- Git uses the branch:file form to refer to a BranchFilePath -} descBranchFilePath :: BranchFilePath -> String

@@ -11,7 +11,8 @@ 	uuidLog, 	describeUUID, 	uuidDescMap,-	uuidDescMapLoad+	uuidDescMapLoad,+	uuidDescMapRaw, ) where  import Types.UUID@@ -38,19 +39,23 @@ uuidDescMap :: Annex UUIDDescMap uuidDescMap = maybe uuidDescMapLoad return =<< Annex.getState Annex.uuiddescmap -{- Read the uuidLog into a simple Map.+{- Read the uuidLog into a map, and cache it for later use.  -- - The UUID of the current repository is included explicitly, since- - it may not have been described and otherwise would not appear. -}+ - If the current repository has not been described, it is still included+ - in the map with an empty description. -} uuidDescMapLoad :: Annex UUIDDescMap uuidDescMapLoad = do-	m <- simpleMap . parseUUIDLog <$> Annex.Branch.get uuidLog+	m <- uuidDescMapRaw 	u <- Annex.UUID.getUUID 	let m' = M.insertWith preferold u mempty m 	Annex.changeState $ \s -> s { Annex.uuiddescmap = Just m' } 	return m'   where 	preferold = flip const++{- Read the uuidLog into a map. Includes only actually set descriptions. -}+uuidDescMapRaw :: Annex UUIDDescMap+uuidDescMapRaw = simpleMap . parseUUIDLog <$> Annex.Branch.get uuidLog  parseUUIDLog :: L.ByteString -> Log UUIDDesc parseUUIDLog = parseLogOld (UUIDDesc <$> A.takeByteString)

@@ -1,6 +1,6 @@ {- git-annex output messages  -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -8,8 +8,10 @@ module Messages ( 	showStart, 	showStart',-	showStartKey,-	ActionItem,+	showStartMessage,+	showEndMessage,+	StartMessage(..),+	ActionItem(..), 	mkActionItem, 	showNote, 	showAction,@@ -42,7 +44,6 @@ 	debugEnabled, 	commandProgressDisabled, 	outputMessage,-	implicitMessage, 	withMessageState, 	prompt, ) where@@ -58,6 +59,8 @@ import Types.Messages import Types.ActionItem import Types.Concurrency+import Types.Command (StartMessage(..))+import Types.Transfer (transferKey) import Messages.Internal import Messages.Concurrent import qualified Messages.JSON as JSON@@ -81,6 +84,30 @@   where 	json = JSON.start command (actionItemWorkTreeFile i) (Just key) +showStartMessage :: StartMessage -> Annex ()+showStartMessage (StartMessage command ai) = case ai of+	ActionItemAssociatedFile _ k -> showStartKey command k ai+	ActionItemKey k -> showStartKey command k ai+	ActionItemBranchFilePath _ k -> showStartKey command k ai+	ActionItemFailedTransfer t _ -> showStartKey command (transferKey t) ai+	ActionItemWorkTreeFile file -> showStart command file+	ActionItemOther msg -> showStart' command msg+	OnlyActionOn _ ai' -> showStartMessage (StartMessage command ai')+showStartMessage (StartUsualMessages command ai) = do+	outputType <$> Annex.getState Annex.output >>= \case+		QuietOutput -> Annex.setOutput NormalOutput+		_ -> noop+	showStartMessage (StartMessage command ai)+showStartMessage (StartNoMessage _) = noop+showStartMessage (CustomOutput _) = Annex.setOutput QuietOutput++-- Only show end result if the StartMessage is one that gets displayed.+showEndMessage :: StartMessage -> Bool -> Annex ()+showEndMessage (StartMessage _ _) = showEndResult+showEndMessage (StartUsualMessages _ _) = showEndResult+showEndMessage (StartNoMessage _) = const noop+showEndMessage (CustomOutput _) = const noop+ showNote :: String -> Annex () showNote s = outputMessage (JSON.note s) $ "(" ++ s ++ ") " @@ -250,12 +277,6 @@ 		QuietOutput -> True 		JSONOutput _ -> True 		NormalOutput -> concurrentOutputEnabled s--{- Use to show a message that is displayed implicitly, and so might be- - disabled when running a certian command that needs more control over its- - output. -}-implicitMessage :: Annex () -> Annex ()-implicitMessage = whenM (implicitMessages <$> Annex.getState Annex.output)  {- Prevents any concurrent console access while running an action, so  - that the action is the only thing using the console, and can eg prompt

@@ -1,10 +1,12 @@ {- git-annex progress output  -- - Copyright 2010-2015 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE FlexibleInstances #-}+ module Messages.Progress where  import Common@@ -13,22 +15,56 @@ import Types import Types.Messages import Types.Key+import Types.KeySource+import Utility.InodeCache import qualified Messages.JSON as JSON import Messages.Concurrent  import qualified System.Console.Regions as Regions import qualified System.Console.Concurrent as Console -{- Shows a progress meter while performing a transfer of a key.- - The action is passed the meter and a callback to use to update the meter.- -- - When the key's size is not known, the srcfile is statted to get the size.+{- Class of things from which a size can be gotten to display a progress+ - meter. -}+class MeterSize t where+	getMeterSize :: t -> Annex (Maybe FileSize)++instance MeterSize t => MeterSize (Maybe t) where+	getMeterSize Nothing = pure Nothing+	getMeterSize (Just t) = getMeterSize t++instance MeterSize FileSize where+	getMeterSize = pure . Just++instance MeterSize Key where+	getMeterSize = pure . keySize++instance MeterSize InodeCache where+	getMeterSize = pure . Just . inodeCacheFileSize++instance MeterSize KeySource where+	getMeterSize = maybe (pure Nothing) getMeterSize . inodeCache++{- When the key's size is not known, the file is statted to get the size.  - This allows uploads of keys without size to still have progress  - displayed.+ -}+data KeySizer = KeySizer Key (Annex (Maybe FilePath))++instance MeterSize KeySizer where+	getMeterSize (KeySizer k getsrcfile) = case keySize k of+		Just sz -> return (Just sz)+		Nothing -> do+			srcfile <- getsrcfile+			case srcfile of+				Nothing -> return Nothing+				Just f -> catchMaybeIO $ liftIO $ getFileSize f++{- Shows a progress meter while performing an action.+ - The action is passed the meter and a callback to use to update the meter.  --}-metered :: Maybe MeterUpdate -> Key -> Annex (Maybe FilePath) -> (Meter -> MeterUpdate -> Annex a) -> Annex a-metered othermeter key getsrcfile a = withMessageState $ \st ->-	flip go st =<< getsz+metered :: MeterSize sizer => Maybe MeterUpdate -> sizer -> (Meter -> MeterUpdate -> Annex a) -> Annex a+metered othermeter sizer a = withMessageState $ \st ->+	flip go st =<< getMeterSize sizer   where 	go _ (MessageState { outputType = QuietOutput }) = nometer 	go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do@@ -66,19 +102,11 @@ 	combinemeter m = case othermeter of 		Nothing -> m 		Just om -> combineMeterUpdate m om-	-	getsz = case keySize key of-		Just sz -> return (Just sz)-		Nothing -> do-			srcfile <- getsrcfile-			case srcfile of-				Nothing -> return Nothing-				Just f -> catchMaybeIO $ liftIO $ getFileSize f  {- Poll file size to display meter. -} meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a meteredFile file combinemeterupdate key a = -	metered combinemeterupdate key (return Nothing) $ \_ p ->+	metered combinemeterupdate key $ \_ p -> 		watchFileSize file p a  {- Progress dots. -}

@@ -32,14 +32,14 @@  store :: (MeterUpdate -> ProtoRunner Bool) -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store runner k af p = do-	let getsrcfile = fmap fst <$> prepSendAnnex k-	metered (Just p) k getsrcfile $ \_ p' -> +	let sizer = KeySizer k (fmap fst <$> prepSendAnnex k)+	metered (Just p) sizer $ \_ p' ->  		fromMaybe False 			<$> runner p' (P2P.put k af p')  retrieve :: (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) retrieve runner k af dest p =-	metered (Just p) k (return Nothing) $ \m p' -> +	metered (Just p) k $ \m p' ->  		fromMaybe (False, UnVerified) 			<$> runner p' (P2P.get dest k af m p') 

@@ -253,7 +253,8 @@ 	chunkconfig = chunkConfig cfg  	displayprogress p k srcfile a-		| displayProgress cfg = metered (Just p) k (return srcfile) (const a)+		| displayProgress cfg =+			metered (Just p) (KeySizer k (return srcfile)) (const a) 		| otherwise = a p  {- Sink callback for retrieveChunks. Stores the file content into the

@@ -41,6 +41,7 @@ import qualified Utility.Exception import qualified Utility.ThreadScheduler import qualified Utility.Tmp.Dir+import qualified Utility.Metered import qualified Command.Uninit import qualified CmdLine.GitAnnex as GitAnnex @@ -567,9 +568,9 @@ getKey :: Types.Backend -> FilePath -> IO Types.Key getKey b f = fromJust <$> annexeval go   where-	go = Types.Backend.getKey b-		Types.KeySource.KeySource-			{ Types.KeySource.keyFilename = f-			, Types.KeySource.contentLocation = f-			, Types.KeySource.inodeCache = Nothing-			}+	go = Types.Backend.getKey b ks Utility.Metered.nullMeterUpdate+	ks = Types.KeySource.KeySource+		{ Types.KeySource.keyFilename = f+		, Types.KeySource.contentLocation = f+		, Types.KeySource.inodeCache = Nothing+		}

@@ -13,21 +13,38 @@ import Types.Transfer import Git.FilePath +import Data.Maybe+ data ActionItem  	= ActionItemAssociatedFile AssociatedFile Key 	| ActionItemKey Key 	| ActionItemBranchFilePath BranchFilePath Key 	| ActionItemFailedTransfer Transfer TransferInfo+	| ActionItemWorkTreeFile FilePath+	| ActionItemOther (Maybe String)+	-- Use to avoid more than one thread concurrently processing the+	-- same Key.+	| OnlyActionOn Key ActionItem+	deriving (Show, Eq)  class MkActionItem t where 	mkActionItem :: t -> ActionItem +instance MkActionItem ActionItem where+	mkActionItem = id+ instance MkActionItem (AssociatedFile, Key) where 	mkActionItem = uncurry ActionItemAssociatedFile  instance MkActionItem (Key, AssociatedFile) where 	mkActionItem = uncurry $ flip ActionItemAssociatedFile +instance MkActionItem (Key, FilePath) where+	mkActionItem (key, file) = ActionItemAssociatedFile (AssociatedFile (Just file)) key++instance MkActionItem (FilePath, Key) where+	mkActionItem (file, key) = mkActionItem (key, file)+ instance MkActionItem Key where 	mkActionItem = ActionItemKey @@ -39,23 +56,33 @@  actionItemDesc :: ActionItem -> String actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f-actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = serializeKey k+actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = +	serializeKey k actionItemDesc (ActionItemKey k) = serializeKey k actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $ 	ActionItemAssociatedFile (associatedFile i) (transferKey t)+actionItemDesc (ActionItemWorkTreeFile f) = f+actionItemDesc (ActionItemOther s) = fromMaybe "" s+actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai -actionItemKey :: ActionItem -> Key-actionItemKey (ActionItemAssociatedFile _ k) = k-actionItemKey (ActionItemKey k) = k-actionItemKey (ActionItemBranchFilePath _ k) = k-actionItemKey (ActionItemFailedTransfer t _) = transferKey t+actionItemKey :: ActionItem -> Maybe Key+actionItemKey (ActionItemAssociatedFile _ k) = Just k+actionItemKey (ActionItemKey k) = Just k+actionItemKey (ActionItemBranchFilePath _ k) = Just k+actionItemKey (ActionItemFailedTransfer t _) = Just (transferKey t)+actionItemKey (ActionItemWorkTreeFile _) = Nothing+actionItemKey (ActionItemOther _) = Nothing+actionItemKey (OnlyActionOn _ ai) = actionItemKey ai  actionItemWorkTreeFile :: ActionItem -> Maybe FilePath actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af) _) = af+actionItemWorkTreeFile (ActionItemWorkTreeFile f) = Just f+actionItemWorkTreeFile (OnlyActionOn _ ai) = actionItemWorkTreeFile ai actionItemWorkTreeFile _ = Nothing  actionItemTransferDirection :: ActionItem -> Maybe Direction actionItemTransferDirection (ActionItemFailedTransfer t _) = Just $ 	transferDirection t+actionItemTransferDirection (OnlyActionOn _ ai) = actionItemTransferDirection ai actionItemTransferDirection _ = Nothing

@@ -2,7 +2,7 @@  -  - Most things should not need this, using Types instead  -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -12,11 +12,12 @@ import Types.Key import Types.KeySource +import Utility.Metered import Utility.FileSystemEncoding  data BackendA a = Backend 	{ backendVariety :: KeyVariety-	, getKey :: KeySource -> a (Maybe Key) +	, getKey :: KeySource -> MeterUpdate -> a (Maybe Key)  	-- Verifies the content of a key. 	, verifyKeyContent :: Maybe (Key -> FilePath -> a Bool) 	-- Checks if a key can be upgraded to a better form.

@@ -1,6 +1,6 @@ {- git-annex command data types  -- - Copyright 2010-2016 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -12,6 +12,7 @@  import Types import Types.DeferredParse+import Types.ActionItem  {- A command runs in these stages.  -@@ -25,11 +26,11 @@  -    the repo to find things to act on (ie, new files to add), and  -    runs commandAction to handle all necessary actions. -} type CommandSeek = Annex ()-{- d. The start stage is run before anything is printed about the- -    command, is passed some input, and can early abort it- -    if nothing needs to be done. It should run quickly and- -    should not modify Annex state. -}-type CommandStart = Annex (Maybe CommandPerform)+{- d. The start stage is run before anything is output, is passed some+ -    value from the seek stage, and can check if anything needs to be+ -    done, and early abort if not. It should run quickly and should+ -    not modify Annex state or output anything. -}+type CommandStart = Annex (Maybe (StartMessage, CommandPerform)) {- e. The perform stage is run after a message is printed about the command  -    being run, and it should be where the bulk of the work happens. -} type CommandPerform = Annex (Maybe CommandCleanup)@@ -37,18 +38,49 @@  -    returns the overall success/fail of the command. -} type CommandCleanup = Annex Bool +{- Message that is displayed when starting to perform an action on+ - something. The String is typically the name of the command or action+ - being performed.+ -}+data StartMessage+	= StartMessage String ActionItem+	| StartUsualMessages String ActionItem+	-- ^ Like StartMessage, but makes sure to enable usual message+	-- display in case it was disabled by cmdnomessages.+	| StartNoMessage ActionItem+	-- ^ Starts, without displaying any message but also without+	-- disabling display of any of the usual messages.+	| CustomOutput ActionItem+	-- ^ Prevents any start, end, or other usual messages from+	-- being displayed, letting a command output its own custom format.+	deriving (Show)++instance MkActionItem StartMessage where+	mkActionItem (StartMessage _ ai) = ai+	mkActionItem (StartUsualMessages _ ai) = ai+	mkActionItem (StartNoMessage ai) = ai+	mkActionItem (CustomOutput ai) = ai+ {- A command is defined by specifying these things. -} data Command = Command-	{ cmdcheck :: [CommandCheck] -- check stage-	, cmdnocommit :: Bool        -- don't commit journalled state changes-	, cmdnomessages :: Bool -- don't output normal messages+	{ cmdcheck :: [CommandCheck]+	-- ^ check stage+	, cmdnocommit :: Bool+	-- ^ don't commit journalled state changes+	, cmdnomessages :: Bool+	-- ^ don't output normal messages 	, cmdname :: String-	, cmdparamdesc :: CmdParamsDesc -- description of params for usage+	, cmdparamdesc :: CmdParamsDesc+	-- ^ description of params for usage 	, cmdsection :: CommandSection-	, cmddesc :: String          -- description of command for usage-	, cmdparser :: CommandParser -- command line parser-	, cmdglobaloptions :: [GlobalOption] -- additional global options-	, cmdnorepo :: Maybe (Parser (IO ())) -- used when not in a repo+	, cmddesc :: String+	-- ^ description of command for usage+	, cmdparser :: CommandParser+	-- ^ command line parser+	, cmdglobaloptions :: [GlobalOption]+	-- ^ additional global options+	, cmdnorepo :: Maybe (Parser (IO ()))+	-- ^used when not in a repo 	}  {- Command-line parameters, after the command is selected and options

@@ -7,6 +7,9 @@  import Utility.PartialPrelude +-- Note that Concurrent 1 is not the same as NonConcurrent;+-- the former specifies 1 job of each particular kind, but there can be+-- more than one kind of job running concurrently. data Concurrency = NonConcurrent | Concurrent Int | ConcurrentPerCpu  parseConcurrency :: String -> Maybe Concurrency

@@ -35,7 +35,6 @@ 	{ outputType :: OutputType 	, concurrentOutputEnabled :: Bool 	, sideActionBlock :: SideActionBlock-	, implicitMessages :: Bool 	, consoleRegion :: Maybe ConsoleRegion 	, consoleRegionErrFlag :: Bool 	, jsonBuffer :: Maybe Aeson.Object@@ -49,7 +48,6 @@ 		{ outputType = NormalOutput 		, concurrentOutputEnabled = False 		, sideActionBlock = NoBlock-		, implicitMessages = True  		, consoleRegion = Nothing 		, consoleRegionErrFlag = False 		, jsonBuffer = Nothing

@@ -1,4 +1,4 @@-{- Command worker pool.+{- Worker thread pool.  -  - Copyright 2019 Joey Hess <id@joeyh.name>  -@@ -7,24 +7,135 @@  module Types.WorkerPool where +import Control.Concurrent import Control.Concurrent.Async-import Data.Either+import qualified Data.Set as S  -- | Pool of worker threads. -data WorkerPool t-	= UnallocatedWorkerPool-	| WorkerPool [Worker t]+data WorkerPool t = WorkerPool+	{ usedStages :: UsedStages+	, workerList :: [Worker t]+	, spareVals :: [t]+	-- ^ Normally there is one value for each IdleWorker,+	-- but there can temporarily be fewer values, when a thread is+	-- changing between stages.+	} +	deriving (Show)  -- | A worker can either be idle or running an Async action.-type Worker t = Either t (Async t)+-- And it is used for some stage.+data Worker t+	= IdleWorker WorkerStage+	| ActiveWorker (Async t) WorkerStage -allocateWorkerPool :: t -> Int -> WorkerPool t-allocateWorkerPool t n = WorkerPool $ replicate n (Left t)+instance Show (Worker t) where+	show (IdleWorker s) = "IdleWorker " ++ show s+	show (ActiveWorker _ s) = "ActiveWorker " ++ show s -addWorkerPool :: WorkerPool t -> Worker t -> WorkerPool t-addWorkerPool (WorkerPool l) w = WorkerPool (w:l)-addWorkerPool UnallocatedWorkerPool w = WorkerPool [w]+data WorkerStage+	= PerformStage+	-- ^ Running a CommandPerform action.+	| CleanupStage+	-- ^ Running a CommandCleanup action.+	| TransferStage+	-- ^ Transferring content to or from a remote.+	| VerifyStage+	-- ^ Verifying content, eg by calculating a checksum.+	deriving (Show, Eq, Ord) -idleWorkers :: WorkerPool t -> [t]-idleWorkers UnallocatedWorkerPool = []-idleWorkers (WorkerPool l) = lefts l+-- | Set of stages that make sense to be used while performing an action,+-- and the stage to use initially.+-- +-- Transitions between these stages will block as needed until there's a+-- free Worker in the pool for the new stage.+-- +-- Actions that indicate they are in some other stage won't change the+-- stage, and so there will be no blocking before starting them.+data UsedStages = UsedStages+	{ initialStage :: WorkerStage+	, stageSet :: S.Set WorkerStage+	}+	deriving (Show)++memberStage :: WorkerStage -> UsedStages -> Bool+memberStage s u = S.member s (stageSet u)++-- | The default is to use only the CommandPerform and CommandCleanup+-- stages. Since cleanup actions often don't contend much with+-- perform actions, this prevents blocking starting the next perform action+-- on finishing the previous cleanup action.+commandStages :: UsedStages+commandStages = UsedStages+	{ initialStage = PerformStage+	, stageSet = S.fromList [PerformStage, CleanupStage]+	}++-- | When a command is transferring content, it can use this instead.+-- Transfers are often bottlenecked on the network another disk than the one+-- containing the repository, while verification bottlenecks on+-- the disk containing the repository or on the CPU.+transferStages :: UsedStages+transferStages = UsedStages+	{ initialStage = TransferStage+	, stageSet = S.fromList [TransferStage, VerifyStage]+	}++workerStage :: Worker t -> WorkerStage+workerStage (IdleWorker s) = s+workerStage (ActiveWorker _ s) = s++workerAsync :: Worker t -> Maybe (Async t)+workerAsync (IdleWorker _) = Nothing+workerAsync (ActiveWorker aid _) = Just aid++-- | Allocates a WorkerPool that has the specified number of workers+-- in it, of each stage.+--+-- The stages are distributed evenly throughout.+allocateWorkerPool :: t -> Int -> UsedStages -> WorkerPool t+allocateWorkerPool t n u = WorkerPool+	{ usedStages = u+	, workerList = take totalthreads $ map IdleWorker stages+	, spareVals = replicate totalthreads t+	}+  where+	stages = concat $ repeat $ S.toList $ stageSet u+	totalthreads = n * S.size (stageSet u)++addWorkerPool :: Worker t -> WorkerPool t -> WorkerPool t+addWorkerPool w pool = pool { workerList = w : workerList pool }++-- | Removes a worker from the pool whose Async uses the ThreadId.+--+-- Each Async has its own ThreadId, so this stops once it finds+-- a match.+removeThreadIdWorkerPool :: ThreadId -> WorkerPool t -> Maybe ((Async t, WorkerStage), WorkerPool t)+removeThreadIdWorkerPool tid pool = go [] (workerList pool)+  where+	go _ [] = Nothing+	go c (ActiveWorker a stage : rest)+		| asyncThreadId a == tid =+			let pool' = pool { workerList = (c++rest) }+			in Just ((a, stage), pool')+	go c (v : rest) = go (v:c) rest++deactivateWorker :: WorkerPool t -> Async t -> t -> WorkerPool t+deactivateWorker pool aid t = pool+	{ workerList = go (workerList pool)+	, spareVals = t : spareVals pool+	}+  where+	go [] = []+	go (w@(IdleWorker _) : rest) = w : go rest+	go (w@(ActiveWorker a st) : rest)+		| a == aid = IdleWorker st : rest+		| otherwise = w : go rest++allIdle :: WorkerPool t -> Bool+allIdle pool = all idle (workerList pool)+	-- If this does not hold, a thread must be transitioning between+	-- states, so it's not really idle.+	&& length (spareVals pool) == length (workerList pool)+  where+	idle (IdleWorker _) = True+	idle (ActiveWorker _ _) = False

@@ -13,6 +13,7 @@ module Utility.InodeCache ( 	InodeCache, 	InodeComparisonType(..),+	inodeCacheFileSize,  	compareStrong, 	compareWeak,@@ -57,6 +58,9 @@  newtype InodeCache = InodeCache InodeCachePrim 	deriving (Show)++inodeCacheFileSize :: InodeCache -> FileSize+inodeCacheFileSize (InodeCache (InodeCachePrim _ sz _)) = sz  {- Inode caches can be compared in two different ways, either weakly  - or strongly. -}

@@ -375,13 +375,13 @@ 	ftpport = 21  	downloadconduit req = catchMaybeIO (getFileSize file) >>= \case-		Nothing -> runResourceT $ do+		Just sz | sz > 0 -> resumeconduit req' sz+		_ -> runResourceT $ do 			liftIO $ debugM "url" (show req') 			resp <- http req' (httpManager uo) 			if responseStatus resp == ok200 				then store zeroBytesProcessed WriteMode resp 				else showrespfailure resp-		Just sz -> resumeconduit req' sz 	  where 		req' = applyRequest uo $ req 			-- Override http-client's default decompression of gzip

@@ -68,6 +68,10 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--json-progress`++  Include progress objects in JSON output.+ * `--json-error-messages`    Messages that would normally be output to standard error are included in

@@ -1,4 +1,4 @@-# NAME+#a NAME  git-annex drop - remove content of files from repository @@ -12,8 +12,12 @@ possible.  git-annex will refuse to drop content if it cannot verify it is-safe to do so.+safe to do so. Usually this involves verifying that the content is stored+in some other repository. +Content that is required to be stored in the repository will not be dropped+even if enough copies exist elsewhere. See [[git-annex-required]](1).+ # OPTIONS  * `--from=remote`@@ -43,28 +47,28 @@   This is the default behavior when running git-annex drop in a bare repository.    Note that this bypasses checking the .gitattributes annex.numcopies-  setting.+  setting and required content settings.  * `--branch=ref`    Drop files in the specified branch or treeish.    Note that this bypasses checking the .gitattributes annex.numcopies-  setting.+  setting and required content settings.  * `--unused`    Drop files found by last run of git-annex unused.    Note that this bypasses checking the .gitattributes annex.numcopies-  setting.+  setting and required content settings.  * `--key=keyname`    Use this option to drop a specified key.    Note that this bypasses checking the .gitattributes annex.numcopies-  setting.+  setting and required content settings.  * file matching options 

@@ -1,5 +1,5 @@ Name: git-annex-Version: 7.20190615+Version: 7.20190626 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -358,6 +358,7 @@    crypto-api,    cryptonite,    memory,+   deepseq,    split,    attoparsec,    concurrent-output (>= 1.6),@@ -593,7 +594,7 @@       CPP-Options: -DWITH_MAGICMIME    if flag(Benchmark)-    Build-Depends: criterion, deepseq+    Build-Depends: criterion     CPP-Options: -DWITH_BENCHMARK      if flag(DebugLocks)