packages feed

git-annex 8.20200908 → 8.20201007

raw patch · 158 files changed

+2007/−1195 lines, 158 files

Files

Annex.hs view
@@ -69,6 +69,7 @@ import Types.WorkerPool import Types.IndexFiles import Types.CatFileHandles+import Types.RemoteConfig import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url@@ -112,7 +113,7 @@ 	, backend :: Maybe (BackendA Annex) 	, remotes :: [Types.Remote.RemoteA Annex] 	, output :: MessageState-	, concurrency :: Concurrency+	, concurrency :: ConcurrencySetting 	, force :: Bool 	, fast :: Bool 	, daemon :: Bool@@ -129,6 +130,7 @@ 	, uuiddescmap :: Maybe UUIDDescMap 	, preferredcontentmap :: Maybe (FileMatcherMap Annex) 	, requiredcontentmap :: Maybe (FileMatcherMap Annex)+	, remoteconfigmap :: Maybe (M.Map UUID RemoteConfig) 	, forcetrust :: TrustMap 	, trustmap :: Maybe TrustMap 	, groupmap :: Maybe GroupMap@@ -171,7 +173,7 @@ 		, backend = Nothing 		, remotes = [] 		, output = o-		, concurrency = NonConcurrent+		, concurrency = ConcurrencyCmdLine NonConcurrent 		, force = False 		, fast = False 		, daemon = False@@ -188,6 +190,7 @@ 		, uuiddescmap = Nothing 		, preferredcontentmap = Nothing 		, requiredcontentmap = Nothing+		, remoteconfigmap = Nothing 		, forcetrust = M.empty 		, trustmap = Nothing 		, groupmap = Nothing
Annex/Action.hs view
@@ -5,20 +5,13 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Annex.Action ( 	startup, 	shutdown, 	stopCoProcesses,-	reapZombies, ) where  import qualified Data.Map as M-#ifndef mingw32_HOST_OS-import System.Posix.Process (getAnyProcessStatus)-import Utility.Exception-#endif  import Annex.Common import qualified Annex@@ -38,7 +31,6 @@ 	saveState nocommit 	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 ()@@ -47,19 +39,3 @@ 	checkAttrStop 	hashObjectStop 	checkIgnoreStop--{- Reaps any zombie processes that may be hanging around.- -- - Warning: Not thread safe. Anything that was expecting to wait- - on a process and get back an exit status is going to be confused- - if this reap gets there first. -}-reapZombies :: IO ()-#ifndef mingw32_HOST_OS-reapZombies =-	-- throws an exception when there are no child processes-	catchDefaultIO Nothing (getAnyProcessStatus False True)-		>>= maybe (return ()) (const reapZombies)--#else-reapZombies = return ()-#endif
Annex/Branch.hs view
@@ -393,24 +393,26 @@  {- Lists all files on the branch. including ones in the journal  - that have not been committed yet. There may be duplicates in the list. -}-files :: Annex [RawFilePath]+files :: Annex ([RawFilePath], IO Bool) files = do 	_  <- update+	(bfs, cleanup) <- branchFiles 	-- ++ forces the content of the first list to be buffered in memory, 	-- so use getJournalledFilesStale which should be much smaller most 	-- of the time. branchFiles will stream as the list is consumed.-	(++)+	l <- (++) 		<$> (map toRawFilePath <$> getJournalledFilesStale)-		<*> branchFiles+		<*> pure bfs+	return (l, cleanup)  {- Files in the branch, not including any from journalled changes,  - and without updating the branch. -}-branchFiles :: Annex [RawFilePath]+branchFiles :: Annex ([RawFilePath], IO Bool) branchFiles = withIndex $ inRepo branchFiles' -branchFiles' :: Git.Repo -> IO [RawFilePath]-branchFiles' = Git.Command.pipeNullSplitZombie'-	(lsTreeParams Git.LsTree.LsTreeRecursive fullname [Param "--name-only"])+branchFiles' :: Git.Repo -> IO ([RawFilePath], IO Bool)+branchFiles' = Git.Command.pipeNullSplit' $+	lsTreeParams Git.LsTree.LsTreeRecursive fullname [Param "--name-only"]  {- Populates the branch's index file with the current branch contents.  - @@ -620,10 +622,11 @@ 		remoteconfigmap <- calcRemoteConfigMap <$> getStaged remoteLog 		-- partially apply, improves performance 		let changers' = map (\c -> c config trustmap remoteconfigmap) changers-		fs <- branchFiles+		(fs, cleanup) <- branchFiles 		forM_ fs $ \f -> do 			content <- getStaged f 			apply changers' f content+		liftIO $ void cleanup 	apply [] _ _ = return () 	apply (changer:rest) file content = case changer file content of 		PreserveFile -> apply rest file content
Annex/CheckIgnore.hs view
@@ -7,6 +7,7 @@  -}  module Annex.CheckIgnore (+	CheckGitIgnore(..), 	checkIgnored, 	checkIgnoreStop, 	mkConcurrentCheckIgnoreHandle,@@ -19,9 +20,15 @@ import Types.Concurrency import Annex.Concurrent.Utility -checkIgnored :: FilePath -> Annex Bool-checkIgnored file = withCheckIgnoreHandle $ \h ->-	liftIO $ Git.checkIgnored h file+newtype CheckGitIgnore = CheckGitIgnore Bool++checkIgnored :: CheckGitIgnore -> FilePath -> Annex Bool+checkIgnored (CheckGitIgnore False) _ = pure False+checkIgnored (CheckGitIgnore True) file =+	ifM (Annex.getState Annex.force)+		( pure False+		, withCheckIgnoreHandle $ \h -> liftIO $ Git.checkIgnored h file+		)  withCheckIgnoreHandle :: (Git.CheckIgnoreHandle -> Annex a) -> Annex a withCheckIgnoreHandle a =
Annex/Concurrent.hs view
@@ -5,10 +5,14 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -module Annex.Concurrent where+module Annex.Concurrent (+	module Annex.Concurrent,+	module Annex.Concurrent.Utility+) where  import Annex import Annex.Common+import Annex.Concurrent.Utility import qualified Annex.Queue import Annex.Action import Types.Concurrency@@ -22,19 +26,24 @@ import Control.Concurrent.STM import qualified Data.Map as M -setConcurrency :: Concurrency -> Annex ()-setConcurrency NonConcurrent = Annex.changeState $ \s -> s -	{ Annex.concurrency = NonConcurrent-	}-setConcurrency c = do-	cfh <- Annex.getState Annex.catfilehandles+setConcurrency :: ConcurrencySetting -> Annex ()+setConcurrency (ConcurrencyCmdLine s) = setConcurrency' s ConcurrencyCmdLine+setConcurrency (ConcurrencyGitConfig s) = setConcurrency' s ConcurrencyGitConfig++setConcurrency' :: Concurrency -> (Concurrency -> ConcurrencySetting) -> Annex ()+setConcurrency' NonConcurrent f = +	Annex.changeState $ \s -> s +		{ Annex.concurrency = f NonConcurrent+		}+setConcurrency' c f = do+	cfh <- getState Annex.catfilehandles 	cfh' <- case cfh of 		CatFileHandlesNonConcurrent _ -> liftIO catFileHandlesPool 		CatFileHandlesPool _ -> pure cfh 	cah <- mkConcurrentCheckAttrHandle c 	cih <- mkConcurrentCheckIgnoreHandle c 	Annex.changeState $ \s -> s-		{ Annex.concurrency = c+		{ Annex.concurrency = f c 		, Annex.catfilehandles = cfh' 		, Annex.checkattrhandle = Just cah 		, Annex.checkignorehandle = Just cih@@ -74,9 +83,9 @@ 	st <- Annex.getState id 	-- Make sure that concurrency is enabled, if it was not already, 	-- so the concurrency-safe resource pools are set up.-	st' <- case Annex.concurrency st of+	st' <- case getConcurrency' (Annex.concurrency st) of 		NonConcurrent -> do-			setConcurrency (Concurrent 1)+			setConcurrency (ConcurrencyCmdLine (Concurrent 1)) 			Annex.getState id 		_ -> return st 	return $ st'
Annex/Concurrent/Utility.hs view
@@ -7,9 +7,17 @@  module Annex.Concurrent.Utility where +import Annex import Types.Concurrency  import GHC.Conc++getConcurrency :: Annex Concurrency+getConcurrency = getConcurrency' <$> getState concurrency++getConcurrency' :: ConcurrencySetting -> Concurrency+getConcurrency' (ConcurrencyCmdLine c) = c+getConcurrency' (ConcurrencyGitConfig c) = c  {- Honor the requested level of concurrency, but only up to the number of  - CPU cores. Useful for things that are known to be CPU bound. -}
Annex/Drop.hs view
@@ -47,8 +47,8 @@  - 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+handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> SeekInput -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex ()+handleDropsFrom locs rs reason fromhere key afile si preverified runner = do 	g <- Annex.gitRepo 	l <- map (`fromTopFilePath` g) 		<$> Database.Keys.getAssociatedFiles key@@ -120,10 +120,10 @@  	dropl fs n = checkdrop fs n Nothing $ \numcopies -> 		stopUnless (inAnnex key) $-			Command.Drop.startLocal afile ai numcopies key preverified+			Command.Drop.startLocal afile ai si numcopies key preverified  	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->-		Command.Drop.startRemote afile ai numcopies key r+		Command.Drop.startRemote afile ai si numcopies key r  	ai = mkActionItem (key, afile)
Annex/FileMatcher.hs view
@@ -78,14 +78,14 @@  checkMatcher' :: FileMatcher Annex -> MatchInfo -> AssumeNotPresent -> Annex Bool checkMatcher' matcher mi notpresent =-	matchMrun matcher $ \a -> a notpresent mi+	matchMrun matcher $ \o -> matchAction o notpresent mi  fileMatchInfo :: RawFilePath -> Annex MatchInfo fileMatchInfo file = do 	matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) 	return $ MatchingFile FileInfo 		{ matchFile = matchfile-		, currFile = file+		, contentFile = Just file 		}  matchAll :: FileMatcher Annex@@ -195,9 +195,9 @@ 		commonKeylessTokens LimitDiskFiles ++ #ifdef WITH_MAGICMIME 		[ mimer "mimetype" $-			matchMagic "mimetype" getMagicMimeType providedMimeType+			matchMagic "mimetype" getMagicMimeType providedMimeType userProvidedMimeType 		, mimer "mimeencoding" $-			matchMagic "mimeencoding" getMagicMimeEncoding providedMimeEncoding+			matchMagic "mimeencoding" getMagicMimeEncoding providedMimeEncoding userProvidedMimeEncoding 		] #else 		[ mimer "mimetype"@@ -264,6 +264,12 @@ usev a v = Operation <$> a v  call :: Either String (FileMatcher Annex) -> ParseResult (MatchFiles Annex)-call (Right sub) = Right $ Operation $ \notpresent mi ->-	matchMrun sub $ \a -> a notpresent mi+call (Right sub) = Right $ Operation $ MatchFiles+	{ matchAction = \notpresent mi ->+		matchMrun sub $ \o -> matchAction o notpresent mi+	, matchNeedsFileName = any matchNeedsFileName sub+	, matchNeedsFileContent = any matchNeedsFileContent sub+	, matchNeedsKey = any matchNeedsKey sub+	, matchNeedsLocationLog = any matchNeedsLocationLog sub+	} call (Left err) = Left err
Annex/Import.hs view
@@ -12,10 +12,10 @@ 	ImportCommitConfig(..), 	buildImportCommit, 	buildImportTrees,+	canImportKeys, 	importKeys,-	filterImportableContents, 	makeImportMatcher,-	listImportableContents,+	getImportableContents, ) where  import Annex.Common@@ -36,6 +36,7 @@ import Annex.RemoteTrackingBranch import Annex.HashObject import Annex.Transfer+import Annex.CheckIgnore import Command import Backend import Types.Key@@ -48,7 +49,7 @@ import Logs.PreferredContent import Types.FileMatcher import Annex.FileMatcher-import Utility.Matcher (isEmpty)+import qualified Utility.Matcher import qualified Database.Export as Export import qualified Database.ContentIdentifier as CIDDb import qualified Logs.ContentIdentifier as CIDLog@@ -57,7 +58,7 @@ import Control.Concurrent.STM import qualified Data.Map.Strict as M import qualified Data.Set as S-import qualified System.FilePath.Posix as Posix+import qualified System.FilePath.Posix.ByteString as Posix import qualified System.FilePath.ByteString as P  {- Configures how to build an import tree. -}@@ -281,6 +282,12 @@ 		topf = asTopFilePath $ 			maybe lf (\sd -> getTopFilePath sd P.</> lf) msubdir +canImportKeys :: Remote -> Bool -> Bool+canImportKeys remote importcontent =+	importcontent || isJust (Remote.importKey ia)+  where+	ia = Remote.importActions remote+ {- Downloads all new ContentIdentifiers, or when importcontent is False,  - generates Keys without downloading.  -@@ -304,7 +311,7 @@ 	-> ImportableContents (ContentIdentifier, ByteSize) 	-> Annex (Maybe (ImportableContents (Either Sha Key))) importKeys remote importtreeconfig importcontent importablecontents = do-	when (not importcontent && isNothing (Remote.importKey ia)) $+	unless (canImportKeys remote importcontent) $ 		giveup "This remote does not support importing without downloading content." 	-- This map is used to remember content identifiers that 	-- were just imported, before they have necessarily been@@ -364,7 +371,8 @@ 		[] -> do 			job <- liftIO $ newEmptyTMVarIO 			let ai = ActionItemOther (Just (fromRawFilePath (fromImportLocation loc)))-			let importaction = starting ("import " ++ Remote.name remote) ai $ do+			let si = SeekInput []+			let importaction = starting ("import " ++ Remote.name remote) ai si $ do 				when oldversion $ 					showNote "old version" 				tryNonAsync (importordownload cidmap db i largematcher) >>= \case@@ -383,41 +391,115 @@ 				importaction 			return (Right job) 	-	importordownload-		| not importcontent = doimport-		| otherwise = dodownload+	importordownload cidmap db (loc, (cid, sz)) largematcher= do+		f <- locworktreefile loc+		matcher <- largematcher (fromRawFilePath f)+		-- When importing a key is supported, always use it rather+		-- than downloading and retrieving a key, to avoid+		-- generating trees with different keys for the same content.+		let act = if importcontent+			then case Remote.importKey ia of+				Nothing -> dodownload+				Just _ -> if Utility.Matcher.introspect matchNeedsFileContent matcher+					then dodownload+					else doimport+			else doimport+		act cidmap db (loc, (cid, sz)) f matcher -	doimport cidmap db (loc, (cid, sz)) _largematcher =+	doimport cidmap db (loc, (cid, sz)) f matcher = 		case Remote.importKey ia of 			Nothing -> error "internal" -- checked earlier-			Just a -> do-				let importer p = do-					unsizedk <- a loc cid p-					-- This avoids every remote needing-					-- to add the size.-					let k = alterKey unsizedk $ \kd -> kd-						{ keySize = keySize kd <|> Just sz }-					checkSecureHashes k >>= \case-						Nothing -> do-							recordcidkey cidmap db cid k-							logChange k (Remote.uuid remote) InfoPresent-							return (Right k)-						Just msg -> giveup (msg ++ " to import")-				let runimport p = tryNonAsync (importer p) >>= \case-					Right k -> return $ Just (loc, k)+			Just importkey -> do+				when (Utility.Matcher.introspect matchNeedsFileContent matcher) $+					giveup "annex.largefiles configuration examines file contents, so cannot import without content."+ 				let mi = MatchingInfo ProvidedInfo+					{ providedFilePath = f+					, providedKey = Nothing+					, providedFileSize = sz+					, providedMimeType = Nothing+					, providedMimeEncoding = Nothing+					}+				islargefile <- checkMatcher' matcher mi mempty+				metered Nothing sz $ const $ if islargefile+					then doimportlarge importkey cidmap db loc cid sz f+					else doimportsmall cidmap db loc cid sz+	+	doimportlarge importkey cidmap db loc cid sz f p =+		tryNonAsync importer >>= \case+			Right (Just (k, True)) -> return $ Just (loc, Right k)+			Right _ -> return Nothing+			Left e -> do+				warning (show e)+				return Nothing+	  where+		importer = do+			unsizedk <- importkey loc cid+				-- Don't display progress when generating+				-- key, if the content will later be+				-- downloaded, which is a more expensive+				-- operation generally.+				(if importcontent then nullMeterUpdate else p)+			-- This avoids every remote needing+			-- to add the size.+			let k = alterKey unsizedk $ \kd -> kd+				{ keySize = keySize kd <|> Just sz }+			checkSecureHashes k >>= \case+				Nothing -> do+					recordcidkey cidmap db cid k+					logChange k (Remote.uuid remote) InfoPresent+					if importcontent+						then getcontent k+						else return (Just (k, True))+				Just msg -> giveup (msg ++ " to import")+		+		getcontent :: Key -> Annex (Maybe (Key, Bool))+		getcontent k = do+			let af = AssociatedFile (Just f)+			let downloader p' tmpfile = do+				k' <- Remote.retrieveExportWithContentIdentifier+					ia loc cid tmpfile +					(pure k)+					(combineMeterUpdate p' p)+				ok <- moveAnnex k' tmpfile+				when ok $+					logStatus k InfoPresent+				return (Just (k', ok))+			checkDiskSpaceToGet k Nothing $+				notifyTransfer Download af $+					download (Remote.uuid remote) k af stdRetry $ \p' ->+						withTmp k $ downloader p'+			+	-- The file is small, so is added to git, so while importing+	-- without content does not retrieve annexed files, it does+	-- need to retrieve this file.+	doimportsmall cidmap db loc cid sz p = do+		let downloader tmpfile = do+			k <- Remote.retrieveExportWithContentIdentifier+				ia loc cid tmpfile+				(mkkey tmpfile)+				p+			case keyGitSha k of+				Just sha -> do+					recordcidkey cidmap db cid k+					return sha+				Nothing -> error "internal"+		checkDiskSpaceToGet tmpkey Nothing $+			withTmp tmpkey $ \tmpfile ->+				tryNonAsync (downloader tmpfile) >>= \case+					Right sha -> return $ Just (loc, Left sha) 					Left e -> do 						warning (show e) 						return Nothing-				metered Nothing	sz $-					const runimport+	  where+		tmpkey = importKey cid sz+		mkkey tmpfile = gitShaKey <$> hashFile tmpfile 	-	dodownload cidmap db (loc, (cid, sz)) largematcher = do-		f <- locworktreefile loc+	dodownload cidmap db (loc, (cid, sz)) f matcher = do 		let af = AssociatedFile (Just f) 		let downloader tmpfile p = do 			k <- Remote.retrieveExportWithContentIdentifier 				ia loc cid tmpfile -				(mkkey f tmpfile largematcher)+				(mkkey tmpfile) 				p 			case keyGitSha k of 				Nothing -> do@@ -445,25 +527,24 @@ 	  where 		tmpkey = importKey cid sz 	-	ia = Remote.importActions remote+		mkkey tmpfile = do+			let mi = MatchingFile FileInfo+				{ matchFile = f+				, contentFile = Just (toRawFilePath tmpfile)+				}+			islargefile <- checkMatcher' matcher mi mempty+			if islargefile+				then do+					backend <- chooseBackend (fromRawFilePath f)+					let ks = KeySource+						{ keyFilename = f+						, contentLocation = toRawFilePath tmpfile+						, inodeCache = Nothing+						}+					fst <$> genKey ks nullMeterUpdate backend+				else gitShaKey <$> hashFile tmpfile 	-	mkkey f tmpfile largematcher = do-		matcher <- largematcher (fromRawFilePath f)-		let mi = MatchingFile FileInfo-			{ matchFile = f-			, currFile = toRawFilePath tmpfile-			}-		islargefile <- checkMatcher' matcher mi mempty-		if islargefile-			then do-				backend <- chooseBackend (fromRawFilePath f)-				let ks = KeySource-					{ keyFilename = f-					, contentLocation = toRawFilePath tmpfile-					, inodeCache = Nothing-					}-				fst <$> genKey ks nullMeterUpdate backend-			else gitShaKey <$> hashFile tmpfile+	ia = Remote.importActions remote  	locworktreefile loc = fromRepo $ fromTopFilePath $ asTopFilePath $ 		case importtreeconfig of@@ -536,61 +617,62 @@   where 	load t = M.lookup (Remote.uuid r) . fst <$> preferredRequiredMapsLoad' t -wantImport :: FileMatcher Annex -> ImportLocation -> ByteSize -> Annex Bool-wantImport matcher loc sz = checkMatcher' matcher mi mempty-  where-	mi = MatchingInfo $ ProvidedInfo-		{ providedFilePath = Right $ fromRawFilePath $ fromImportLocation loc-		, providedKey = unavail "key"-		, providedFileSize = Right sz-		, providedMimeType = unavail "mime"-		, providedMimeEncoding = unavail "mime"-		}-	-- This should never run, as long as the FileMatcher was generated-	-- using the preferredContentKeylessTokens.-	unavail v = Left $ error $ "Internal error: unavailable " ++ v--{- If a file is not preferred content, but it was previously exported or- - imported to the remote, not importing it would result in a remote- - tracking branch that, when merged, would delete the file.- -- - To avoid that problem, such files are included in the import.- - The next export will remove them from the remote.- -}-shouldImport :: Export.ExportHandle -> FileMatcher Annex -> ImportLocation -> ByteSize -> Annex Bool-shouldImport dbhandle matcher loc sz = -	wantImport matcher loc sz-		<||>-	liftIO (not . null <$> Export.getExportTreeKey dbhandle loc)--filterImportableContents :: Remote -> FileMatcher Annex -> ImportableContents (ContentIdentifier, ByteSize) -> Annex (ImportableContents (ContentIdentifier, ByteSize))-filterImportableContents r matcher importable-	| isEmpty matcher = return importable-	| otherwise = do-		dbhandle <- Export.openDb (Remote.uuid r)-		go dbhandle importable-  where-	go dbhandle ic = ImportableContents-		<$> filterM (match dbhandle) (importableContents ic)-		<*> mapM (go dbhandle) (importableHistory ic)-	-	match dbhandle (loc, (_cid, sz)) = shouldImport dbhandle matcher loc sz-	 {- Gets the ImportableContents from the remote.  -  - Filters out any paths that include a ".git" component, because git does  - not allow storing ".git" in a git repository. While it is possible to  - write a git tree that contains that, git will complain and refuse to  - check it out.+ -+ - Filters out new things not matching the FileMatcher or that are+ - gitignored. However, files that are already in git get imported+ - regardless. (Similar to how git add behaves on gitignored files.)+ - This avoids creating a remote tracking branch that, when merged,+ - would delete the files.  -}-listImportableContents :: Remote -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))-listImportableContents r = fmap removegitspecial-	<$> Remote.listImportableContents (Remote.importActions r)+getImportableContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> FileMatcher Annex -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))+getImportableContents r importtreeconfig ci matcher = +	Remote.listImportableContents (Remote.importActions r) >>= \case+		Nothing -> return Nothing+		Just importable -> do+			dbhandle <- Export.openDb (Remote.uuid r)+			Just <$> filterunwanted dbhandle importable   where-	removegitspecial ic = ImportableContents-		{ importableContents = -			filter (not . gitspecial . fst) (importableContents ic)-		, importableHistory =-			map removegitspecial (importableHistory ic)+	filterunwanted dbhandle ic = ImportableContents+		<$> filterM (wanted dbhandle) (importableContents ic)+		<*> mapM (filterunwanted dbhandle) (importableHistory ic)+	+	wanted dbhandle (loc, (_cid, sz))+		| ingitdir = pure False+		| otherwise =+			isknown <||> (matches <&&> notignored)+	  where+		-- Checks, from least to most expensive.+		ingitdir = ".git" `elem` Posix.splitDirectories (fromImportLocation loc)+		matches = matchesImportLocation matcher loc sz+		isknown = isKnownImportLocation dbhandle loc+		notignored = notIgnoredImportLocation importtreeconfig ci loc++isKnownImportLocation :: Export.ExportHandle -> ImportLocation -> Annex Bool+isKnownImportLocation dbhandle loc = liftIO $+	not . null <$> Export.getExportTreeKey dbhandle loc++matchesImportLocation :: FileMatcher Annex -> ImportLocation -> Integer -> Annex Bool+matchesImportLocation matcher loc sz = checkMatcher' matcher mi mempty+  where+	mi = MatchingInfo $ ProvidedInfo+		{ providedFilePath = fromImportLocation loc+		, providedKey = Nothing+		, providedFileSize = sz+		, providedMimeType = Nothing+		, providedMimeEncoding = Nothing 		}-	gitspecial l = ".git" `elem` Posix.splitDirectories (fromRawFilePath (fromImportLocation l))++notIgnoredImportLocation :: ImportTreeConfig -> CheckGitIgnore -> ImportLocation -> Annex Bool+notIgnoredImportLocation importtreeconfig ci loc = not <$> checkIgnored ci f+  where+	f = fromRawFilePath $ case importtreeconfig of+		ImportSubTree dir _ ->+			getTopFilePath dir P.</> fromImportLocation loc+		ImportTree ->+			fromImportLocation loc
Annex/Ingest.hs view
@@ -1,6 +1,6 @@ {- git-annex content ingestion  -- - Copyright 2010-2019 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -18,7 +18,8 @@ 	addLink, 	makeLink, 	addUnlocked,-	forceParams,+	CheckGitIgnore(..),+	gitAddParams, 	addAnnexedFile, ) where @@ -31,6 +32,7 @@ import Annex.Link import Annex.MetaData import Annex.CurrentBranch+import Annex.CheckIgnore import Logs.Location import qualified Annex import qualified Annex.Queue@@ -125,19 +127,19 @@  {- Ingests a locked down file into the annex. Updates the work tree and  - index. -}-ingestAdd :: MeterUpdate -> Maybe LockedDown -> Annex (Maybe Key)-ingestAdd meterupdate ld = ingestAdd' meterupdate ld Nothing+ingestAdd :: CheckGitIgnore -> MeterUpdate -> Maybe LockedDown -> Annex (Maybe Key)+ingestAdd ci meterupdate ld = ingestAdd' ci meterupdate ld Nothing -ingestAdd' :: MeterUpdate -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key)-ingestAdd' _ Nothing _ = return Nothing-ingestAdd' meterupdate ld@(Just (LockedDown cfg source)) mk = do+ingestAdd' :: CheckGitIgnore -> MeterUpdate -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key)+ingestAdd' _ _ Nothing _ = return Nothing+ingestAdd' ci meterupdate ld@(Just (LockedDown cfg source)) mk = do 	(mk', mic) <- ingest meterupdate ld mk 	case mk' of 		Nothing -> return Nothing 		Just k -> do 			let f = keyFilename source 			if lockingFile cfg-				then addLink (fromRawFilePath f) k mic+				then addLink ci (fromRawFilePath f) k mic 				else do 					mode <- liftIO $ catchMaybeIO $ 						fileMode <$> R.getFileStatus (contentLocation source)@@ -292,23 +294,28 @@  - Also, using git add allows it to skip gitignored files, unless forced  - to include them.  -}-addLink :: FilePath -> Key -> Maybe InodeCache -> Annex ()-addLink file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig)+addLink :: CheckGitIgnore -> FilePath -> Key -> Maybe InodeCache -> Annex ()+addLink ci file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig) 	( do 		_ <- makeLink file key mcache-		ps <- forceParams+		ps <- gitAddParams ci 		Annex.Queue.addCommand "add" (ps++[Param "--"]) [file] 	, do 		l <- makeLink file key mcache 		addAnnexLink l (toRawFilePath file) 	) -{- Parameters to pass to git add, forcing addition of ignored files. -}-forceParams :: Annex [CommandParam]-forceParams = ifM (Annex.getState Annex.force)+{- Parameters to pass to git add, forcing addition of ignored files.+ -+ - Note that, when git add is being run on an ignored file that is already+ - checked in, CheckGitIgnore True has no effect.+ -}+gitAddParams :: CheckGitIgnore -> Annex [CommandParam]+gitAddParams (CheckGitIgnore True) = ifM (Annex.getState Annex.force) 	( return [Param "-f"] 	, return [] 	)+gitAddParams (CheckGitIgnore False) = return [Param "-f"]  {- Whether a file should be added unlocked or not. Default is to not,  - unless symlinks are not supported. annex.addunlocked can override that.@@ -332,15 +339,15 @@  -  - When the content of the key is not accepted into the annex, returns False.  -}-addAnnexedFile :: AddUnlockedMatcher -> FilePath -> Key -> Maybe FilePath -> Annex Bool-addAnnexedFile matcher file key mtmp = ifM (addUnlocked matcher mi)+addAnnexedFile :: CheckGitIgnore -> AddUnlockedMatcher -> FilePath -> Key -> Maybe FilePath -> Annex Bool+addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi) 	( do 		mode <- maybe 			(pure Nothing) 			(\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp) 			mtmp-		stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key-		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (toRawFilePath file))+		stagePointerFile file' mode =<< hashPointerFile key+		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file') 		case mtmp of 			Just tmp -> ifM (moveAnnex key tmp) 				( linkunlocked mode >> return True@@ -351,7 +358,7 @@ 				, writepointer mode >> return True 				) 	, do-		addLink file key Nothing+		addLink ci file key Nothing 		case mtmp of 			Just tmp -> moveAnnex key tmp 			Nothing -> return True@@ -359,24 +366,24 @@   where 	mi = case mtmp of 		Just tmp -> MatchingFile $ FileInfo-			{ currFile = toRawFilePath tmp-			, matchFile = toRawFilePath file+			{ contentFile = Just (toRawFilePath tmp)+			, matchFile = file' 			} 		-- Provide as much info as we can without access to the-		-- file's content. It's better to provide wrong info-		-- than for an operation to fail just because it can't-		-- tell if a file should be unlocked or locked.+		-- file's content. 		Nothing -> MatchingInfo $ ProvidedInfo-			{ providedFilePath = Right file-			, providedKey = Right key-			, providedFileSize = Right $ fromMaybe 0 $+			{ providedFilePath = file'+			, providedKey = Just key+			, providedFileSize = fromMaybe 0 $ 				keySize `fromKey` key-			, providedMimeType = Right "application/octet-stream"-			, providedMimeEncoding = Right "binary"+			, providedMimeType = Nothing+			, providedMimeEncoding = Nothing 			} 	 	linkunlocked mode = linkFromAnnex key file mode >>= \case 		LinkAnnexFailed -> liftIO $-			writePointerFile (toRawFilePath file) key mode+			writePointerFile file' key mode 		_ -> return ()-	writepointer mode = liftIO $ writePointerFile (toRawFilePath file) key mode+	writepointer mode = liftIO $ writePointerFile file' key mode++	file' = toRawFilePath file
Annex/Magic.hs view
@@ -1,6 +1,6 @@ {- Interface to libmagic  -- - Copyright 2019 Joey Hess <id@joeyh.name>+ - Copyright 2019-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -21,6 +21,8 @@ #ifdef WITH_MAGICMIME import Magic import Utility.Env+import Control.Concurrent+import System.IO.Unsafe (unsafePerformIO) import Common #else type Magic = ()@@ -41,7 +43,7 @@  getMagicMime :: Magic -> FilePath -> IO (Maybe (MimeType, MimeEncoding)) #ifdef WITH_MAGICMIME-getMagicMime m f = Just . parse <$> magicFile m f+getMagicMime m f = Just . parse <$> magicConcurrentSafe (magicFile m f)   where 	parse s =  		let (mimetype, rest) = separate (== ';') s@@ -58,3 +60,15 @@  getMagicMimeEncoding :: MonadIO m => Magic -> FilePath -> m(Maybe MimeEncoding) getMagicMimeEncoding m f = liftIO $ fmap snd <$> getMagicMime m f++#ifdef WITH_MAGICMIME+{-# NOINLINE mutex #-}+mutex :: MVar ()+mutex = unsafePerformIO $ newMVar ()++-- Work around a bug, the library is not concurrency safe and will+-- sometimes access the wrong memory if multiple ones are called at the+-- same time.+magicConcurrentSafe :: IO a -> IO a+magicConcurrentSafe = bracket_ (takeMVar mutex) (putMVar mutex ())+#endif
Annex/PidLock.hs view
@@ -67,7 +67,7 @@ 		let p' = p { env = Just ((v, PidF.pidLockEnvValue) : baseenv) } 		withCreateProcess p' a #else-	gonopidlock+	liftIO gonopidlock #endif  {- Wrap around actions that may run a git-annex child process via a git
Annex/SpecialRemote.hs view
@@ -36,7 +36,7 @@ 	headMaybe 		. sortBy (comparing $ \(u, _, _) -> Down $ M.lookup u t) 		. findByRemoteConfig (\c -> lookupName c == Just name)-		<$> Logs.Remote.readRemoteLog+		<$> Logs.Remote.remoteConfigMap  newConfig 	:: RemoteName@@ -56,7 +56,7 @@  specialRemoteMap :: Annex (M.Map UUID RemoteName) specialRemoteMap = do-	m <- Logs.Remote.readRemoteLog+	m <- Logs.Remote.remoteConfigMap 	return $ M.fromList $ mapMaybe go (M.toList m)   where 	go (u, c) = case lookupName c of@@ -79,7 +79,7 @@  autoEnable :: Annex () autoEnable = do-	remotemap <- M.filter configured <$> readRemoteLog+	remotemap <- M.filter configured <$> remoteConfigMap 	enabled <- getenabledremotes 	forM_ (M.toList remotemap) $ \(cu, c) -> unless (cu `M.member` enabled) $ do 		let u = case findSameasUUID c of
Annex/Ssh.hs view
@@ -34,6 +34,7 @@ import Utility.Env import Utility.Hash import Types.CleanupActions+import Annex.Concurrent.Utility import Types.Concurrency import Git.Env import Git.Ssh@@ -107,7 +108,7 @@ 	-- No connection caching with concurrency is not a good 	-- combination, so warn the user. 	go (Left whynocaching) = do-		Annex.getState Annex.concurrency >>= \case+		getConcurrency >>= \case                 	NonConcurrent -> return () 			Concurrent {} -> warnnocaching whynocaching 			ConcurrentPerCpu -> warnnocaching whynocaching@@ -229,7 +230,7 @@ 	 	let socketlock = socket2lock socketfile -	Annex.getState Annex.concurrency >>= \case+	getConcurrency >>= \case 		NonConcurrent -> return () 		Concurrent {} -> makeconnection socketlock 		ConcurrentPerCpu -> makeconnection socketlock
Annex/Transfer.hs view
@@ -31,6 +31,7 @@ import Types.Key import qualified Types.Remote as Remote import Types.Concurrency+import Annex.Concurrent.Utility import Types.WorkerPool import Annex.WorkerPool import Backend (isCryptographicallySecure)@@ -73,9 +74,7 @@  {- Like runTransfer, but ignores any existing transfer lock file for the  - transfer, allowing re-running a transfer that is already in progress.- -- - Note that this may result in confusing progress meter display in the- - webapp, if multiple processes are writing to the transfer info file. -}+ -} alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v alwaysRunTransfer = runTransfer' True @@ -262,7 +261,7 @@  - increase total transfer speed.  -} pickRemote :: Observable v => [Remote] -> (Remote -> Annex v) -> Annex v-pickRemote l a = debugLocks $ go l =<< Annex.getState Annex.concurrency+pickRemote l a = debugLocks $ go l =<< getConcurrency   where 	go [] _ = return observeFailure 	go (r:[]) _ = a r
Annex/YoutubeDl.hs view
@@ -1,6 +1,6 @@ {- youtube-dl integration for git-annex  -- - Copyright 2017-2018 Joey Hess <id@joeyh.name>+ - Copyright 2017-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -21,10 +21,15 @@ import Utility.DiskFree import Utility.HtmlDetect import Utility.Process.Transcript+import Utility.Metered+import Utility.DataUnits+import Messages.Progress import Logs.Transfer  import Network.URI import Control.Concurrent.Async+import Data.Char+import Text.Read  -- youtube-dl can follow redirects to anywhere, including potentially -- localhost or a private address. So, it's only allowed to download@@ -43,6 +48,8 @@ -- Runs youtube-dl in a work directory, to download a single media file -- from the url. Reutrns the path to the media file in the work directory. --+-- Displays a progress meter as youtube-dl downloads.+-- -- If youtube-dl fails without writing any files to the work directory,  -- or is not installed, returns Right Nothing. --@@ -53,14 +60,14 @@ -- -- (Note that we can't use --output to specifiy the file to download to, -- due to <https://github.com/rg3/youtube-dl/issues/14864>)-youtubeDl :: URLString -> FilePath -> Annex (Either String (Maybe FilePath))-youtubeDl url workdir = ifM ipAddressesUnlimited-	( withUrlOptions $ youtubeDl' url workdir+youtubeDl :: URLString -> FilePath -> MeterUpdate -> Annex (Either String (Maybe FilePath))+youtubeDl url workdir p = ifM ipAddressesUnlimited+	( withUrlOptions $ youtubeDl' url workdir p 	, return $ Left youtubeDlNotAllowedMessage 	) -youtubeDl' :: URLString -> FilePath -> UrlOptions -> Annex (Either String (Maybe FilePath))-youtubeDl' url workdir uo+youtubeDl' :: URLString -> FilePath -> MeterUpdate -> UrlOptions -> Annex (Either String (Maybe FilePath))+youtubeDl' url workdir p uo 	| supportedScheme uo url = ifM (liftIO $ inPath "youtube-dl") 		( runcmd >>= \case 			Right True -> workdirfiles >>= \case@@ -81,11 +88,17 @@ 	runcmd = youtubeDlMaxSize workdir >>= \case 		Left msg -> return (Left msg) 		Right maxsize -> do-			quiet <- commandProgressDisabled-			opts <- youtubeDlOpts $ dlopts ++ maxsize ++ -				if quiet then [ Param "--quiet" ] else []-			ok <- liftIO $ boolSystem' "youtube-dl" opts $-				\p -> p { cwd = Just workdir }+			opts <- youtubeDlOpts (dlopts ++ maxsize)+			oh <- mkOutputHandlerQuiet+			-- The size is unknown to start. Once youtube-dl+			-- outputs some progress, the meter will be updated+			-- with the size, which is why it's important the+			-- meter is passed into commandMeter'+			let unknownsize = Nothing :: Maybe FileSize+			ok <- metered (Just p) unknownsize $ \meter meterupdate ->+				liftIO $ commandMeter' +					parseYoutubeDlProgress oh (Just meter) meterupdate "youtube-dl" opts+					(\pr -> pr { cwd = Just workdir }) 			return (Right ok) 	dlopts =  		[ Param url@@ -125,10 +138,10 @@ 	)  -- Download a media file to a destination, -youtubeDlTo :: Key -> URLString -> FilePath -> Annex Bool-youtubeDlTo key url dest = do+youtubeDlTo :: Key -> URLString -> FilePath -> MeterUpdate -> Annex Bool+youtubeDlTo key url dest p = do 	res <- withTmpWorkDir key $ \workdir ->-		youtubeDl url workdir >>= \case+		youtubeDl url workdir p >>= \case 			Right (Just mediafile) -> do 				liftIO $ renameFile mediafile dest 				return (Just True)@@ -239,3 +252,37 @@ 		-- involving youtube-dl in a ftp download 		"ftp:" -> False 		_ -> allowedScheme uo u++{- Strategy: Look for chunks prefixed with \r, which look approximately+ - like this:+ - "ESC[K[download]  26.6% of 60.22MiB at 254.69MiB/s ETA 00:00"+ - Look at the number before "% of " and the number and unit after,+ - to determine the number of bytes.+ -}+parseYoutubeDlProgress :: ProgressParser+parseYoutubeDlProgress = go [] . reverse . progresschunks+  where+	delim = '\r'++	progresschunks = drop 1 . splitc delim++	go remainder [] = (Nothing, Nothing, remainder)+	go remainder (x:xs) = case split "% of " x of+		(p:r:[]) -> case (parsepercent p, parsebytes r) of+			(Just percent, Just total) ->+				( Just (toBytesProcessed (calc percent total))+				, Just (TotalSize total)+				, remainder+				)+			_ -> go (delim:x++remainder) xs+		_ -> go (delim:x++remainder) xs++	calc :: Double -> Integer -> Integer+	calc percent total = round (percent * fromIntegral total / 100)++	parsepercent :: String -> Maybe Double+	parsepercent = readMaybe . reverse . takeWhile (not . isSpace) . reverse++	parsebytes = readSize units . takeWhile (not . isSpace)++	units = memoryUnits ++ storageUnits
Assistant/Drop.hs view
@@ -16,6 +16,7 @@ import Logs.Location import CmdLine.Action import Types.NumCopies+import Types.Command  {- Drop from local and/or remote when allowed by the preferred content and  - numcopies settings. -}@@ -23,4 +24,7 @@ handleDrops reason fromhere key f preverified = do 	syncrs <- syncDataRemotes <$> getDaemonStatus 	locs <- liftAnnex $ loggedLocations key-	liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f preverified callCommandAction+	liftAnnex $ handleDropsFrom+		locs syncrs reason fromhere key f+		(SeekInput [])+		preverified callCommandAction
Assistant/Threads/Committer.hs view
@@ -24,6 +24,7 @@ import qualified Utility.Lsof as Lsof import qualified Utility.DirWatcher as DirWatcher import Types.KeySource+import Types.Command import Config import Annex.Content import Annex.Ingest@@ -286,7 +287,7 @@ 	  	ks = keySource ld 		doadd = sanitycheck ks $ do 			(mkey, _mcache) <- liftAnnex $ do-				showStart "add" $ keyFilename ks+				showStart "add" (keyFilename ks) (SeekInput []) 				ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing 			maybe (failedingest change) (done change $ fromRawFilePath $ keyFilename ks) mkey 	add _ _ = return Nothing
Assistant/Threads/TransferScanner.hs view
@@ -30,6 +30,7 @@ import Annex.Content import Annex.Wanted import CmdLine.Action+import Types.Command  import qualified Data.Set as S import Control.Concurrent@@ -168,7 +169,7 @@  		liftAnnex $ handleDropsFrom locs syncrs 			"expensive scan found too many copies of object"-			present key af [] callCommandAction+			present key af (SeekInput []) [] callCommandAction 		ts <- if present 			then liftAnnex . filterM (wantSend True (Just key) af . Remote.uuid . fst) 				=<< use syncDataRemotes (genTransfer Upload False)
Assistant/Threads/Watcher.hs view
@@ -169,7 +169,7 @@ 	ig _ = False  unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change)-unlessIgnored file a = ifM (liftAnnex $ checkIgnored file)+unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) file) 	( noChange 	, a 	)
Assistant/WebApp/Configurators/AWS.hs view
@@ -154,7 +154,7 @@  getEnableS3R :: UUID -> Handler Html getEnableS3R uuid = do-	m <- liftAnnex readRemoteLog+	m <- liftAnnex remoteConfigMap 	isia <- case M.lookup uuid m of 		Just c -> liftAnnex $ do 			pc <- parsedRemoteConfig S3.remote c@@ -180,7 +180,7 @@ 		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ awsCredsAForm defcreds 	case result of 		FormSuccess creds -> liftH $ do-			m <- liftAnnex readRemoteLog+			m <- liftAnnex remoteConfigMap 			let name = fromJust $ lookupName $ 				fromJust $ M.lookup uuid m 			makeAWSRemote enableSpecialRemote remotetype SmallArchiveGroup creds name M.empty
Assistant/WebApp/Configurators/Delete.hs view
@@ -59,7 +59,7 @@  	reponame <- liftAnnex $ Remote.prettyUUID uuid 	{- If it's not listed in the remote log, it must be a git repo. -}-	gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog+	gitrepo <- liftAnnex $ M.notMember uuid <$> remoteConfigMap 	$(widgetFile "configurators/delete/finished")	  getDeleteCurrentRepositoryR :: Handler Html
Assistant/WebApp/Configurators/Edit.hs view
@@ -71,7 +71,7 @@ 	void uuidDescMapLoad  	groups <- lookupGroups uuid-	remoteconfig <- M.lookup uuid <$> readRemoteLog+	remoteconfig <- M.lookup uuid <$> remoteConfigMap 	let (repogroup, associateddirectory) = case getStandardGroup groups of 		Nothing -> (RepoGroupCustom $ unwords $ map fromGroup $ S.toList groups, Nothing) 		Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g)@@ -122,7 +122,7 @@ 			| T.null t -> noop 			| otherwise -> liftAnnex $ do 				let dir = takeBaseName $ T.unpack t-				m <- readRemoteLog+				m <- remoteConfigMap 				case M.lookup uuid m of 					Nothing -> noop 					Just remoteconfig -> configSet uuid $@@ -220,7 +220,7 @@ 				let istransfer = repoGroup curr == RepoGroupStandard TransferGroup 				config <- liftAnnex $ fromMaybe mempty  					. M.lookup uuid-					<$> readRemoteLog+					<$> remoteConfigMap 				let repoInfo = getRepoInfo mremote config 				let repoEncryption = getRepoEncryption mremote (Just config) 				$(widgetFile "configurators/edit/repository")@@ -230,7 +230,7 @@ 		Just rmt -> do 			config <- liftAnnex $ fromMaybe mempty 				. M.lookup (Remote.uuid rmt)-				<$> readRemoteLog+				<$> remoteConfigMap 			getRepoInfo mr config 		Nothing -> getRepoInfo Nothing mempty 	g <- liftAnnex gitRepo@@ -242,7 +242,7 @@ checkAssociatedDirectory :: RepoConfig -> Maybe Remote -> Annex () checkAssociatedDirectory _ Nothing = noop checkAssociatedDirectory cfg (Just r) = do-	repoconfig <- M.lookup (Remote.uuid r) <$> readRemoteLog+	repoconfig <- M.lookup (Remote.uuid r) <$> remoteConfigMap 	case repoGroup cfg of 		RepoGroupStandard gr -> case associatedDirectory repoconfig gr of 			Just d -> do
Assistant/WebApp/Configurators/IA.hs view
@@ -158,7 +158,7 @@ 		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaCredsAForm defcreds 	case result of 		FormSuccess creds -> liftH $ do-			m <- liftAnnex readRemoteLog+			m <- liftAnnex remoteConfigMap 			let name = fromJust $ lookupName $ 				fromJust $ M.lookup uuid m 			AWS.makeAWSRemote enableSpecialRemote S3.remote PublicGroup creds name M.empty
Assistant/WebApp/Configurators/Ssh.hs view
@@ -209,7 +209,7 @@  -} enableSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> UUID -> Handler Html) -> UUID -> Handler Html enableSshRemote getsshdata rsyncnetsetup genericsetup u = do-	m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog+	m <- fromMaybe M.empty . M.lookup u <$> liftAnnex remoteConfigMap 	case (unmangle <$> getsshdata m, lookupName m) of 		(Just sshdata, Just reponame) -> sshConfigurator $ do 			((result, form), enctype) <- liftH $@@ -424,7 +424,7 @@ 		-- Not a UUID we know, so prompt about combining. 		$(widgetFile "configurators/ssh/combine") 	handleexisting (Just _) = prepSsh False sshdata $ \sshdata' -> do-		m <- liftAnnex readRemoteLog+		m <- liftAnnex remoteConfigMap 		case fromProposedAccepted <$> (M.lookup typeField =<< M.lookup u m) of 			Just "gcrypt" -> combineExistingGCrypt sshdata' u 			_ -> makeSshRepo ExistingRepo sshdata'@@ -545,7 +545,7 @@ 	-- Record the location of the ssh remote in the remote log, so it 	-- can easily be enabled elsewhere using the webapp. 	setup r = do-		m <- readRemoteLog+		m <- remoteConfigMap 		let c = fromMaybe M.empty (M.lookup (Remote.uuid r) m) 		let c' = M.insert (Proposed "location") (Proposed (genSshUrl sshdata)) $ 			M.insert typeField (Proposed "git") $
Assistant/WebApp/Configurators/WebDAV.hs view
@@ -53,7 +53,7 @@ getEnableWebDAVR = postEnableWebDAVR postEnableWebDAVR :: UUID -> Handler Html postEnableWebDAVR uuid = do-	m <- liftAnnex readRemoteLog+	m <- liftAnnex remoteConfigMap 	let c = fromJust $ M.lookup uuid m 	let name = fromJust $ lookupName c 	let url = fromProposedAccepted $ fromJust $ M.lookup (Accepted "url") c
Assistant/WebApp/Gpg.hs view
@@ -80,7 +80,7 @@ 	mname <- ifM (inRepo $ Git.Command.runBool [Param "fetch", Param tmpremote]) 		( do 			void Annex.Branch.forceUpdate-			(lookupName <=< M.lookup u) <$> readRemoteLog+			(lookupName <=< M.lookup u) <$> remoteConfigMap 		, return Nothing 		) 	void $ inRepo $ Git.Remote.Remove.remove tmpremote
Assistant/WebApp/RepoList.hs view
@@ -162,7 +162,7 @@ 					return $ here : l 				else return l 	unconfigured = liftAnnex $ do-		m <- readRemoteLog+		m <- remoteConfigMap 		g <- gitRepo 		map snd . catMaybes . filter selectedremote  			. map (findinfo m g)
Benchmark.hs view
@@ -15,7 +15,6 @@ import CmdLine.GitAnnex.Options import qualified Annex import qualified Annex.Branch-import Annex.Action  import qualified Options.Applicative as O @@ -35,10 +34,6 @@ 			-- The cmd is run for benchmarking without startup or 			-- shutdown actions. 			Annex.eval st $ performCommandAction cmd seek noop-		-- Since the cmd will be run many times, some zombie-		-- processes that normally only occur once per command-		-- will build up; reap them.-		reapZombies   where 	-- Simplified versio of CmdLine.dispatch, without support for fuzzy 	-- matching or out-of-repo commands.
CHANGELOG view
@@ -1,3 +1,52 @@+git-annex (8.20201007) upstream; urgency=medium++  * --json output now includes a new field "input" which is the input+    value (filename, url, etc) that caused a json object to be output.+  * --batch combined with -J now runs batch requests concurrently for many+    commands. Before, the combination was accepted, but did not enable+    concurrency. Since the output of batch requests can be in any order,+    --json with the new "input" field is recommended to be used,+    to determine which batch request each response corresponds to.+  * aws-0.22 improved its support for setting etags, which improves+    support for versioned S3 buckets.+  * Serialize use of C magic library, which is not thread safe.+    This fixes failures uploading to S3 when using -J.+  * add, addurl, importfeed, import: Added --no-check-gitignore option+    for finer grained control than using --force.+  * import: Check gitignores when importing trees from special remotes.+  * addunused: Don't check .gitignores when adding files.+  * Improve the "Try making some of these repositories available"+    message, with some hints for the user for what to do.+  * Improve --debug output to show pid of processes that are started and+    stopped.+  * sync --all: Sped up seeking to around twice as fast, by avoiding a+    pass over the worktree files when preferred content expressions of the+    local repo and remotes don't use include=/exclude=.+  * Sped up seeking for files to operate on, when using options like+    --copies or --in, by around 20%+  * import --no-content: Check annex.largefiles, and import small+    files into git, the same as is done when importing with content.+    If the largefiles expression needs the file content available+    (due to mimetype or mimeencoding being used), the import will fail.+  * sync: When run without --content, import without copying from+    importtree=yes directory special remotes.+    (Other special remotes may support this later as well.)+  * addurl: Avoid a redundant git ignores check for speed.+  * upgrade: Avoid an upgrade failure of a bare repo in unusual circumstances.+  * httpalso: Support being used with special remotes that do not have+    encryption= in their config.+  * Parse youtube-dl progress output, which lets progress be displayed+    when doing concurrent downloads.+  * Fix build with Benchmark build flag.+  * Enable building with git-annex benchmark by default, only turning it+    off when the criterion library is not installed.+  * runshell: Fix a edge case where rm errors were sent to stdout, which+    could confuse things parsing git-annex output.+  * runshell: Update files atomically when preparing to run git-annex.+  * Fix a build failure on Windows.++ -- Joey Hess <id@joeyh.name>  Wed, 07 Oct 2020 12:19:05 -0400+ git-annex (8.20200908) upstream; urgency=medium    * Added httpalso special remote, which is useful for accessing
CmdLine/Action.hs view
@@ -53,9 +53,11 @@  - This should only be run in the seek stage.  -} commandAction :: CommandStart -> Annex ()-commandAction start = Annex.getState Annex.concurrency >>= \case+commandAction start = getConcurrency >>= \case 	NonConcurrent -> runnonconcurrent-	Concurrent _ -> runconcurrent+	Concurrent n+		| n > 1 -> runconcurrent+		| otherwise -> runnonconcurrent 	ConcurrentPerCpu -> runconcurrent   where 	runnonconcurrent = void $ includeCommandAction start@@ -174,17 +176,11 @@  - 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' start = -	start >>= \case-		Nothing -> return Nothing-		Just (startmsg, perform) -> do-			showStartMessage startmsg-			Just <$> performCommandAction' startmsg perform+callCommandAction start = start >>= \case+	Just (startmsg, perform) -> do+		showStartMessage startmsg+		performCommandAction' startmsg perform+	Nothing -> return True  performCommandAction' :: StartMessage -> CommandPerform -> CommandCleanup performCommandAction' startmsg perform = @@ -206,9 +202,9 @@  -} startConcurrency :: UsedStages -> Annex a -> Annex a startConcurrency usedstages a = do-	fromcmdline <- Annex.getState Annex.concurrency+	fromcmdline <- getConcurrency 	fromgitcfg <- annexJobs <$> Annex.getGitConfig-	let usegitcfg = setConcurrency fromgitcfg+	let usegitcfg = setConcurrency (ConcurrencyGitConfig fromgitcfg) 	case (fromcmdline, fromgitcfg) of 		(NonConcurrent, NonConcurrent) -> a 		(Concurrent n, _) ->@@ -264,7 +260,7 @@  - 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+	go =<< getConcurrency   where 	go NonConcurrent = a 	go (Concurrent _) = goconcurrent
CmdLine/Batch.hs view
@@ -8,6 +8,7 @@ module CmdLine.Batch where  import Annex.Common+import qualified Annex import Types.Command import CmdLine.Action import CmdLine.GitAnnex.Options@@ -18,6 +19,8 @@ import Annex.BranchState import Annex.WorkTree import Annex.Content+import Annex.Concurrent+import Types.Concurrency  data BatchMode = Batch BatchFormat | NoBatch @@ -42,7 +45,9 @@ -- In batch mode, one line at a time is read, parsed, and a reply output to -- stdout. In non batch mode, the command's parameters are parsed and -- a reply output for each.-batchable :: (opts -> String -> Annex Bool) -> Parser opts -> CmdParamsDesc -> CommandParser+--+-- Note that the actions are not run concurrently.+batchable :: (opts -> SeekInput -> String -> Annex Bool) -> Parser opts -> CmdParamsDesc -> CommandParser batchable handler parser paramdesc = batchseeker <$> batchparser   where 	batchparser = (,,)@@ -51,12 +56,12 @@ 		<*> cmdParams paramdesc 	 	batchseeker (opts, NoBatch, params) =-		mapM_ (go NoBatch opts) params+		mapM_ (\p -> go NoBatch opts (SeekInput [p], p)) params 	batchseeker (opts, batchmode@(Batch fmt), _) =  		batchInput fmt (pure . Right) (go batchmode opts) -	go batchmode opts p =-		unlessM (handler opts p) $+	go batchmode opts (si, p) =+		unlessM (handler opts si p) $ 			batchBadInput batchmode  -- bad input is indicated by an empty line in batch mode. In non batch@@ -72,17 +77,18 @@ -- be converted to relative. Normally, filename parameters are passed -- through git ls-files, which makes them relative, but batch mode does -- not use that, and absolute worktree files are likely to cause breakage.-batchInput :: BatchFormat -> (String -> Annex (Either String a)) -> (a -> Annex ()) -> Annex ()+batchInput :: BatchFormat -> (String -> Annex (Either String v)) -> ((SeekInput, v) -> Annex ()) -> Annex () batchInput fmt parser a = go =<< batchLines fmt   where 	go [] = return () 	go (l:rest) = do-		either parseerr a =<< parser l+		either parseerr (\v -> a (SeekInput [l], v)) =<< parser l 		go rest 	parseerr s = giveup $ "Batch input parse failure: " ++ s  batchLines :: BatchFormat -> Annex [String] batchLines fmt = do+	checkBatchConcurrency 	enableInteractiveBranchAccess 	liftIO $ splitter <$> getContents   where@@ -90,45 +96,57 @@ 		BatchLine -> lines 		BatchNull -> splitc '\0' --- Runs a CommandStart in batch mode.---+-- When concurrency is enabled at the command line, it is used in batch+-- mode. But, if it's only set in git config, don't use it, because the+-- program using batch mode may not expect interleaved output.+checkBatchConcurrency :: Annex ()+checkBatchConcurrency = Annex.getState Annex.concurrency >>= \case+	ConcurrencyCmdLine _ -> noop+	ConcurrencyGitConfig _ -> +		setConcurrency (ConcurrencyGitConfig (Concurrent 1))++batchCommandAction :: CommandStart -> Annex ()+batchCommandAction = commandAction . batchCommandStart+ -- The batch mode user expects to read a line of output, and it's up to the -- CommandStart to generate that output as it succeeds or fails to do its -- job. However, if it stops without doing anything, it won't generate--- any output, so in that case, batchBadInput is used to provide the caller--- with an empty line.-batchCommandAction :: CommandStart -> Annex ()-batchCommandAction a = maybe (batchBadInput (Batch BatchLine)) (const noop)-	=<< callCommandAction' a+-- any output. This modifies it so in that case, an empty line is printed.+batchCommandStart :: CommandStart -> CommandStart+batchCommandStart a = a >>= \case+	Just v -> return (Just v)+	Nothing -> do+		batchBadInput (Batch BatchLine)+		return Nothing  -- Reads lines of batch input and passes the filepaths to a CommandStart -- to handle them. ----- Absolute filepaths are converted to relative.+-- Absolute filepaths are converted to relative, because in non-batch+-- mode, that is done when CmdLine.Seek uses git ls-files. ----- File matching options are not checked.-batchStart :: BatchFormat -> (FilePath -> CommandStart) -> Annex ()-batchStart fmt a = batchInput fmt (Right <$$> liftIO . relPathCwdToFile) $-	batchCommandAction . a---- Like batchStart, but checks the file matching options--- and skips non-matching files.-batchFilesMatching :: BatchFormat -> (RawFilePath -> CommandStart) -> Annex ()+-- File matching options are checked, and non-matching files skipped.+batchFilesMatching :: BatchFormat -> ((SeekInput, RawFilePath) -> CommandStart) -> Annex () batchFilesMatching fmt a = do 	matcher <- getMatcher-	batchStart fmt $ \f ->+	go $ \si f -> 		let f' = toRawFilePath f-		in ifM (matcher $ MatchingFile $ FileInfo f' f')-			( a f'+		in ifM (matcher $ MatchingFile $ FileInfo (Just f') f')+			( a (si, f') 			, return Nothing 			)+  where+	go a' = batchInput fmt +		(Right <$$> liftIO . relPathCwdToFile)+		(batchCommandAction . uncurry a')  batchAnnexedFilesMatching :: BatchFormat -> AnnexedFileSeeker -> Annex ()-batchAnnexedFilesMatching fmt seeker = batchFilesMatching fmt $-	whenAnnexed $ \f k -> case checkContentPresent seeker of-		Just v -> do-			present <- inAnnex k-			if present == v-				then startAction seeker f k-				else return Nothing-		Nothing -> startAction seeker f k+batchAnnexedFilesMatching fmt seeker = batchFilesMatching fmt $ \(si, bf) ->+	flip whenAnnexed bf $ \f k -> +		case checkContentPresent seeker of+			Just v -> do+				present <- inAnnex k+				if present == v+					then startAction seeker si f k+					else return Nothing+			Nothing -> startAction seeker si f k
CmdLine/GitAnnex/Options.hs view
@@ -392,7 +392,7 @@ -- action in `allowConcurrentOutput`. jobsOption :: [GlobalOption] jobsOption = -	[ globalSetter setConcurrency $ +	[ globalSetter (setConcurrency . ConcurrencyCmdLine) $  		option (maybeReader parseConcurrency) 			( long "jobs" <> short 'J'  			<> metavar (paramNumber `paramOr` "cpus")
CmdLine/Seek.hs view
@@ -18,7 +18,6 @@ import Types.FileMatcher import qualified Annex import qualified Git-import qualified Git.Command import qualified Git.LsFiles as LsFiles import qualified Git.LsTree as LsTree import qualified Git.Types as Git@@ -39,6 +38,7 @@ import Annex.Link import Annex.InodeSentinal import Annex.Concurrent+import Annex.CheckIgnore import qualified Annex.Branch import qualified Annex.BranchState import qualified Database.Keys@@ -50,7 +50,7 @@ import System.Posix.Types  data AnnexedFileSeeker = AnnexedFileSeeker-	{ startAction :: RawFilePath -> Key -> CommandStart+	{ startAction :: SeekInput -> RawFilePath -> Key -> CommandStart 	, checkContentPresent :: Maybe Bool 	, usesLocationLog :: Bool 	}@@ -67,32 +67,29 @@ 		else seekFilteredKeys a (getfiles [] l) 	)   where-	getfiles c [] = return (reverse c)+	getfiles c [] = return (reverse c, pure True) 	getfiles c (p:ps) = do 		os <- seekOptions ww 		(fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p]-		case fs of+		r <- case fs of 			[f] -> do 				void $ liftIO $ cleanup-				getfiles (f:c) ps+				fst <$> getfiles ((SeekInput [p], f):c) ps 			[] -> do 				void $ liftIO $ cleanup-				getfiles c ps-			_ -> giveup needforce+				fst <$> getfiles c ps+			_ -> do+				void $ liftIO $ cleanup+				giveup needforce+		return (r, pure True) withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop -withFilesNotInGit :: (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek-withFilesNotInGit a (WorkTreeItems l) = go =<< seek-  where-	seek = do-		force <- Annex.getState Annex.force-		g <- gitRepo-		liftIO $ Git.Command.leaveZombie-			<$> LsFiles.notInRepo [] force l' g-	go fs = seekFiltered a $-		return $ concat $ segmentPaths id l' fs-	l' = map toRawFilePath l-withFilesNotInGit _ NoWorkTreeItems = noop +withFilesNotInGit :: CheckGitIgnore -> WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek+withFilesNotInGit (CheckGitIgnore ci) ww a l = do+	force <- Annex.getState Annex.force+	let include_ignored = force || not ci+	seekFiltered (const (pure True)) a $+		seekHelper id ww (const $ LsFiles.notInRepo [] include_ignored) l  withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents a params = do@@ -109,7 +106,7 @@ 		, return [(p, takeFileName p)] 		) 	checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo-		{ currFile = toRawFilePath f+		{ contentFile = Just (toRawFilePath f) 		, matchFile = toRawFilePath relf 		} @@ -119,24 +116,24 @@ withStrings :: (String -> CommandSeek) -> CmdParams -> CommandSeek withStrings a params = sequence_ $ map a params -withPairs :: ((String, String) -> CommandSeek) -> CmdParams -> CommandSeek-withPairs a params = sequence_ $ map a $ pairs [] params+withPairs :: ((SeekInput, (String, String)) -> CommandSeek) -> CmdParams -> CommandSeek+withPairs a params = sequence_ $ +	map (\p@(x,y) -> a (SeekInput [x,y], p)) (pairs [] params)   where 	pairs c [] = reverse c 	pairs c (x:y:xs) = pairs ((x,y):c) xs 	pairs _ _ = giveup "expected pairs" -withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek-withFilesToBeCommitted a l = seekFiltered a $+withFilesToBeCommitted :: ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek+withFilesToBeCommitted a l = seekFiltered (const (pure True)) a $ 	seekHelper id WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l  {- unlocked pointer files that are staged, and whose content has not been  - modified-}-withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek-withUnmodifiedUnlockedPointers ww a l = seekFiltered a unlockedfiles-  where-	unlockedfiles = filterM isUnmodifiedUnlocked -		=<< seekHelper id ww (const LsFiles.typeChangedStaged) l+withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek+withUnmodifiedUnlockedPointers ww a l =+	seekFiltered (isUnmodifiedUnlocked . snd) a $+		seekHelper id ww (const LsFiles.typeChangedStaged) l  isUnmodifiedUnlocked :: RawFilePath -> Annex Bool isUnmodifiedUnlocked f = catKeyFile f >>= \case@@ -144,12 +141,12 @@ 	Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k  {- Finds files that may be modified. -}-withFilesMaybeModified :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek-withFilesMaybeModified ww a params = seekFiltered a $+withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek+withFilesMaybeModified ww a params = seekFiltered (const (pure True)) a $ 	seekHelper id ww LsFiles.modified params -withKeys :: (Key -> CommandSeek) -> CmdParams -> CommandSeek-withKeys a l = sequence_ $ map (a . parse) l+withKeys :: ((SeekInput, Key) -> CommandSeek) -> CmdParams -> CommandSeek+withKeys a ls = sequence_ $ map (\l -> a (SeekInput [l], parse l)) ls   where 	parse p = fromMaybe (giveup "bad key") $ deserializeKey p @@ -170,7 +167,7 @@ 	:: Maybe KeyOptions 	-> Bool 	-> AnnexedFileSeeker-	-> ((Key, ActionItem) -> CommandSeek)+	-> ((SeekInput, Key, ActionItem) -> CommandSeek) 	-> (WorkTreeItems -> CommandSeek) 	-> WorkTreeItems 	-> CommandSeek@@ -178,7 +175,7 @@   where 	mkkeyaction = do 		matcher <- Limit.getMatcher-		return $ \v@(k, ai) -> checkseeker k $+		return $ \v@(_si, k, ai) -> checkseeker k $ 			let i = case ai of 				ActionItemBranchFilePath (BranchFilePath _ topf) _ -> 					MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf)@@ -194,7 +191,7 @@ withKeyOptions'  	:: Maybe KeyOptions 	-> Bool-	-> Annex ((Key, ActionItem) -> Annex ())+	-> Annex ((SeekInput, Key, ActionItem) -> Annex ()) 	-> (WorkTreeItems -> CommandSeek) 	-> WorkTreeItems 	-> CommandSeek@@ -245,7 +242,7 @@ 			Nothing -> return () 			Just ((k, f), content) -> do 				maybe noop (Annex.BranchState.setCache f) content-				keyaction (k, mkActionItem k)+				keyaction (SeekInput [], k, mkActionItem k) 				go reader 		catObjectStreamLsTree l (getk . getTopFilePath . LsTree.file) g go 		liftIO $ void cleanup@@ -253,7 +250,7 @@ 	runkeyaction getks = do 		keyaction <- mkkeyaction 		ks <- getks-		forM_ ks $ \k -> keyaction (k, mkActionItem k)+		forM_ ks $ \k -> keyaction (SeekInput [], k, mkActionItem k) 	 	runbranchkeys bs = do 		keyaction <- mkkeyaction@@ -263,7 +260,7 @@ 				Nothing -> noop 				Just k ->  					let bfp = mkActionItem (BranchFilePath b (LsTree.file i), k)-					in keyaction (k, bfp)+					in keyaction (SeekInput [], k, bfp) 			unlessM (liftIO cleanup) $ 				error ("git ls-tree " ++ Git.fromRef b ++ " failed") 	@@ -272,127 +269,166 @@ 		rs <- remoteList 		ts <- concat <$> mapM (getFailedTransfers . Remote.uuid) rs 		forM_ ts $ \(t, i) ->-			keyaction (transferKey t, mkActionItem (t, i))+			keyaction (SeekInput [], transferKey t, mkActionItem (t, i)) -seekFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex ()-seekFiltered a fs = do+seekFiltered :: ((SeekInput, RawFilePath) -> Annex Bool) -> ((SeekInput, RawFilePath) -> CommandSeek) -> Annex ([(SeekInput, RawFilePath)], IO Bool) -> Annex ()+seekFiltered prefilter a listfs = do 	matcher <- Limit.getMatcher-	sequence_ =<< (map (process matcher) <$> fs)+	(fs, cleanup) <- listfs+	sequence_ (map (process matcher) fs)+	liftIO $ void cleanup   where-	process matcher f =-		whenM (matcher $ MatchingFile $ FileInfo f f) $ a f+	process matcher v@(_si, f) =+		whenM (prefilter v) $+			whenM (matcher $ MatchingFile $ FileInfo (Just f) f) $+				a v +data MatcherInfo = MatcherInfo+	{ matcherAction :: MatchInfo -> Annex Bool+	, matcherNeedsFileName :: Bool+	, matcherNeedsKey :: Bool+	, matcherNeedsLocationLog :: Bool+	}++checkMatcherWhen :: MatcherInfo -> Bool -> MatchInfo -> Annex () -> Annex ()+checkMatcherWhen mi c i a+	| c = whenM (matcherAction mi i) a+	| otherwise = a+ -- This is significantly faster than using lookupKey after seekFiltered, -- because of the way data is streamed through git cat-file. -- -- It can also precache location logs using the same efficient streaming.-seekFilteredKeys :: AnnexedFileSeeker -> Annex [(RawFilePath, Git.Sha, FileMode)] -> Annex ()+seekFilteredKeys :: AnnexedFileSeeker -> Annex ([(SeekInput, (RawFilePath, Git.Sha, FileMode))], IO Bool) -> Annex () seekFilteredKeys seeker listfs = do 	g <- Annex.gitRepo-	matcher <- Limit.getMatcher+	mi <- MatcherInfo+		<$> Limit.getMatcher+		<*> Limit.introspect matchNeedsFileName+		<*> Limit.introspect matchNeedsKey+		<*> Limit.introspect matchNeedsLocationLog 	config <- Annex.getGitConfig-	-- Run here, not in the async, because it could throw an exception-	-- The list should be built lazily.-	l <- listfs+	(l, cleanup) <- listfs 	catObjectMetaDataStream g $ \mdfeeder mdcloser mdreader -> 		catObjectStream g $ \ofeeder ocloser oreader -> do 			processertid <- liftIO . async =<< forkState-				(process matcher ofeeder mdfeeder mdcloser False l)+				(process mi ofeeder mdfeeder mdcloser False l) 			mdprocessertid <- liftIO . async =<< forkState-				(mdprocess matcher mdreader ofeeder ocloser)-			if usesLocationLog seeker+				(mdprocess mi mdreader ofeeder ocloser)+			if usesLocationLog seeker || matcherNeedsLocationLog mi 				then catObjectStream g $ \lfeeder lcloser lreader -> do 					precachertid <- liftIO . async =<< forkState-						(precacher config oreader lfeeder lcloser)-					precachefinisher lreader+						(precacher mi config oreader lfeeder lcloser)+					precachefinisher mi lreader 					join (liftIO (wait precachertid))-				else finisher oreader+				else finisher mi oreader 			join (liftIO (wait mdprocessertid)) 			join (liftIO (wait processertid))+	liftIO $ void cleanup   where-	checkpresence k cont = case checkContentPresent seeker of-		Just v -> do-			present <- inAnnex k-			when (present == v) cont-		Nothing -> cont--	finisher oreader = liftIO oreader >>= \case-		Just (f, content) -> do-			case parseLinkTargetOrPointerLazy =<< content of-				Just k -> checkpresence k $-					commandAction $-						startAction seeker f k-				Nothing -> noop-			finisher oreader+	finisher mi oreader = liftIO oreader >>= \case+		Just ((si, f), content) -> do+			keyaction f mi content $ +				commandAction . startAction seeker si f+			finisher mi oreader 		Nothing -> return () -	precachefinisher lreader = liftIO lreader >>= \case-		Just ((logf, f, k), logcontent) -> do+	precachefinisher mi lreader = liftIO lreader >>= \case+		Just ((logf, (si, f), k), logcontent) -> do 			maybe noop (Annex.BranchState.setCache logf) logcontent-			commandAction $ startAction seeker f k-			precachefinisher lreader+			checkMatcherWhen mi+				(matcherNeedsLocationLog mi && not (matcherNeedsFileName mi))+				(MatchingKey k (AssociatedFile (Just f)))+				(commandAction $ startAction seeker si f k)+			precachefinisher mi lreader 		Nothing -> return () 	-	precacher config oreader lfeeder lcloser = liftIO oreader >>= \case-		Just (f, content) -> do-			case parseLinkTargetOrPointerLazy =<< content of-				Just k -> checkpresence k $-					let logf = locationLogFile config k-					    ref = Git.Ref.branchFileRef Annex.Branch.fullname logf-					in liftIO $ lfeeder ((logf, f, k), ref)-				Nothing -> noop-			precacher config oreader lfeeder lcloser+	precacher mi config oreader lfeeder lcloser = liftIO oreader >>= \case+		Just ((si, f), content) -> do+			keyaction f mi content $ \k -> +				let logf = locationLogFile config k+				    ref = Git.Ref.branchFileRef Annex.Branch.fullname logf+				in liftIO $ lfeeder ((logf, (si, f), k), ref)+			precacher mi config oreader lfeeder lcloser 		Nothing -> liftIO $ void lcloser 	-	feedmatches matcher ofeeder f sha = -		whenM (matcher $ MatchingFile $ FileInfo f f) $-			liftIO $ ofeeder (f, sha)+	feedmatches mi ofeeder si f sha = checkMatcherWhen mi+		-- When the matcher needs a key or location log +		-- (and does not need a worktree filename), it will be+		-- checked later, to avoid a slow lookup here.+		(not ((matcherNeedsKey mi || matcherNeedsLocationLog mi) +			&& not (matcherNeedsFileName mi)))+		(MatchingFile $ FileInfo (Just f) f)+		(liftIO $ ofeeder ((si, f), sha)) -	process matcher ofeeder mdfeeder mdcloser seenpointer ((f, sha, mode):rest) =+	keyaction f mi content a = +		case parseLinkTargetOrPointerLazy =<< content of+			Just k -> checkMatcherWhen mi+				(matcherNeedsKey mi && not (matcherNeedsFileName mi || matcherNeedsLocationLog mi))+				(MatchingKey k (AssociatedFile (Just f)))+				(checkpresence k (a k))+			Nothing -> noop+	+	checkpresence k cont = case checkContentPresent seeker of+		Just v -> do+			present <- inAnnex k+			when (present == v) cont+		Nothing -> cont++	process mi ofeeder mdfeeder mdcloser seenpointer ((si, (f, sha, mode)):rest) = 		case Git.toTreeItemType mode of 			Just Git.TreeSymlink -> do 				whenM (exists f) $ 					-- Once a pointer file has been seen, 					-- symlinks have to be sent via the -					-- metadata processor too. That is slightly-					-- slower, but preserves the requested-					-- file order.+					-- metadata processor too. That is+					-- slightly slower, but preserves the+					-- requested file order. 					if seenpointer-						then liftIO $ mdfeeder (f, sha)-						else feedmatches matcher ofeeder f sha-				process matcher ofeeder mdfeeder mdcloser seenpointer rest+						then liftIO $ mdfeeder ((si, f), sha)+						else feedmatches mi ofeeder si f sha+				process mi ofeeder mdfeeder mdcloser seenpointer rest 			Just Git.TreeSubmodule ->-				process matcher ofeeder mdfeeder mdcloser seenpointer rest+				process mi ofeeder mdfeeder mdcloser seenpointer rest 			-- Might be a pointer file, might be other 			-- file in git, possibly large. Avoid catting 			-- large files by first looking up the size. 			Just _ -> do 				whenM (exists f) $-					liftIO $ mdfeeder (f, sha)-				process matcher ofeeder mdfeeder mdcloser True rest+					liftIO $ mdfeeder ((si, f), sha)+				process mi ofeeder mdfeeder mdcloser True rest 			Nothing ->-				process matcher ofeeder mdfeeder mdcloser seenpointer rest+				process mi ofeeder mdfeeder mdcloser seenpointer rest 	process _ _ _ mdcloser _ [] = liftIO $ void mdcloser 	 	-- Check if files exist, because a deleted file will still be 	-- listed by ls-tree, but should not be processed. 	exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p) -	mdprocess matcher mdreader ofeeder ocloser = liftIO mdreader >>= \case-		Just (f, Just (sha, size, _type))+	mdprocess mi mdreader ofeeder ocloser = liftIO mdreader >>= \case+		Just ((si, f), Just (sha, size, _type)) 			| size < maxPointerSz -> do-				feedmatches matcher ofeeder f sha-				mdprocess matcher mdreader ofeeder ocloser-		Just _ -> mdprocess matcher mdreader ofeeder ocloser+				feedmatches mi ofeeder si f sha+				mdprocess mi mdreader ofeeder ocloser+		Just _ -> mdprocess mi mdreader ofeeder ocloser 		Nothing -> liftIO $ void ocloser -seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex [a]+seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex ([(SeekInput, a)], IO Bool) seekHelper c ww a (WorkTreeItems l) = do 	os <- seekOptions ww-	inRepo $ \g ->-		concat . concat <$> forM (segmentXargsOrdered l)-			(runSegmentPaths c (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath)-seekHelper _ _ _ NoWorkTreeItems = return []+	inRepo $ \g -> combinelists <$> forM (segmentXargsOrdered l)+		(runSegmentPaths' mk c (\fs -> a os fs g) . map toRawFilePath)+  where+	mk (Just i) f = (SeekInput [fromRawFilePath i], f) +	-- This is not accurate, but it only happens when there are a+	-- great many input WorkTreeItems.+	mk Nothing f = (SeekInput [fromRawFilePath (c f)], f)++	combinelists v = +		let r = concat $ concat $ map fst v+		    cleanup = and <$> sequence (map snd v)+		in (r, cleanup)+seekHelper _ _ _ NoWorkTreeItems = return ([], pure True)  data WarnUnmatchWhen = WarnUnmatchLsFiles | WarnUnmatchWorkTreeItems
Command.hs view
@@ -74,13 +74,15 @@ withGlobalOptions os c = c { cmdglobaloptions = cmdglobaloptions c ++ concat os }  {- 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)+starting:: MkActionItem actionitem => String -> actionitem -> SeekInput -> CommandPerform -> CommandStart+starting msg ai si a = next+	(StartMessage msg (mkActionItem ai) si, 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)+startingUsualMessages :: MkActionItem t => String -> t -> SeekInput -> CommandPerform -> CommandStart+startingUsualMessages msg t si a = next +	(StartUsualMessages msg (mkActionItem t) si, a)  {- When no message should be displayed at start/end, but messages can still   - be displayed when using eg includeCommandAction. -}
Command/Add.hs view
@@ -24,6 +24,7 @@ import Config.GitConfig import qualified Git.UpdateIndex import Utility.FileMode+import Utility.OptParse import qualified Utility.RawFilePath as R  cmd :: Command@@ -37,6 +38,7 @@ 	, batchOption :: BatchMode 	, updateOnly :: Bool 	, largeFilesOverride :: Maybe Bool+	, checkGitIgnoreOption :: CheckGitIgnore 	}  optParser :: CmdParamsDesc -> Parser AddOptions@@ -49,6 +51,7 @@ 		<> help "only update tracked files" 		) 	<*> (parseforcelarge <|> parseforcesmall)+	<*> checkGitIgnoreSwitch   where 	parseforcelarge = flag Nothing (Just True) 		( long "force-large"@@ -59,23 +62,28 @@ 		<> help "add all files to git, ignoring other configuration" 		) +checkGitIgnoreSwitch :: Parser CheckGitIgnore+checkGitIgnoreSwitch = CheckGitIgnore <$>+	invertableSwitch "check-gitignore" True+		(help "Do not check .gitignore when adding files")+ seek :: AddOptions -> CommandSeek seek o = startConcurrency commandStages $ do 	largematcher <- largeFilesMatcher 	addunlockedmatcher <- addUnlockedMatcher 	annexdotfiles <- getGitConfigVal annexDotFiles -	let gofile file = case largeFilesOverride o of+	let gofile (si, file) = case largeFilesOverride o of 		Nothing ->  			let file' = fromRawFilePath file 			in ifM (pure (annexdotfiles || not (dotfile file')) <&&> (checkFileMatcher largematcher file' <||> Annex.getState Annex.force))-				( start file addunlockedmatcher+				( start o si file addunlockedmatcher 				, ifM (annexAddSmallFiles <$> Annex.getGitConfig)-					( startSmall file+					( startSmall o si file 					, stop 					) 				)-		Just True -> start file addunlockedmatcher-		Just False -> startSmallOverridden file+		Just True -> start o si file addunlockedmatcher+		Just False -> startSmallOverridden o si file 	case batchOption o of 		Batch fmt 			| updateOnly o ->@@ -90,31 +98,33 @@ 			l <- workTreeItems ww (addThese o) 			let go a = a ww (commandAction . gofile) l 			unless (updateOnly o) $-				go (const withFilesNotInGit)+				go (withFilesNotInGit (checkGitIgnoreOption o)) 			go withFilesMaybeModified 			go withUnmodifiedUnlockedPointers  {- Pass file off to git-add. -}-startSmall :: RawFilePath -> CommandStart-startSmall file = starting "add" (ActionItemWorkTreeFile file) $-	next $ addSmall file+startSmall :: AddOptions -> SeekInput -> RawFilePath -> CommandStart+startSmall o si file =+	starting "add" (ActionItemWorkTreeFile file) si $+		next $ addSmall (checkGitIgnoreOption o) file -addSmall :: RawFilePath -> Annex Bool-addSmall file = do+addSmall :: CheckGitIgnore -> RawFilePath -> Annex Bool+addSmall ci file = do 	showNote "non-large file; adding content to git repository"-	addFile file+	addFile ci file -startSmallOverridden :: RawFilePath -> CommandStart-startSmallOverridden file = starting "add" (ActionItemWorkTreeFile file) $-	next $ addSmallOverridden file+startSmallOverridden :: AddOptions -> SeekInput -> RawFilePath -> CommandStart+startSmallOverridden o si file = +	starting "add" (ActionItemWorkTreeFile file) si $+		next $ addSmallOverridden o file -addSmallOverridden :: RawFilePath -> Annex Bool-addSmallOverridden file = do+addSmallOverridden :: AddOptions -> RawFilePath -> Annex Bool+addSmallOverridden o file = do 	showNote "adding content to git repository" 	let file' = fromRawFilePath file 	s <- liftIO $ getSymbolicLinkStatus file' 	if not (isRegularFile s)-		then addFile file +		then addFile (checkGitIgnoreOption o) file 		else do 			-- Can't use addFile because the clean filter will 			-- honor annex.largefiles and it has been overridden.@@ -127,14 +137,14 @@ 				inRepo (Git.UpdateIndex.stageFile sha ty file') 			return True -addFile :: RawFilePath -> Annex Bool-addFile file = do-	ps <- forceParams+addFile :: CheckGitIgnore -> RawFilePath -> Annex Bool+addFile ci file = do+	ps <- gitAddParams ci 	Annex.Queue.addCommand "add" (ps++[Param "--"]) [fromRawFilePath file] 	return True -start :: RawFilePath -> AddUnlockedMatcher -> CommandStart-start file addunlockedmatcher = do+start :: AddOptions -> SeekInput -> RawFilePath -> AddUnlockedMatcher -> CommandStart+start o si file addunlockedmatcher = do 	mk <- liftIO $ isPointerFile file 	maybe go fixuppointer mk   where@@ -144,29 +154,29 @@ 		Just s  			| not (isRegularFile s) && not (isSymbolicLink s) -> stop 			| otherwise -> -				starting "add" (ActionItemWorkTreeFile file) $+				starting "add" (ActionItemWorkTreeFile file) si $ 					if isSymbolicLink s-						then next $ addFile file-						else perform file addunlockedmatcher+						then next $ addFile (checkGitIgnoreOption o) file+						else perform o file addunlockedmatcher 	addpresent key =  		liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case 			Just s | isSymbolicLink s -> fixuplink key 			_ -> add-	fixuplink key = starting "add" (ActionItemWorkTreeFile file) $ do+	fixuplink key = starting "add" (ActionItemWorkTreeFile file) si $ do 		-- the annexed symlink is present but not yet added to git 		liftIO $ removeFile (fromRawFilePath file)-		addLink (fromRawFilePath file) key Nothing+		addLink (checkGitIgnoreOption o) (fromRawFilePath file) key Nothing 		next $ 			cleanup key =<< inAnnex key-	fixuppointer key = starting "add" (ActionItemWorkTreeFile file) $ do+	fixuppointer key = starting "add" (ActionItemWorkTreeFile file) si $ do 		-- the pointer file is present, but not yet added to git 		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)-		next $ addFile file+		next $ addFile (checkGitIgnoreOption o) file -perform :: RawFilePath -> AddUnlockedMatcher -> CommandPerform-perform file addunlockedmatcher = withOtherTmp $ \tmpdir -> do+perform :: AddOptions -> RawFilePath -> AddUnlockedMatcher -> CommandPerform+perform o file addunlockedmatcher = withOtherTmp $ \tmpdir -> do 	lockingfile <- not <$> addUnlocked addunlockedmatcher-		(MatchingFile (FileInfo file file))+		(MatchingFile (FileInfo (Just file) file)) 	let cfg = LockDownConfig 		{ lockingFile = lockingfile 		, hardlinkFileTmpDir = Just tmpdir@@ -174,7 +184,7 @@ 	ld <- lockDown cfg (fromRawFilePath file) 	let sizer = keySource <$> ld 	v <- metered Nothing sizer $ \_meter meterupdate ->-		ingestAdd meterupdate ld+		ingestAdd (checkGitIgnoreOption o) meterupdate ld 	finish v   where 	finish (Just key) = next $ cleanup key True
Command/AddUnused.hs view
@@ -28,7 +28,9 @@ perform :: Key -> CommandPerform perform key = next $ do 	logStatus key InfoPresent-	addLink file key Nothing+	-- Ignore the usual git ignores because the user has explictly+	-- asked to add these files.+	addLink (CheckGitIgnore False) file key Nothing 	return True   where 	file = "unused." ++ fromRawFilePath (keyFile key)
Command/AddUrl.hs view
@@ -54,6 +54,7 @@ 	, rawOption :: Bool 	, fileOption :: Maybe FilePath 	, preserveFilenameOption :: Bool+	, checkGitIgnoreOption :: CheckGitIgnore 	}  optParser :: CmdParamsDesc -> Parser AddUrlOptions@@ -100,16 +101,18 @@ 			<> help "use filename provided by server as-is" 			) 		else pure False)+	<*> Command.Add.checkGitIgnoreSwitch  seek :: AddUrlOptions -> CommandSeek seek o = startConcurrency commandStages $ do 	addunlockedmatcher <- addUnlockedMatcher-	let go (o', u) = do+	let go (si, (o', u)) = do 		r <- Remote.claimingUrl u 		if Remote.uuid r == webUUID || rawOption (downloadOptions o')-			then void $ commandAction $ startWeb addunlockedmatcher o' u-			else checkUrl addunlockedmatcher r o' u-	forM_ (addUrls o) (\u -> go (o, u))+			then void $ commandAction $+				startWeb addunlockedmatcher o' si u+			else checkUrl addunlockedmatcher r o' si u+	forM_ (addUrls o) (\u -> go (SeekInput [u], (o, u))) 	case batchOption o of 		Batch fmt -> batchInput fmt (pure . parseBatchInput o) go 		NoBatch -> noop@@ -123,8 +126,8 @@ 			else Right (o { downloadOptions = (downloadOptions o) { fileOption = Just f } }, u) 	| otherwise = Right (o, s) -checkUrl :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> Annex ()-checkUrl addunlockedmatcher r o u = do+checkUrl :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> URLString -> Annex ()+checkUrl addunlockedmatcher r o si u = do 	pathmax <- liftIO $ fileNameLengthLimit "." 	let deffile = fromMaybe (urlString2file u (pathdepthOption o) pathmax) (fileOption (downloadOptions o)) 	go deffile =<< maybe@@ -133,35 +136,35 @@ 		(Remote.checkUrl r)   where -	go _ (Left e) = void $ commandAction $ startingAddUrl u o $ do+	go _ (Left e) = void $ commandAction $ startingAddUrl si u o $ do 		warning (show e) 		next $ return False 	go deffile (Right (UrlContents sz mf)) = do 		f <- maybe (pure deffile) (sanitizeOrPreserveFilePath o) mf 		let f' = adjustFile o (fromMaybe f (fileOption (downloadOptions o)))-		void $ commandAction $ startRemote addunlockedmatcher r o f' u sz+		void $ commandAction $ startRemote addunlockedmatcher r o si f' u sz 	go deffile (Right (UrlMulti l)) = case fileOption (downloadOptions o) of 		Nothing -> 			forM_ l $ \(u', sz, f) -> do 				f' <- sanitizeOrPreserveFilePath o f 				let f'' = adjustFile o (deffile </> f')-				void $ commandAction $ startRemote addunlockedmatcher r o f'' u' sz+				void $ commandAction $ startRemote addunlockedmatcher r o si f'' u' sz 		Just f -> case l of 			[] -> noop 			((u',sz,_):[]) -> do 				let f' = adjustFile o f-				void $ commandAction $ startRemote addunlockedmatcher r o f' u' sz+				void $ commandAction $ startRemote addunlockedmatcher r o si f' u' sz 			_ -> giveup $ unwords 				[ "That url contains multiple files according to the" 				, Remote.name r 				, " remote; cannot add it to a single file." 				] -startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> FilePath -> URLString -> Maybe Integer -> CommandStart-startRemote addunlockedmatcher r o file uri sz = do+startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> FilePath -> URLString -> Maybe Integer -> CommandStart+startRemote addunlockedmatcher r o si file uri sz = do 	pathmax <- liftIO $ fileNameLengthLimit "." 	let file' = joinPath $ map (truncateFilePath pathmax) $ splitDirectories file-	startingAddUrl uri o $ do+	startingAddUrl si uri o $ do 		showNote $ "from " ++ Remote.name r  		showDestinationFile file' 		performRemote addunlockedmatcher r o uri file' sz@@ -177,12 +180,12 @@ 	geturi = next $ isJust <$> downloadRemoteFile addunlockedmatcher r (downloadOptions o) uri file sz  downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key)-downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd file $ do+downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \canadd -> do 	let urlkey = Backend.URL.fromUrl uri sz 	createWorkTreeDirectory (parentDir file) 	ifM (Annex.getState Annex.fast <||> pure (relaxedOption o)) 		( do-			addWorkTree addunlockedmatcher (Remote.uuid r) loguri file urlkey Nothing+			addWorkTree canadd addunlockedmatcher (Remote.uuid r) loguri file urlkey Nothing 			return (Just urlkey) 		, do 			-- Set temporary url for the urlkey@@ -191,7 +194,7 @@ 			setTempUrl urlkey loguri 			let downloader = \dest p -> 				fst <$> Remote.verifiedAction (Remote.retrieveKeyFile r urlkey af dest p)-			ret <- downloadWith addunlockedmatcher downloader urlkey (Remote.uuid r) loguri file+			ret <- downloadWith canadd addunlockedmatcher downloader urlkey (Remote.uuid r) loguri file 			removeTempUrl urlkey 			return ret 		)@@ -199,12 +202,12 @@ 	loguri = setDownloader uri OtherDownloader 	af = AssociatedFile (Just (toRawFilePath file)) -startWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> CommandStart-startWeb addunlockedmatcher o urlstring = go $ fromMaybe bad $ parseURI urlstring+startWeb :: AddUnlockedMatcher -> AddUrlOptions -> SeekInput -> URLString -> CommandStart+startWeb addunlockedmatcher o si urlstring = go $ fromMaybe bad $ parseURI urlstring   where 	bad = fromMaybe (giveup $ "bad url " ++ urlstring) $ 		Url.parseURIRelaxed $ urlstring-	go url = startingAddUrl urlstring o $+	go url = startingAddUrl si urlstring o $ 		if relaxedOption (downloadOptions o) 			then go' url Url.assumeUrlExists 			else Url.withUrlOptions (Url.getUrlInfo urlstring) >>= \case@@ -308,10 +311,10 @@ 		( tryyoutubedl tmp 		, normalfinish tmp 		)-	normalfinish tmp = checkCanAdd file $ do+	normalfinish tmp = checkCanAdd o file $ \canadd -> do 		showDestinationFile file 		createWorkTreeDirectory (parentDir file)-		Just <$> finishDownloadWith addunlockedmatcher tmp webUUID url file+		Just <$> finishDownloadWith canadd addunlockedmatcher tmp webUUID url file 	-- Ask youtube-dl what filename it will download first,  	-- so it's only used when the file contains embedded media. 	tryyoutubedl tmp = youtubeDlFileNameHtmlOnly url >>= \case@@ -324,14 +327,15 @@ 	  where 		dl dest = withTmpWorkDir mediakey $ \workdir -> do 			let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . nukeFile)+			showNote "using youtube-dl" 			Transfer.notifyTransfer Transfer.Download url $-				Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \_p ->-					youtubeDl url workdir >>= \case+				Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p ->+					youtubeDl url workdir p >>= \case 						Right (Just mediafile) -> do 							cleanuptmp-							checkCanAdd dest $ do+							checkCanAdd o dest $ \canadd -> do 								showDestinationFile dest-								addWorkTree addunlockedmatcher webUUID mediaurl dest mediakey (Just mediafile)+								addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just mediafile) 								return $ Just mediakey 						Right Nothing -> normalfinish tmp 						Left msg -> do@@ -353,8 +357,8 @@ {- 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. -}-startingAddUrl :: URLString -> AddUrlOptions -> CommandPerform -> CommandStart-startingAddUrl url o p = starting "addurl" (ActionItemOther (Just url)) $ do+startingAddUrl :: SeekInput -> URLString -> AddUrlOptions -> CommandPerform -> CommandStart+startingAddUrl si url o p = starting "addurl" (ActionItemOther (Just url)) si $ do 	case fileOption (downloadOptions o) of 		Nothing -> noop 		Just file -> maybeShowJSON $ JSONChunk [("file", file)]@@ -374,13 +378,13 @@  - Downloads the url, sets up the worktree file, and returns the  - real key.  -}-downloadWith :: AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> FilePath -> Annex (Maybe Key)-downloadWith addunlockedmatcher downloader dummykey u url file =+downloadWith :: CanAddFile -> AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> FilePath -> Annex (Maybe Key)+downloadWith canadd addunlockedmatcher downloader dummykey u url file = 	go =<< downloadWith' downloader dummykey u url afile   where 	afile = AssociatedFile (Just (toRawFilePath file)) 	go Nothing = return Nothing-	go (Just tmp) = Just <$> finishDownloadWith addunlockedmatcher tmp u url file+	go (Just tmp) = Just <$> finishDownloadWith canadd addunlockedmatcher tmp u url file  {- Like downloadWith, but leaves the dummy key content in  - the returned location. -}@@ -396,8 +400,8 @@ 			then return (Just tmp) 			else return Nothing -finishDownloadWith :: AddUnlockedMatcher -> FilePath -> UUID -> URLString -> FilePath -> Annex Key-finishDownloadWith addunlockedmatcher tmp u url file = do+finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> FilePath -> UUID -> URLString -> FilePath -> Annex Key+finishDownloadWith canadd addunlockedmatcher tmp u url file = do 	backend <- chooseBackend file 	let source = KeySource 		{ keyFilename = toRawFilePath file@@ -405,7 +409,7 @@ 		, inodeCache = Nothing 		} 	key <- fst <$> genKey source nullMeterUpdate backend-	addWorkTree addunlockedmatcher u url file key (Just tmp)+	addWorkTree canadd addunlockedmatcher u url file key (Just tmp) 	return key  {- Adds the url size to the Key. -}@@ -415,8 +419,8 @@ 	}  {- Adds worktree file to the repository. -}-addWorkTree :: AddUnlockedMatcher -> UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex ()-addWorkTree addunlockedmatcher u url file key mtmp = case mtmp of+addWorkTree :: CanAddFile -> AddUnlockedMatcher -> UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex ()+addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of 	Nothing -> go 	Just tmp -> do 		-- Move to final location for large file check.@@ -432,18 +436,22 @@ 				-- than the work tree file. 				liftIO $ renameFile file tmp 				go-			else void $ Command.Add.addSmall (toRawFilePath file)+			else void $ Command.Add.addSmall noci (toRawFilePath file)   where 	go = do 		maybeShowJSON $ JSONChunk [("key", serializeKey key)] 		setUrlPresent key url 		logChange key u InfoPresent-		ifM (addAnnexedFile addunlockedmatcher file key mtmp)+		ifM (addAnnexedFile noci addunlockedmatcher file key mtmp) 			( do 				when (isJust mtmp) $ 					logStatus key InfoPresent 			, maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . nukeFile)) mtmp 			)+	+	-- git does not need to check ignores, because that has already+	-- been done, as witnessed by the CannAddFile.+	noci = CheckGitIgnore False  nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) nodownloadWeb addunlockedmatcher o url urlinfo file@@ -457,23 +465,23 @@   where 	nomedia = do 		let key = Backend.URL.fromUrl url (Url.urlSize urlinfo)-		nodownloadWeb' addunlockedmatcher url key file+		nodownloadWeb' o addunlockedmatcher url key file 	usemedia mediafile = do 		let dest = youtubeDlDestFile o file mediafile 		let mediaurl = setDownloader url YoutubeDownloader 		let mediakey = Backend.URL.fromUrl mediaurl Nothing-		nodownloadWeb' addunlockedmatcher mediaurl mediakey dest+		nodownloadWeb' o addunlockedmatcher mediaurl mediakey dest  youtubeDlDestFile :: DownloadOptions -> FilePath -> FilePath -> FilePath youtubeDlDestFile o destfile mediafile 	| isJust (fileOption o) = destfile 	| otherwise = takeFileName mediafile -nodownloadWeb' :: AddUnlockedMatcher -> URLString -> Key -> FilePath -> Annex (Maybe Key)-nodownloadWeb' addunlockedmatcher url key file = checkCanAdd file $ do+nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> FilePath -> Annex (Maybe Key)+nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do 	showDestinationFile file 	createWorkTreeDirectory (parentDir file)-	addWorkTree addunlockedmatcher webUUID url file key Nothing+	addWorkTree canadd addunlockedmatcher webUUID url file key Nothing 	return (Just key)  url2file :: URI -> Maybe Int -> Int -> FilePath@@ -505,15 +513,17 @@ 	addprefix f = maybe f (++ f) (prefixOption o) 	addsuffix f = maybe f (f ++) (suffixOption o) -checkCanAdd :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)-checkCanAdd file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus file))+data CanAddFile = CanAddFile++checkCanAdd :: DownloadOptions -> FilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a)+checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus file)) 	( do 		warning $ file ++ " already exists; not overwriting" 		return Nothing-	, ifM ((not <$> Annex.getState Annex.force) <&&> checkIgnored file)+	, ifM (checkIgnored (checkGitIgnoreOption o) file) 		( do-			warning $ "not adding " ++ file ++ " which is .gitignored (use --force to override)"+			warning $ "not adding " ++ file ++ " which is .gitignored (use --no-check-gitignore to override)" 			return Nothing-		, a+		, a CanAddFile 		) 	)
Command/Adjust.hs view
@@ -51,5 +51,5 @@ start :: Adjustment -> CommandStart start adj = do 	checkVersionSupported-	starting "adjust" (ActionItemOther Nothing) $+	starting "adjust" (ActionItemOther Nothing) (SeekInput []) $ 		next $ enterAdjustedBranch adj
Command/CalcKey.hs view
@@ -19,8 +19,8 @@ 		(paramRepeating paramFile) 		(batchable run (pure ())) -run :: () -> String -> Annex Bool-run _ file = tryNonAsync (genKey ks nullMeterUpdate Nothing) >>= \case+run :: () -> SeekInput -> String -> Annex Bool+run _ _ file = tryNonAsync (genKey ks nullMeterUpdate Nothing) >>= \case 	Right (k, _) -> do 		liftIO $ putStrLn $ serializeKey k 		return True
Command/CheckPresentKey.hs view
@@ -39,7 +39,8 @@ 			(rn:[]) -> toRemote rn >>= \r -> return (flip check (Just r)) 			[] -> return (flip check Nothing) 			_ -> wrongnumparams-		batchInput fmt (pure . Right) $ checker >=> batchResult+		batchInput fmt (pure . Right) $+			checker . snd >=> batchResult   where 	wrongnumparams = giveup "Wrong number of parameters"
Command/Commit.hs view
@@ -10,6 +10,7 @@ import Command import qualified Annex.Branch import qualified Git+import Git.Types  cmd :: Command cmd = command "commit" SectionPlumbing @@ -20,10 +21,12 @@ seek = withNothing (commandAction start)  start :: CommandStart-start = starting "commit" (ActionItemOther (Just "git-annex")) $ do-		Annex.Branch.commit =<< Annex.Branch.commitMessage-		_ <- runhook <=< inRepo $ Git.hookPath "annex-content"-		next $ return True+start = starting "commit" ai si $ 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+	ai = ActionItemOther (Just (fromRef Annex.Branch.name))+	si = SeekInput []
Command/Config.hs view
@@ -55,24 +55,32 @@  seek :: Action -> CommandSeek seek (SetConfig ck@(ConfigKey name) val) = checkIsGlobalConfig ck $ commandAction $-	startingUsualMessages (decodeBS' name) (ActionItemOther (Just (fromConfigValue val))) $ do+	startingUsualMessages (decodeBS' name) ai si $ do 		setGlobalConfig ck val 		when (needLocalUpdate ck) $ 			setConfig ck (fromConfigValue val) 		next $ return True+  where+	ai = ActionItemOther (Just (fromConfigValue val))+	si = SeekInput [decodeBS' name] seek (UnsetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction $-	startingUsualMessages (decodeBS' name) (ActionItemOther (Just "unset")) $do+	startingUsualMessages (decodeBS' name) ai si $ do 		unsetGlobalConfig ck 		when (needLocalUpdate ck) $ 			unsetConfig ck 		next $ return True+  where+	ai = ActionItemOther (Just "unset")+	si = SeekInput [decodeBS' name] seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $-	startingCustomOutput (ActionItemOther Nothing) $ do+	startingCustomOutput ai $ do 		getGlobalConfig ck >>= \case 			Just (ConfigValue v) -> liftIO $ S8.putStrLn v 			Just NoConfigValue -> return () 			Nothing -> return () 		next $ return True+  where+	ai = ActionItemOther Nothing  checkIsGlobalConfig :: ConfigKey -> Annex a -> Annex a checkIsGlobalConfig ck@(ConfigKey name) a
Command/ContentLocation.hs view
@@ -20,8 +20,8 @@ 		(paramRepeating paramKey) 		(batchable run (pure ())) -run :: () -> String -> Annex Bool-run _ p = do+run :: () -> SeekInput -> String -> Annex Bool+run _ _ p = do 	let k = fromMaybe (giveup "bad key") $ deserializeKey p 	maybe (return False) (\f -> liftIO (B8.putStrLn f) >> return True) 		=<< inAnnex' (pure True) Nothing check k
Command/Copy.hs view
@@ -67,9 +67,9 @@ {- A copy is just a move that does not delete the source file.  - However, auto mode avoids unnecessary copies, and avoids getting or  - sending non-preferred content. -}-start :: CopyOptions -> RawFilePath -> Key -> CommandStart-start o file key = stopUnless shouldCopy $ -	Command.Move.start (fromToOptions o) Command.Move.RemoveNever file key+start :: CopyOptions -> SeekInput -> RawFilePath -> Key -> CommandStart+start o si file key = stopUnless shouldCopy $ +	Command.Move.start (fromToOptions o) Command.Move.RemoveNever si file key   where 	shouldCopy 		| autoMode o = want <||> numCopiesCheck (fromRawFilePath file) key (<)
Command/Dead.hs view
@@ -32,11 +32,11 @@ seek (DeadKeys ks) = commandActions $ map startKey ks  startKey :: Key -> CommandStart-startKey key = starting "dead" (mkActionItem key) $+startKey key = starting "dead" (mkActionItem key) (SeekInput []) $ 	keyLocations key >>= \case 		[] -> performKey key 		_ -> giveup "This key is still known to be present in some locations; not marking as dead."-		+ performKey :: Key -> CommandPerform performKey key = do 	setDead key
Command/Describe.hs view
@@ -23,8 +23,11 @@ start :: [String] -> CommandStart start (name:description) | not (null description) = do 	u <- Remote.nameToUUID name-	starting "describe" (ActionItemOther (Just name)) $+	starting "describe" ai si $ 		perform u $ unwords description+  where+	ai = ActionItemOther (Just name)+	si = SeekInput [name] start _ = giveup "Specify a repository and a description."	  perform :: UUID -> String -> CommandPerform
Command/Drop.hs view
@@ -76,35 +76,35 @@   where 	ww = WarnUnmatchLsFiles -start :: DropOptions -> Maybe Remote -> RawFilePath -> Key -> CommandStart-start o from file key = start' o from key afile ai+start :: DropOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart+start o from si file key = start' o from key afile ai si   where 	afile = AssociatedFile (Just file) 	ai = mkActionItem (key, afile) -start' :: DropOptions -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart-start' o from key afile ai = +start' :: DropOptions -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart+start' o from key afile ai si =  	checkDropAuto (autoMode o) from afile key $ \numcopies -> 		stopUnless want $ 			case from of-				Nothing -> startLocal afile ai numcopies key []-				Just remote -> startRemote afile ai numcopies key remote+				Nothing -> startLocal afile ai si numcopies key []+				Just remote -> startRemote afile ai si numcopies key remote   where 	want 		| autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile 		| otherwise = return True -startKeys :: DropOptions -> Maybe Remote -> (Key, ActionItem) -> CommandStart-startKeys o from (key, ai) = start' o from key (AssociatedFile Nothing) ai+startKeys :: DropOptions -> Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart+startKeys o from (si, key, ai) = start' o from key (AssociatedFile Nothing) ai si -startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart-startLocal afile ai numcopies key preverified =-	starting "drop" (OnlyActionOn key ai) $+startLocal :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart+startLocal afile ai si numcopies key preverified =+	starting "drop" (OnlyActionOn key ai) si $ 		performLocal key afile numcopies preverified -startRemote :: AssociatedFile -> ActionItem -> NumCopies -> Key -> Remote -> CommandStart-startRemote afile ai numcopies key remote = -	starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) $+startRemote :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> Key -> Remote -> CommandStart+startRemote afile ai si numcopies key remote = +	starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) si $ 		performRemote key afile numcopies remote  performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform
Command/DropKey.hs view
@@ -41,8 +41,8 @@   where 	parsekey = maybe (Left "bad key") Right . deserializeKey -start :: Key -> CommandStart-start key = starting "dropkey" (mkActionItem key) $+start :: (SeekInput, Key) -> CommandStart+start (si, key) = starting "dropkey" (mkActionItem key) si $ 	perform key  perform :: Key -> CommandPerform
Command/EnableRemote.hs view
@@ -58,31 +58,37 @@ -- the remote uuid. startNormalRemote :: Git.RemoteName -> [String] -> Git.Repo -> CommandStart startNormalRemote name restparams r-	| null restparams = starting "enableremote" (ActionItemOther (Just name)) $ do+	| null restparams = starting "enableremote" ai si $ 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+  where+	ai = ActionItemOther (Just name)+	si = SeekInput [name]  startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID)) -> CommandStart startSpecialRemote name config Nothing = do 	m <- SpecialRemote.specialRemoteMap-	confm <- Logs.Remote.readRemoteLog+	confm <- Logs.Remote.remoteConfigMap 	Remote.nameToUUID' name >>= \case 		Right u | u `M.member` m -> 			startSpecialRemote name config $ 				Just (u, fromMaybe M.empty (M.lookup u confm), Nothing) 		_ -> unknownNameError "Unknown remote name." startSpecialRemote name config (Just (u, c, mcu)) =-	starting "enableremote" (ActionItemOther (Just name)) $ do+	starting "enableremote" ai si $ do 		let fullconfig = config `M.union` c	 		t <- either giveup return (SpecialRemote.findType fullconfig) 		gc <- maybe (liftIO dummyRemoteGitConfig)  			(return . Remote.gitconfig) 			=<< Remote.byUUID u 		performSpecialRemote t u c fullconfig gc mcu+  where+	ai = ActionItemOther (Just name)+	si = SeekInput [name]  performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform performSpecialRemote t u oldc c gc mcu = do
Command/EnableTor.hs view
@@ -47,12 +47,14 @@ start _os = do #endif #ifndef mingw32_HOST_OS+	let ai = ActionItemOther Nothing+	let si = SeekInput [] 	curruserid <- liftIO getEffectiveUserID 	if curruserid == 0 		then case readish =<< headMaybe os of 			Nothing -> giveup "Need user-id parameter." 			Just userid -> go userid-		else starting "enable-tor" (ActionItemOther Nothing) $ do+		else starting "enable-tor" ai si $ do 			gitannex <- liftIO programPath 			let ps = [Param (cmdname cmd), Param (show curruserid)] 			sucommand <- liftIO $ mkSuCommand gitannex ps
Command/ExamineKey.hs view
@@ -19,8 +19,8 @@ 			(paramRepeating paramKey) 			(batchable run (optional parseFormatOption)) -run :: Maybe Utility.Format.Format -> String -> Annex Bool-run format p = do+run :: Maybe Utility.Format.Format -> SeekInput -> String -> Annex Bool+run format _ p = do 	let k = fromMaybe (giveup "bad key") $ deserializeKey p 	showFormatted format (serializeKey' k) (keyVars k) 	return True
Command/Expire.hs view
@@ -60,13 +60,13 @@ start (Expire expire) noact actlog descs u = 	case lastact of 		Just ent | notexpired ent -> checktrust (== DeadTrusted) $-			starting "unexpire" (ActionItemOther (Just desc)) $ do+			starting "unexpire" ai si $ do 				showNote =<< whenactive 				unless noact $ 					trustSet u SemiTrusted 				next $ return True 		_ -> checktrust (/= DeadTrusted) $-			starting "expire" (ActionItemOther (Just desc)) $ do+			starting "expire" ai si $ do 				showNote =<< whenactive 				unless noact $ 					trustSet u DeadTrusted@@ -79,6 +79,8 @@ 			return $ "last active: " ++ fromDuration d ++ " ago" 		_  -> return "no activity" 	desc = fromUUID u ++ " " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs))+	ai = ActionItemOther (Just desc)+	si = SeekInput [] 	notexpired ent = case ent of 		Unknown -> False 		VectorClock c -> case lookupexpire of
Command/Export.hs view
@@ -258,7 +258,7 @@ startExport r db cvar allfilledvar ti = do 	ek <- exportKey (Git.LsTree.sha ti) 	stopUnless (notrecordedpresent ek) $-		starting ("export " ++ name r) (ActionItemOther (Just (fromRawFilePath f))) $+		starting ("export " ++ name r) ai si $ 			ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc)) 				( next $ cleanupExport r db ek loc False 				, do@@ -269,6 +269,8 @@ 	loc = mkExportLocation f 	f = getTopFilePath (Git.LsTree.file ti) 	af = AssociatedFile (Just f)+	ai = ActionItemOther (Just (fromRawFilePath f))+	si = SeekInput [] 	notrecordedpresent ek = (||) 		<$> liftIO (notElem loc <$> getExportedLocation db (asKey ek)) 		-- If content was removed from the remote, the export db@@ -321,18 +323,23 @@ 	eks <- forM (filter (`notElem` nullShas) shas) exportKey 	if null eks 		then stop-		else starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $+		else starting ("unexport " ++ name r) ai si $ 			performUnexport r db eks loc   where 	loc = mkExportLocation f' 	f' = getTopFilePath f+	ai = ActionItemOther (Just (fromRawFilePath f'))+	si = SeekInput []  startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart-startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $-	performUnexport r db [ek] loc+startUnexport' r db f ek =+	starting ("unexport " ++ name r) ai si $+		performUnexport r db [ek] loc   where 	loc = mkExportLocation f' 	f' = getTopFilePath f+	ai = ActionItemOther (Just (fromRawFilePath f'))+	si = SeekInput []  -- Unlike a usual drop from a repository, this does not check that -- numcopies is satisfied before removing the content. Typically an export@@ -373,30 +380,36 @@ 	| otherwise = do 		ek <- exportKey sha 		let loc = exportTempName ek-		starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation loc)))) $ do+		let ai = ActionItemOther (Just (fromRawFilePath (fromExportLocation loc)))+		let si = SeekInput []+		starting ("unexport " ++ name r) ai si $ do 			liftIO $ removeExportedLocation db (asKey ek) oldloc 			performUnexport r db [ek] loc   where 	oldloc = mkExportLocation $ getTopFilePath oldf  startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart-startMoveToTempName r db f ek = starting ("rename " ++ name r) -	(ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc))-	(performRename r db ek loc tmploc)+startMoveToTempName r db f ek = +	starting ("rename " ++ name r) ai si $+		performRename r db ek loc tmploc   where 	loc = mkExportLocation f' 	f' = getTopFilePath f 	tmploc = exportTempName ek+	ai = ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc)+	si = SeekInput []  startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart startMoveFromTempName r db ek f = do 	let tmploc = exportTempName ek+	let ai = ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f')) 	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $-		starting ("rename " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f'))) $+		starting ("rename " ++ name r) ai si $ 			performRename r db ek tmploc loc   where 	loc = mkExportLocation f' 	f' = getTopFilePath f+	si = SeekInput []  performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform performRename r db ek src dest =
Command/Find.hs view
@@ -73,14 +73,14 @@   where 	ww = WarnUnmatchLsFiles -start :: FindOptions -> RawFilePath -> Key -> CommandStart-start o file key = startingCustomOutput key $ do+start :: FindOptions -> SeekInput -> RawFilePath -> Key -> CommandStart+start o _ file key = startingCustomOutput key $ do 	showFormatted (formatOption o) file $ ("file", fromRawFilePath file) : keyVars key 	next $ return True -startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart-startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = -	start o (getTopFilePath topf) key+startKeys :: FindOptions -> (SeekInput, Key, ActionItem) -> CommandStart+startKeys o (si, key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = +	start o si (getTopFilePath topf) key startKeys _ _ = stop  showFormatted :: Maybe Utility.Format.Format -> S.ByteString -> [(String, String)] -> Annex ()
Command/Fix.hs view
@@ -43,8 +43,8 @@  data FixWhat = FixSymlinks | FixAll -start :: FixWhat -> RawFilePath -> Key -> CommandStart-start fixwhat file key = do+start :: FixWhat -> SeekInput -> RawFilePath -> Key -> CommandStart+start fixwhat si file key = do 	currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file 	wantlink <- calcRepo $ gitAnnexLink (fromRawFilePath file) key 	case currlink of@@ -56,7 +56,7 @@ 			FixAll -> fixthin 			FixSymlinks -> stop   where-	fixby = starting "fix" (mkActionItem (key, file))+	fixby = starting "fix" (mkActionItem (key, file)) si 	fixthin = do 		obj <- calcRepo (gitAnnexLocation key) 		stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do
Command/Forget.hs view
@@ -12,6 +12,7 @@ import Logs.Transitions import qualified Annex import Annex.VectorClock+import Git.Types  cmd :: Command cmd = command "forget" SectionMaintenance @@ -33,13 +34,16 @@ seek = commandAction . start  start :: ForgetOptions -> CommandStart-start o = starting "forget" (ActionItemOther (Just "git-annex")) $ do+start o = starting "forget" ai si $ do 	c <- liftIO currentVectorClock 	let basets = addTransition c ForgetGitHistory noTransitions 	let ts = if dropDead o 		then addTransition c ForgetDeadRemotes basets 		else basets 	perform ts =<< Annex.getState Annex.force+  where+	ai = ActionItemOther (Just (fromRef Branch.name))+	si = SeekInput []  perform :: Transitions -> Bool -> CommandPerform perform ts True = do
Command/FromKey.hs view
@@ -45,27 +45,30 @@ 		withPairs (commandAction . start force) ps  seekBatch :: BatchFormat -> CommandSeek-seekBatch fmt = batchInput fmt parse commandAction+seekBatch fmt = batchInput fmt parse (commandAction . go)   where 	parse s = do 		let (keyname, file) = separate (== ' ') s 		if not (null keyname) && not (null file) 			then do 				file' <- liftIO $ relPathCwdToFile file-				return $ Right $ go file' (keyOpt keyname)+				return $ Right (file', keyOpt keyname) 			else return $ 				Left "Expected pairs of key and filename"-	go file key = starting "fromkey" (mkActionItem (key, toRawFilePath file)) $-		perform key file+	go (si, (file, key)) = +		let ai = mkActionItem (key, toRawFilePath file)+		in starting "fromkey" ai si $+			perform key file -start :: Bool -> (String, FilePath) -> CommandStart-start force (keyname, file) = do+start :: Bool -> (SeekInput, (String, FilePath)) -> CommandStart+start force (si, (keyname, file)) = do 	let key = keyOpt keyname 	unless force $ do 		inbackend <- inAnnex key 		unless inbackend $ giveup $ 			"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"-	starting "fromkey" (mkActionItem (key, toRawFilePath file)) $+	let ai = mkActionItem (key, toRawFilePath file)+	starting "fromkey" ai si $ 		perform key file  -- From user input to a Key.
Command/Fsck.hs view
@@ -111,8 +111,8 @@ 	whenM ((==) DeadTrusted <$> lookupTrust u) $ 		earlyWarning "Warning: Fscking a repository that is currently marked as dead." -start :: Maybe Remote -> Incremental -> RawFilePath -> Key -> CommandStart-start from inc file key = Backend.getBackend (fromRawFilePath file) key >>= \case+start :: Maybe Remote -> Incremental -> SeekInput -> RawFilePath -> Key -> CommandStart+start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \case 	Nothing -> stop 	Just backend -> do 		numcopies <- getFileNumCopies (fromRawFilePath file)@@ -120,7 +120,7 @@ 			Nothing -> go $ perform key file backend numcopies 			Just r -> go $ performRemote key afile backend numcopies r   where-	go = runFsck inc (mkActionItem (key, afile)) key+	go = runFsck inc si (mkActionItem (key, afile)) key 	afile = AssociatedFile (Just file)  perform :: Key -> RawFilePath -> Backend -> NumCopies -> Annex Bool@@ -197,11 +197,11 @@ 		Just a -> isRight <$> tryNonAsync (a key afile tmp) 		Nothing -> return False -startKey :: Maybe Remote -> Incremental -> (Key, ActionItem) -> NumCopies -> CommandStart-startKey from inc (key, ai) numcopies =+startKey :: Maybe Remote -> Incremental -> (SeekInput, Key, ActionItem) -> NumCopies -> CommandStart+startKey from inc (si, key, ai) numcopies = 	Backend.maybeLookupBackendVariety (fromKey keyVariety key) >>= \case 		Nothing -> stop-		Just backend -> runFsck inc ai key $+		Just backend -> runFsck inc si ai key $ 			case from of 				Nothing -> performKey key backend numcopies 				Just r -> performRemote key (AssociatedFile Nothing) backend numcopies r@@ -555,9 +555,9 @@ 		(False, Right ()) -> "dropped from " ++ Remote.name remote 		(_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e -runFsck :: Incremental -> ActionItem -> Key -> Annex Bool -> CommandStart-runFsck inc ai key a = stopUnless (needFsck inc key) $-	starting "fsck" (OnlyActionOn key ai) $ do+runFsck :: Incremental -> SeekInput -> ActionItem -> Key -> Annex Bool -> CommandStart+runFsck inc si ai key a = stopUnless (needFsck inc key) $+	starting "fsck" (OnlyActionOn key ai) si $ do 		ok <- a 		when ok $ 			recordFsckTime inc key
Command/FuzzTest.hs view
@@ -36,7 +36,7 @@ start = do 	guardTest 	logf <- fromRepo gitAnnexFuzzTestLogFile-	showStart "fuzztest" (toRawFilePath logf)+	showStart "fuzztest" (toRawFilePath logf) (SeekInput []) 	logh <- liftIO $ openFile logf WriteMode 	void $ forever $ fuzz logh 	stop
Command/GCryptSetup.hs view
@@ -22,7 +22,7 @@ seek = withStrings (commandAction . start)  start :: String -> CommandStart-start gcryptid = starting "gcryptsetup" (ActionItemOther Nothing) $ do+start gcryptid = starting "gcryptsetup" (ActionItemOther Nothing) (SeekInput [gcryptid]) $ do 	u <- getUUID 	when (u /= NoUUID) $ 		giveup "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
Command/Get.hs view
@@ -54,8 +54,8 @@   where 	ww = WarnUnmatchLsFiles -start :: GetOptions -> Maybe Remote -> RawFilePath -> Key -> CommandStart-start o from file key = start' expensivecheck from key afile ai+start :: GetOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart+start o from si file key = start' expensivecheck from key afile ai si   where 	afile = AssociatedFile (Just file) 	ai = mkActionItem (key, afile)@@ -64,12 +64,12 @@ 			<||> wantGet False (Just key) afile 		| otherwise = return True -startKeys :: Maybe Remote -> (Key, ActionItem) -> CommandStart-startKeys from (key, ai) = checkFailedTransferDirection ai Download $-	start' (return True) from key (AssociatedFile Nothing) ai+startKeys :: Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart+startKeys from (si, key, ai) = checkFailedTransferDirection ai Download $+	start' (return True) from key (AssociatedFile Nothing) ai si -start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart-start' expensivecheck from key afile ai =+start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart+start' expensivecheck from key afile ai si = 	stopUnless expensivecheck $ 		case from of 			Nothing -> go $ perform key afile@@ -77,7 +77,7 @@ 				stopUnless (Command.Move.fromOk src key) $ 					go $ Command.Move.fromPerform src Command.Move.RemoveNever key afile   where-	go = starting "get" (OnlyActionOn key ai)+	go = starting "get" (OnlyActionOn key ai) si  perform :: Key -> AssociatedFile -> CommandPerform perform key afile = stopUnless (getKey key afile) $
Command/Group.hs view
@@ -22,10 +22,13 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start (name:g:[]) = do+start ps@(name:g:[]) = do 	u <- Remote.nameToUUID name-	startingUsualMessages "group" (ActionItemOther (Just name)) $+	startingUsualMessages "group" ai si $ 		setGroup u (toGroup g)+  where+	ai = ActionItemOther (Just name)+	si = SeekInput ps start (name:[]) = do 	u <- Remote.nameToUUID name 	startingCustomOutput (ActionItemOther Nothing) $ do
Command/GroupWanted.hs view
@@ -24,6 +24,9 @@ start :: [String] -> CommandStart start (g:[]) = startingCustomOutput (ActionItemOther Nothing) $ 	performGet groupPreferredContentMapRaw (toGroup g)-start (g:expr:[]) = startingUsualMessages "groupwanted" (ActionItemOther (Just g)) $+start ps@(g:expr:[]) = startingUsualMessages "groupwanted" ai si $ 	performSet groupPreferredContentSet expr (toGroup g)+  where+	ai = ActionItemOther (Just g)+	si = SeekInput ps start _ = giveup "Specify a group."
Command/Import.hs view
@@ -49,12 +49,14 @@ 	= LocalImportOptions 		{ importFiles :: CmdParams 		, duplicateMode :: DuplicateMode+		, checkGitIgnoreOption :: CheckGitIgnore 		} 	| RemoteImportOptions 		{ importFromRemote :: DeferredParse Remote 		, importToBranch :: Branch 		, importToSubDir :: Maybe FilePath 		, importContent :: Bool+		, checkGitIgnoreOption :: CheckGitIgnore 		}  optParser :: CmdParamsDesc -> Parser ImportOptions@@ -65,8 +67,9 @@ 		( help "do not get contents of imported files" 		) 	dupmode <- fromMaybe Default <$> optional duplicateModeParser+	ic <- Command.Add.checkGitIgnoreSwitch 	return $ case mfromremote of-		Nothing -> LocalImportOptions ps dupmode+		Nothing -> LocalImportOptions ps dupmode ic 		Just r -> case ps of 			[bs] ->  				let (branch, subdir) = separate (== ':') bs@@ -74,6 +77,7 @@ 					(Ref (encodeBS' branch)) 					(if null subdir then Nothing else Just subdir) 					content+					ic 			_ -> giveup "expected BRANCH[:SUBDIR]"  data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates | ReinjectDuplicates@@ -110,7 +114,7 @@ 		giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops 	largematcher <- largeFilesMatcher 	addunlockedmatcher <- addUnlockedMatcher-	(commandAction . startLocal addunlockedmatcher largematcher (duplicateMode o))+	(commandAction . startLocal o addunlockedmatcher largematcher (duplicateMode o)) 		`withPathContents` importFiles o seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do 	r <- getParsed (importFromRemote o)@@ -120,16 +124,18 @@ 		(pure Nothing) 		(Just <$$> inRepo . toTopFilePath . toRawFilePath) 		(importToSubDir o)-	seekRemote r (importToBranch o) subdir (importContent o)+	seekRemote r (importToBranch o) subdir (importContent o) (checkGitIgnoreOption o) -startLocal :: AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart-startLocal addunlockedmatcher largematcher mode (srcfile, destfile) =+startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart+startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = 	ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile)-		( starting "import" (ActionItemWorkTreeFile destfile')-			pickaction+		( starting "import" ai si pickaction 		, stop 		)   where+ 	ai = ActionItemWorkTreeFile destfile'+	si = SeekInput []+ 	destfile' = toRawFilePath destfile  	deletedup k = do@@ -146,10 +152,10 @@ 		showNote "reinjecting" 		Command.Reinject.perform srcfile k 	importfile ld k = checkdestdir $ do-		ignored <- not <$> Annex.getState Annex.force <&&> checkIgnored destfile+		ignored <- checkIgnored (checkGitIgnoreOption o) destfile 		if ignored 			then do-				warning $ "not importing " ++ destfile ++ " which is .gitignored (use --force to override)"+				warning $ "not importing " ++ destfile ++ " which is .gitignored (use --no-check-gitignore to override)" 				stop 			else do 				existing <- liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile)@@ -208,18 +214,18 @@ 				} 			} 		ifM (checkFileMatcher largematcher destfile)-			( ingestAdd' nullMeterUpdate (Just ld') (Just k)+			( ingestAdd' (checkGitIgnoreOption o) nullMeterUpdate (Just ld') (Just k) 				>>= maybe 					stop 					(\addedk -> next $ Command.Add.cleanup addedk True)-			, next $ Command.Add.addSmall destfile'+			, next $ Command.Add.addSmall (checkGitIgnoreOption o) destfile' 			) 	notoverwriting why = do 		warning $ "not overwriting existing " ++ destfile ++ " " ++ why 		stop 	lockdown a = do 		let mi = MatchingFile $ FileInfo-			{ currFile = toRawFilePath srcfile+			{ contentFile = Just (toRawFilePath srcfile) 			, matchFile = toRawFilePath destfile 			} 		lockingfile <- not <$> addUnlocked addunlockedmatcher mi@@ -264,8 +270,8 @@ 	verifyEnoughCopiesToDrop [] key Nothing need [] preverified tocheck 		(const yes) no -seekRemote :: Remote -> Branch -> Maybe TopFilePath -> Bool -> CommandSeek-seekRemote remote branch msubdir importcontent = do+seekRemote :: Remote -> Branch -> Maybe TopFilePath -> Bool -> CheckGitIgnore -> CommandSeek+seekRemote remote branch msubdir importcontent ci = do 	importtreeconfig <- case msubdir of 		Nothing -> return ImportTree 		Just subdir ->@@ -282,7 +288,7 @@ 	let commitimport = commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig  	importabletvar <- liftIO $ newTVarIO Nothing-	void $ includeCommandAction (listContents remote importabletvar)+	void $ includeCommandAction (listContents remote importtreeconfig ci importabletvar) 	liftIO (atomically (readTVar importabletvar)) >>= \case 		Nothing -> return () 		Just importable -> importKeys remote importtreeconfig importcontent importable >>= \case@@ -301,25 +307,32 @@  	fromtrackingbranch a = inRepo $ a (fromRemoteTrackingBranch tb) -listContents :: Remote -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart-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-				Right matcher -> filterImportableContents remote matcher importable-				Left err -> giveup $ "Cannot import from " ++ Remote.name remote ++ " because of a problem with its configuration: " ++ err-			next $ do-				liftIO $ atomically $ writeTVar tvar (Just importable')+listContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart+listContents remote importtreeconfig ci tvar = starting "list" ai si $+	makeImportMatcher remote >>= \case+		Right matcher -> getImportableContents remote importtreeconfig ci matcher >>= \case+			Just importable -> next $ do+				liftIO $ atomically $ writeTVar tvar (Just importable) 				return True+			Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote+		Left err -> giveup $ unwords +			[ "Cannot import from"+			, Remote.name remote+			, "because of a problem with its configuration:"+			, err+			]+  where+	ai = ActionItemOther (Just (Remote.name remote))+	si = SeekInput []  commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents (Either Sha Key) -> CommandStart commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable =-	starting "update" (ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb)) $ do+	starting "update" ai si $ do 		importcommit <- buildImportCommit remote importtreeconfig importcommitconfig importable 		next $ updateremotetrackingbranch importcommit-		   where+	ai = ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb)+	si = SeekInput [] 	-- Update the tracking branch. Done even when there 	-- is nothing new to import, to make sure it exists. 	updateremotetrackingbranch importcommit =
Command/ImportFeed.hs view
@@ -34,7 +34,7 @@ import qualified Utility.Format import Utility.Tmp import Utility.Metered-import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..))+import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..), checkCanAdd) import Annex.UUID import Backend.URL (fromUrl) import Annex.Content@@ -78,7 +78,7 @@  getFeed :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> URLString -> CommandSeek getFeed addunlockedmatcher opts cache url = do-	showStart' "importfeed" (Just url)+	showStartOther "importfeed" (Just url) (SeekInput []) 	downloadFeed url >>= \case 		Nothing -> showEndResult =<< feedProblem url 			"downloading the feed failed"@@ -124,7 +124,7 @@ getCache opttemplate = ifM (Annex.getState Annex.force) 	( ret S.empty S.empty 	, do-		showStart "importfeed" "checking known urls"+		showStart "importfeed" "checking known urls" (SeekInput []) 		(is, us) <- unzip <$> knownItems 		showEndOk 		ret (S.fromList us) (S.fromList (concat is))@@ -198,28 +198,28 @@ 						-- don't use youtube-dl 						, rawOption = True 						}-					let go urlinfo = maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f+					let go urlinfo = Just . maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f 					if relaxedOption (downloadOptions opts) 						then go Url.assumeUrlExists 						else Url.withUrlOptions (Url.getUrlInfo url) >>= \case 							Right urlinfo -> go urlinfo 							Left err -> do 								warning err-								return []+								return (Just []) 				else do 					res <- tryNonAsync $ maybe 						(error $ "unable to checkUrl of " ++ Remote.name r) 						(flip id url) 						(Remote.checkUrl r) 					case res of-						Left _ -> return []+						Left _ -> return (Just []) 						Right (UrlContents sz _) ->-							maybeToList <$>+							Just . maybeToList <$> 								downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz 						Right (UrlMulti l) -> do 							kl <- forM l $ \(url', sz, subf) -> 								downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' (f </> sanitizeFilePath subf) sz-							return $ if all isJust kl+							return $ Just $ if all isJust kl 								then catMaybes kl 								else [] 							@@ -256,20 +256,27 @@ 		case dest of 			Nothing -> return True 			Just f -> do-				showStart' "addurl" (Just url)-				ks <- getter f-				if null ks-					then do+				showStartOther "addurl" (Just url) (SeekInput [])+				getter f >>= \case+					Just ks+						-- Download problem.+						| null ks -> do+							showEndFail+							checkFeedBroken (feedurl todownload)+						| otherwise -> do+							forM_ ks $ \key ->+								ifM (annexGenMetaData <$> Annex.getGitConfig)+									( addMetaData key $ extractMetaData todownload+									, addMetaData key $ minimalMetaData todownload+									)+							showEndOk+							return True+					-- Was not able to add anything,+					-- but not because of a download +					-- problem.+					Nothing -> do 						showEndFail-						checkFeedBroken (feedurl todownload)-					else do-						forM_ ks $ \key ->-							ifM (annexGenMetaData <$> Annex.getGitConfig)-								( addMetaData key $ extractMetaData todownload-								, addMetaData key $ minimalMetaData todownload-								)-						showEndOk-						return True+						return False  	{- Find a unique filename to save the url to. 	 - If the file exists, prefixes it with a number.@@ -300,15 +307,16 @@ 		| rawOption (downloadOptions opts) = downloadlink 		| otherwise = do 			r <- withTmpWorkDir mediakey $ \workdir -> do-				dl <- youtubeDl linkurl workdir+				dl <- youtubeDl linkurl workdir nullMeterUpdate 				case dl of 					Right (Just mediafile) -> do 						let ext = case takeExtension mediafile of 							[] -> ".m" 							s -> s-						ok <- rundownload linkurl ext $ \f -> do-							addWorkTree addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile)-							return [mediakey]+						ok <- rundownload linkurl ext $ \f ->+							checkCanAdd (downloadOptions opts) f $ \canadd -> do+								addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile)+								return (Just [mediakey]) 						return (Just ok) 					-- youtude-dl didn't support it, so 					-- download it as if the link were@@ -325,9 +333,10 @@ 	addmediafast linkurl mediaurl mediakey = 		ifM (pure (not (rawOption (downloadOptions opts))) 		     <&&> youtubeDlSupported linkurl)-			( rundownload linkurl ".m" $ \f -> do-				addWorkTree addunlockedmatcher webUUID mediaurl f mediakey Nothing-				return [mediakey]+			( rundownload linkurl ".m" $ \f ->+				checkCanAdd (downloadOptions opts) f $ \canadd -> do+					addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey Nothing+					return (Just [mediakey]) 			, performDownload addunlockedmatcher opts cache todownload 				{ location = Enclosure linkurl } 			)
Command/InAnnex.hs view
@@ -20,8 +20,8 @@ seek :: CmdParams -> CommandSeek seek = withKeys (commandAction . start) -start :: Key -> CommandStart-start key = inAnnexSafe key >>= dispatch+start :: (SeekInput, Key) -> CommandStart+start (_, key) = inAnnexSafe key >>= dispatch   where 	dispatch (Just True) = stop 	dispatch (Just False) = exit 1
Command/Info.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -125,7 +125,7 @@ 	globalInfo o 	stop start o ps = do-	mapM_ (itemInfo o) ps+	mapM_ (\p -> itemInfo o (SeekInput [p], p)) ps 	stop  globalInfo :: InfoOptions -> Annex ()@@ -135,34 +135,34 @@ 	whenM ((==) DeadTrusted <$> lookupTrust u) $ 		earlyWarning "Warning: This repository is currently marked as dead." 	stats <- selStats global_fast_stats global_slow_stats-	showCustom "info" $ do+	showCustom "info" (SeekInput []) $ do 		evalStateT (mapM_ showStat stats) (emptyStatInfo o) 		return True -itemInfo :: InfoOptions -> String -> Annex ()-itemInfo o p = ifM (isdir p)-	( dirInfo o p+itemInfo :: InfoOptions -> (SeekInput, String) -> Annex ()+itemInfo o (si, p) = ifM (isdir p)+	( dirInfo o p si 	, do 		disallowMatchingOptions 		v <- Remote.byName' p 		case v of-			Right r -> remoteInfo o r+			Right r -> remoteInfo o r si 			Left _ -> do 				v' <- Remote.nameToUUID' p 				case v' of-					Right u -> uuidInfo o u+					Right u -> uuidInfo o u si 					Left _ -> do 						relp <- liftIO $ relPathCwdToFile p 						ifAnnexed (toRawFilePath relp)-							(fileInfo o relp)-							(treeishInfo o p)+							(fileInfo o relp si)+							(treeishInfo o p si) 	)   where 	isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus) -noInfo :: String -> Annex ()-noInfo s = do-	showStart "info" (encodeBS' s)+noInfo :: String -> SeekInput -> Annex ()+noInfo s si = do+	showStart "info" (encodeBS' s) si 	showNote $ "not a directory or an annexed file or a treeish or a remote or a uuid" 	showEndFail @@ -170,8 +170,8 @@ disallowMatchingOptions = whenM Limit.limited $ 	giveup "File matching options can only be used when getting info on a directory." -dirInfo :: InfoOptions -> FilePath -> Annex ()-dirInfo o dir = showCustom (unwords ["info", dir]) $ do+dirInfo :: InfoOptions -> FilePath -> SeekInput -> Annex ()+dirInfo o dir si = showCustom (unwords ["info", dir]) si $ do 	stats <- selStats 		(tostats (dir_name:tree_fast_stats True)) 		(tostats tree_slow_stats)@@ -180,12 +180,12 @@   where 	tostats = map (\s -> s dir) -treeishInfo :: InfoOptions -> String -> Annex ()-treeishInfo o t = do+treeishInfo :: InfoOptions -> String -> SeekInput -> Annex ()+treeishInfo o t si = do 	mi <- getTreeStatInfo o (Git.Ref (encodeBS' t)) 	case mi of-		Nothing -> noInfo t-		Just i -> showCustom (unwords ["info", t]) $ do+		Nothing -> noInfo t si+		Just i -> showCustom (unwords ["info", t]) si $ do 			stats <- selStats  				(tostats (tree_name:tree_fast_stats False))  				(tostats tree_slow_stats)@@ -194,13 +194,13 @@   where 	tostats = map (\s -> s t) -fileInfo :: InfoOptions -> FilePath -> Key -> Annex ()-fileInfo o file k = showCustom (unwords ["info", file]) $ do+fileInfo :: InfoOptions -> FilePath -> SeekInput -> Key -> Annex ()+fileInfo o file si k = showCustom (unwords ["info", file]) si $ do 	evalStateT (mapM_ showStat (file_stats file k)) (emptyStatInfo o) 	return True -remoteInfo :: InfoOptions -> Remote -> Annex ()-remoteInfo o r = showCustom (unwords ["info", Remote.name r]) $ do+remoteInfo :: InfoOptions -> Remote -> SeekInput -> Annex ()+remoteInfo o r si = showCustom (unwords ["info", Remote.name r]) si $ do 	i <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r 	let u = Remote.uuid r 	l <- selStats @@ -209,8 +209,8 @@ 	evalStateT (mapM_ showStat l) (emptyStatInfo o) 	return True -uuidInfo :: InfoOptions -> UUID -> Annex ()-uuidInfo o u = showCustom (unwords ["info", fromUUID u]) $ do+uuidInfo :: InfoOptions -> UUID -> SeekInput -> Annex ()+uuidInfo o u si = showCustom (unwords ["info", fromUUID u]) si $ do 	l <- selStats (uuid_fast_stats u) (uuid_slow_stats u) 	evalStateT (mapM_ showStat l) (emptyStatInfo o) 	return True@@ -532,8 +532,9 @@ 			let combinedata d uk = finishCheck uk >>= \case 				Nothing -> return d 				Just k -> return $ addKey k d-			v <- lift $ foldM combinedata emptyKeyInfo-				=<< loggedKeysFor' u+			(ks, cleanup) <- lift $ loggedKeysFor' u+			v <- lift $ foldM combinedata emptyKeyInfo ks+			liftIO $ void cleanup 			put s { repoData = M.insert u v (repoData s) } 			return v @@ -567,7 +568,7 @@   where 	initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty) 	update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) =-		ifM (matcher $ MatchingFile $ FileInfo file file)+		ifM (matcher $ MatchingFile $ FileInfo (Just file) file) 			( do 				!presentdata' <- ifM (inAnnex key) 					( return $ addKey key presentdata
Command/Init.hs view
@@ -53,10 +53,14 @@  start :: InitOptions -> CommandStart start os-	| autoEnableOnly os = starting "init" (ActionItemOther (Just "autoenable")) $-		performAutoEnableOnly-	| otherwise = starting "init" (ActionItemOther (Just $ initDesc os)) $-		perform os+	| autoEnableOnly os = +		starting "init" (ActionItemOther (Just "autoenable")) si $+			performAutoEnableOnly+	| otherwise = +		starting "init" (ActionItemOther (Just $ initDesc os)) si $+			perform os+  where+	si = SeekInput []  perform :: InitOptions -> CommandPerform perform os = do
Command/InitRemote.hs view
@@ -62,25 +62,26 @@ start o (name:ws) = ifM (isJust <$> findExisting name) 	( giveup $ "There is already a special remote named \"" ++ name ++ 		"\". (Use enableremote to enable an existing special remote.)"-	, do-		ifM (isJust <$> Remote.byNameOnly name)-			( giveup $ "There is already a remote named \"" ++ name ++ "\""-			, do-				sameasuuid <- maybe-					(pure Nothing)-					(Just . Sameas <$$> getParsed)-					(sameas o) -				c <- newConfig name sameasuuid-					(Logs.Remote.keyValToConfig Proposed ws)-					<$> readRemoteLog-				t <- either giveup return (findType c)-				if whatElse o-					then startingCustomOutput (ActionItemOther Nothing) $-						describeOtherParamsFor c t-					else starting "initremote" (ActionItemOther (Just name)) $-						perform t name c o-			)+	, ifM (isJust <$> Remote.byNameOnly name)+		( giveup $ "There is already a remote named \"" ++ name ++ "\""+		, do+			sameasuuid <- maybe+				(pure Nothing)+				(Just . Sameas <$$> getParsed)+				(sameas o) +			c <- newConfig name sameasuuid+				(Logs.Remote.keyValToConfig Proposed ws)+				<$> remoteConfigMap+			t <- either giveup return (findType c)+			if whatElse o+				then startingCustomOutput (ActionItemOther Nothing) $+					describeOtherParamsFor c t+				else starting "initremote" (ActionItemOther (Just name)) si $+					perform t name c o+		) 	)+  where+	si = SeekInput [name]  perform :: RemoteType -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform perform t name c o = do
Command/Inprogress.hs view
@@ -48,8 +48,8 @@   where 	ww = WarnUnmatchLsFiles -start :: S.Set Key -> RawFilePath -> Key -> CommandStart-start s _file k+start :: S.Set Key -> SeekInput -> RawFilePath -> Key -> CommandStart+start s _si _file k 	| S.member k s = start' k 	| otherwise = stop
Command/List.hs view
@@ -77,8 +77,8 @@ printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex () printHeader l = liftIO $ putStrLn $ lheader $ map (\(_, n, t) -> (n, t)) l -start :: [(UUID, RemoteName, TrustLevel)] -> RawFilePath -> Key -> CommandStart-start l file key = do+start :: [(UUID, RemoteName, TrustLevel)] -> SeekInput -> RawFilePath -> Key -> CommandStart+start l _si file key = do 	ls <- S.fromList <$> keyLocations key 	liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file 	stop
Command/Lock.hs view
@@ -37,10 +37,10 @@ 		, usesLocationLog = False 		} -start :: RawFilePath -> Key -> CommandStart-start file key = ifM (isJust <$> isAnnexLink file)+start :: SeekInput -> RawFilePath -> Key -> CommandStart+start si file key = ifM (isJust <$> isAnnexLink file) 	( stop-	, starting "lock" (mkActionItem (key, file)) $+	, starting "lock" (mkActionItem (key, file)) si $ 		go =<< liftIO (isPointerFile file) 	)   where@@ -60,7 +60,7 @@ perform :: RawFilePath -> Key -> CommandPerform perform file key = do 	lockdown =<< calcRepo (gitAnnexLocation key)-	addLink (fromRawFilePath file) key+	addLink (CheckGitIgnore False) (fromRawFilePath file) key 		=<< withTSDelta (liftIO . genInodeCache file) 	next $ cleanup file key   where
Command/Log.hs view
@@ -100,8 +100,8 @@   where 	ww = WarnUnmatchLsFiles -start :: LogOptions -> (FilePath -> Outputter) -> RawFilePath -> Key -> CommandStart-start o outputter file key = do+start :: LogOptions -> (FilePath -> Outputter) -> SeekInput -> RawFilePath -> Key -> CommandStart+start o outputter _ file key = do 	(changes, cleanup) <- getKeyLog key (passthruOptions o) 	showLogIncremental (outputter (fromRawFilePath file)) changes 	void $ liftIO cleanup
Command/LookupKey.hs view
@@ -18,8 +18,8 @@ 		(paramRepeating paramFile) 		(batchable run (pure ())) -run :: () -> String -> Annex Bool-run _ file = seekSingleGitFile file >>= \case+run :: () -> SeekInput -> String -> Annex Bool+run _ _ file = seekSingleGitFile file >>= \case 	Nothing -> return False 	Just file' -> catKeyFile file' >>= \case 		Just k  -> do
Command/Map.hs view
@@ -197,7 +197,7 @@ {- reads the config of a remote, with progress display -} scan :: Git.Repo -> Annex Git.Repo scan r = do-	showStart' "map" (Just $ Git.repoDescribe r)+	showStartOther "map" (Just $ Git.repoDescribe r) (SeekInput []) 	v <- tryScan r 	case v of 		Just r' -> do
Command/MatchExpression.hs view
@@ -37,9 +37,9 @@ 		( long "largefiles" 		<> help "parse as annex.largefiles expression" 		)-	<*> (MatchingInfo . addkeysize <$> dataparser)+	<*> (MatchingUserInfo . addkeysize <$> dataparser)   where-	dataparser = ProvidedInfo+	dataparser = UserProvidedInfo 		<$> optinfo "file" (strOption 			( long "file" <> metavar paramFile 			<> help "specify filename to match against"@@ -65,9 +65,9 @@ 		<|> (pure $ Left $ missingdata datadesc) 	missingdata datadesc = bail $ "cannot match this expression without " ++ datadesc ++ " data" 	-- When a key is provided, make its size also be provided.-	addkeysize p = case providedKey p of+	addkeysize p = case userProvidedKey p of 		Right k -> case fromKey keySize k of-			Just sz -> p { providedFileSize = Right sz }+			Just sz -> p { userProvidedFileSize = Right sz } 			Nothing -> p 		Left _ -> p @@ -91,7 +91,8 @@ 			, liftIO exitFailure 			)   where-	checkmatcher matcher = matchMrun matcher $ \a -> a S.empty (matchinfo o)+	checkmatcher matcher = matchMrun matcher $ \op ->+		matchAction op S.empty (matchinfo o)  bail :: String -> IO a bail s = do
Command/Merge.hs view
@@ -13,6 +13,7 @@ import qualified Git.Branch import Annex.CurrentBranch import Command.Sync (prepMerge, mergeLocal, mergeConfig, merge, SyncOptions(..))+import Git.Types  cmd :: Command cmd = command "merge" SectionMaintenance@@ -29,17 +30,23 @@ 	forM_ bs (commandAction . mergeBranch . Git.Ref . encodeBS')  mergeAnnexBranch :: CommandStart-mergeAnnexBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do+mergeAnnexBranch = starting "merge" ai si $ do 	_ <- Annex.Branch.update 	-- commit explicitly, in case no remote branches were merged 	Annex.Branch.commit =<< Annex.Branch.commitMessage 	next $ return True+  where+	ai = ActionItemOther (Just (fromRef Annex.Branch.name))+	si = SeekInput []  mergeSyncedBranch :: CommandStart mergeSyncedBranch = mergeLocal mergeConfig def =<< getCurrentBranch  mergeBranch :: Git.Ref -> CommandStart-mergeBranch r = starting "merge" (ActionItemOther (Just (Git.fromRef r))) $ do+mergeBranch r = starting "merge" ai si $ do 	currbranch <- getCurrentBranch 	let o = def { notOnlyAnnexOption = True } 	next $ merge currbranch mergeConfig o Git.Branch.ManualCommit r+  where+	ai = ActionItemOther (Just (Git.fromRef r))+	si = SeekInput []
Command/MetaData.hs view
@@ -93,24 +93,24 @@ 	Batch fmt -> withMessageState $ \s -> case outputType s of 		JSONOutput _ -> ifM limited 			( giveup "combining --batch with file matching options is not currently supported"-			, batchInput fmt parseJSONInput $-				commandAction . startBatch+			, batchInput fmt parseJSONInput +				(commandAction . startBatch) 			) 		_ -> giveup "--batch is currently only supported in --json mode" -start :: VectorClock -> MetaDataOptions -> RawFilePath -> Key -> CommandStart-start c o file k = startKeys c o (k, mkActionItem (k, afile))+start :: VectorClock -> MetaDataOptions -> SeekInput -> RawFilePath -> Key -> CommandStart+start c o si file k = startKeys c o (si, k, mkActionItem (k, afile))   where 	afile = AssociatedFile (Just file) -startKeys :: VectorClock -> MetaDataOptions -> (Key, ActionItem) -> CommandStart-startKeys c o (k, ai) = case getSet o of+startKeys :: VectorClock -> MetaDataOptions -> (SeekInput, Key, ActionItem) -> CommandStart+startKeys c o (si, k, ai) = case getSet o of 	Get f -> startingCustomOutput k $ do 		l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k 		liftIO $ forM_ l $ 			B8.putStrLn . fromMetaValue 		next $ return True-	_ -> starting "metadata" ai $+	_ -> starting "metadata" ai si $ 		perform c o k  perform :: VectorClock -> MetaDataOptions -> Key -> CommandPerform@@ -170,8 +170,8 @@ 			(Nothing, Nothing) -> return $  				Left "JSON input is missing either file or key" -startBatch :: (Either RawFilePath Key, MetaData) -> CommandStart-startBatch (i, (MetaData m)) = case i of+startBatch :: (SeekInput, (Either RawFilePath Key, MetaData)) -> CommandStart+startBatch (si, (i, (MetaData m))) = case i of 	Left f -> do 		mk <- lookupKey f 		case mk of@@ -179,7 +179,7 @@ 			Nothing -> giveup $ "not an annexed file: " ++ fromRawFilePath f 	Right k -> go k (mkActionItem k)   where-	go k ai = starting "metadata" ai $ do+	go k ai = starting "metadata" ai si $ do 		let o = MetaDataOptions 			{ forFiles = [] 			, getSet = if MetaData m == emptyMetaData
Command/Migrate.hs view
@@ -35,8 +35,8 @@ 		, usesLocationLog = False 		} -start :: RawFilePath -> Key -> CommandStart-start file key = do+start :: SeekInput -> RawFilePath -> Key -> CommandStart+start si file key = do 	forced <- Annex.getState Annex.force 	v <- Backend.getBackend (fromRawFilePath file) key 	case v of@@ -46,7 +46,7 @@ 			newbackend <- maybe defaultBackend return  				=<< chooseBackend (fromRawFilePath file) 			if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists-				then starting "migrate" (mkActionItem (key, file)) $+				then starting "migrate" (mkActionItem (key, file)) si $ 					perform file key oldbackend newbackend 				else stop
Command/Mirror.hs view
@@ -57,19 +57,19 @@ 		, usesLocationLog = True 		} -start :: MirrorOptions -> RawFilePath -> Key -> CommandStart-start o file k = startKey o afile (k, ai)+start :: MirrorOptions -> SeekInput -> RawFilePath -> Key -> CommandStart+start o si file k = startKey o afile (si, k, ai)   where 	afile = AssociatedFile (Just file) 	ai = mkActionItem (k, afile) -startKey :: MirrorOptions -> AssociatedFile -> (Key, ActionItem) -> CommandStart-startKey o afile (key, ai) = case fromToOptions o of+startKey :: MirrorOptions -> AssociatedFile -> (SeekInput, Key, ActionItem) -> CommandStart+startKey o afile (si, 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+		( Command.Move.toStart Command.Move.RemoveNever afile key ai si =<< getParsed r 		, do 			numcopies <- getnumcopies-			Command.Drop.startRemote afile ai numcopies key =<< getParsed r+			Command.Drop.startRemote afile ai si numcopies key =<< getParsed r 		) 	FromRemote r -> checkFailedTransferDirection ai Download $ do 		haskey <- flip Remote.hasKey key =<< getParsed r@@ -77,12 +77,12 @@ 			Left _ -> stop 			Right True -> ifM (inAnnex key) 				( stop-				, Command.Get.start' (return True) Nothing key afile ai+				, Command.Get.start' (return True) Nothing key afile ai si 				) 			Right False -> ifM (inAnnex key) 				( do 					numcopies <- getnumcopies-					Command.Drop.startLocal afile ai numcopies key []+					Command.Drop.startLocal afile ai si numcopies key [] 				, stop 				)   where
Command/Move.hs view
@@ -76,42 +76,42 @@ 		Left ToHere -> downloadStages 	ww = WarnUnmatchLsFiles -start :: FromToHereOptions -> RemoveWhen -> RawFilePath -> Key -> CommandStart-start fromto removewhen f k = start' fromto removewhen afile k ai+start :: FromToHereOptions -> RemoveWhen -> SeekInput -> RawFilePath -> Key -> CommandStart+start fromto removewhen si f k = start' fromto removewhen afile si k ai   where 	afile = AssociatedFile (Just f) 	ai = mkActionItem (k, afile) -startKey :: FromToHereOptions -> RemoveWhen -> (Key, ActionItem) -> CommandStart-startKey fromto removewhen = -	uncurry $ start' fromto removewhen (AssociatedFile Nothing)+startKey :: FromToHereOptions -> RemoveWhen -> (SeekInput, Key, ActionItem) -> CommandStart+startKey fromto removewhen (si, k, ai) = +	start' fromto removewhen (AssociatedFile Nothing) si k ai -start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart-start' fromto removewhen afile key ai =+start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> SeekInput -> Key -> ActionItem -> CommandStart+start' fromto removewhen afile si key ai = 	case fromto of 		Right (FromRemote src) -> 			checkFailedTransferDirection ai Download $-				fromStart removewhen afile key ai =<< getParsed src+				fromStart removewhen afile key ai si =<< getParsed src 		Right (ToRemote dest) -> 			checkFailedTransferDirection ai Upload $-				toStart removewhen afile key ai =<< getParsed dest+				toStart removewhen afile key ai si =<< getParsed dest 		Left ToHere -> 			checkFailedTransferDirection ai Download $-				toHereStart removewhen afile key ai+				toHereStart removewhen afile key ai si  describeMoveAction :: RemoveWhen -> String describeMoveAction RemoveNever = "copy" describeMoveAction _ = "move" -toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart-toStart removewhen afile key ai dest = do+toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart+toStart removewhen afile key ai si dest = do 	u <- getUUID 	if u == Remote.uuid dest 		then stop-		else toStart' dest removewhen afile key ai+		else toStart' dest removewhen afile key ai si -toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart-toStart' dest removewhen afile key ai = do+toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart+toStart' dest removewhen afile key ai si = do 	fast <- Annex.getState Annex.fast 	if fast && removewhen == RemoveNever 		then ifM (expectedPresent dest key)@@ -121,7 +121,7 @@ 		else go False (Remote.hasKey dest key)   where 	go fastcheck isthere =-		starting (describeMoveAction removewhen) (OnlyActionOn key ai) $+		starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $ 			toPerform dest removewhen key afile fastcheck =<< isthere  expectedPresent :: Remote -> Key -> Annex Bool@@ -196,10 +196,10 @@ 	-- to be done except for cleaning up. 	lockfailed = next $ Command.Drop.cleanupLocal key -fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart-fromStart removewhen afile key ai src = +fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart+fromStart removewhen afile key ai si src =  	stopUnless (fromOk src key) $-		starting (describeMoveAction removewhen) (OnlyActionOn key ai) $+		starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $ 			fromPerform src removewhen key afile  fromOk :: Remote -> Key -> Annex Bool@@ -252,13 +252,13 @@  -  - When moving, the content is removed from all the reachable remotes that  - it can safely be removed from. -}-toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart-toHereStart removewhen afile key ai = +toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart+toHereStart removewhen afile key ai si =  	startingNoMessage (OnlyActionOn key ai) $ do 		rs <- Remote.keyPossibilities key 		forM_ rs $ \r -> 			includeCommandAction $-				starting (describeMoveAction removewhen) ai $+				starting (describeMoveAction removewhen) ai si $ 					fromPerform r removewhen key afile 		next $ return True
Command/Multicast.hs view
@@ -78,7 +78,7 @@ seek (MultiCastOptions Receive _ _) = giveup "Cannot specify list of files with --receive; this receives whatever files the sender chooses to send."  genAddress :: CommandStart-genAddress = starting "gen-address" (ActionItemOther Nothing) $ do+genAddress = starting "gen-address" (ActionItemOther Nothing) (SeekInput []) $ do 	k <- uftpKey 	(s, ok) <- case k of 		KeyContainer s -> liftIO $ genkey (Param s)@@ -127,21 +127,22 @@ 	-- In a direct mode repository, the annex objects do not have 	-- the names of keys, and would have to be copied, which is too 	-- expensive.-	starting "sending files" (ActionItemOther Nothing) $+	starting "sending files" (ActionItemOther Nothing) (SeekInput []) $ 		withTmpFile "send" $ \t h -> do 			let ww = WarnUnmatchLsFiles-			fs' <- seekHelper id ww LsFiles.inRepo+			(fs', cleanup) <- seekHelper id ww LsFiles.inRepo 				=<< workTreeItems ww fs 			matcher <- Limit.getMatcher-			let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $+			let addlist f o = whenM (matcher $ MatchingFile $ FileInfo (Just f) f) $ 				liftIO $ hPutStrLn h o-			forM_ fs' $ \f -> do+			forM_ fs' $ \(_, f) -> do 				mk <- lookupKey f 				case mk of 					Nothing -> noop 					Just k -> withObjectLoc k $ 						addlist f . fromRawFilePath 			liftIO $ hClose h+			liftIO $ void cleanup 			 			serverkey <- uftpKey 			u <- getUUID@@ -166,7 +167,7 @@ 			next $ return True  receive :: [CommandParam] -> CommandStart-receive ups = starting "receiving multicast files" (ActionItemOther Nothing) $ do+receive ups = starting "receiving multicast files" ai si $ do 	showNote "Will continue to run until stopped by ctrl-c" 	 	showOutput@@ -200,6 +201,9 @@ 		mapM_ storeReceived . lines =<< liftIO (hGetContents statush) 		showEndResult =<< liftIO (wait runner) 	next $ return True+  where+	ai = ActionItemOther Nothing+	si = SeekInput []  storeReceived :: FilePath -> Annex () storeReceived f = do
Command/NumCopies.hs view
@@ -46,6 +46,9 @@ 	return True  startSet :: Int -> CommandStart-startSet n = startingUsualMessages "numcopies" (ActionItemOther (Just $ show n)) $ do+startSet n = startingUsualMessages "numcopies" ai si $ do 	setGlobalNumCopies $ NumCopies n 	next $ return True+  where+	ai = ActionItemOther (Just $ show n)+	si = SeekInput [show n]
Command/P2P.hs view
@@ -98,9 +98,11 @@  -- Address is read from stdin, to avoid leaking it in shell history. linkRemote :: RemoteName -> CommandStart-linkRemote remotename = starting "p2p link" (ActionItemOther (Just remotename)) $+linkRemote remotename = starting "p2p link" ai si $ 	next promptaddr   where+	ai = ActionItemOther (Just remotename)+	si = SeekInput [] 	promptaddr = do 		liftIO $ putStrLn "" 		liftIO $ putStr "Enter peer address: "@@ -124,10 +126,13 @@ startPairing :: RemoteName -> [P2PAddress] -> CommandStart startPairing _ [] = giveup "No P2P networks are currrently available." startPairing remotename addrs = ifM (liftIO Wormhole.isInstalled)-	( starting "p2p pair" (ActionItemOther (Just remotename)) $+	( starting "p2p pair" ai si $ 		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/"-	) +	)+  where+	ai = ActionItemOther (Just remotename)+	si = SeekInput []  performPairing :: RemoteName -> [P2PAddress] -> CommandPerform performPairing remotename addrs = do
Command/PreCommit.hs view
@@ -35,8 +35,8 @@ 	let ww = WarnUnmatchWorkTreeItems 	l <- workTreeItems ww ps 	-- fix symlinks to files being committed-	flip withFilesToBeCommitted l $ \f -> commandAction $-		maybe stop (Command.Fix.start Command.Fix.FixSymlinks f)+	flip withFilesToBeCommitted l $ \(si, f) -> commandAction $+		maybe stop (Command.Fix.start Command.Fix.FixSymlinks si f) 			=<< isAnnexLink f 	-- after a merge conflict or git cherry-pick or stash, pointer 	-- files in the worktree won't be populated, so populate them here@@ -53,12 +53,18 @@ 			(removeViewMetaData v)  addViewMetaData :: View -> ViewedFile -> Key -> CommandStart-addViewMetaData v f k = starting "metadata" (mkActionItem (k, toRawFilePath f)) $+addViewMetaData v f k = starting "metadata" ai si $ 	next $ changeMetaData k $ fromView v f+  where+	ai = mkActionItem (k, toRawFilePath f)+	si = SeekInput []  removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart-removeViewMetaData v f k = starting "metadata" (mkActionItem (k, toRawFilePath f)) $+removeViewMetaData v f k = starting "metadata" ai si $ 	next $ changeMetaData k $ unsetMetaData $ fromView v f+  where+	ai = mkActionItem (k, toRawFilePath f)+	si = SeekInput []  changeMetaData :: Key -> MetaData -> CommandCleanup changeMetaData k metadata = do
Command/ReKey.hs view
@@ -52,21 +52,25 @@  seek :: ReKeyOptions -> CommandSeek seek o = case batchOption o of-	Batch fmt -> batchInput fmt batchParser $-		batchCommandAction . start-	NoBatch -> withPairs (commandAction . start . parsekey) (reKeyThese o)+	Batch fmt -> batchInput fmt batchParser+		(batchCommandAction . uncurry start)+	NoBatch -> withPairs +		(\(si, p) -> commandAction (start si (parsekey p))) +		(reKeyThese o)   where 	parsekey (file, skey) = 		(toRawFilePath file, fromMaybe (giveup "bad key") (deserializeKey skey)) -start :: (RawFilePath, Key) -> CommandStart-start (file, newkey) = ifAnnexed file go stop+start :: SeekInput -> (RawFilePath, Key) -> CommandStart+start si (file, newkey) = ifAnnexed file go stop   where 	go oldkey 		| oldkey == newkey = stop-		| otherwise = starting "rekey" (ActionItemWorkTreeFile file) $+		| otherwise = starting "rekey" ai si $ 			perform file oldkey newkey +	ai = ActionItemWorkTreeFile file+ perform :: RawFilePath -> Key -> Key -> CommandPerform perform file oldkey newkey = do 	ifM (inAnnex oldkey) @@ -120,7 +124,7 @@ 		( do 			-- Update symlink to use the new key. 			liftIO $ removeFile (fromRawFilePath file)-			addLink (fromRawFilePath file) newkey Nothing+			addLink (CheckGitIgnore False) (fromRawFilePath file) newkey Nothing 		, do 			mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file 			liftIO $ whenM (isJust <$> isPointerFile file) $
Command/RecvKey.hs view
@@ -24,8 +24,8 @@ seek :: CmdParams -> CommandSeek seek = withKeys (commandAction . start) -start :: Key -> CommandStart-start key = fieldTransfer Download key $ \_p -> do+start :: (SeekInput, Key) -> CommandStart+start (_, key) = fieldTransfer Download key $ \_p -> do 	-- Always verify content when a repo is sending an unlocked file, 	-- as the file could change while being transferred. 	fromunlocked <- (isJust <$> Fields.getField Fields.unlocked)
Command/RegisterUrl.hs view
@@ -40,14 +40,16 @@  start :: [String] -> CommandStart start (keyname:url:[]) = -	starting "registerurl" (ActionItemOther (Just url)) $ do-		let key = keyOpt keyname-		perform key url+	starting "registerurl" ai si $+		perform (keyOpt keyname) url+  where+	ai = ActionItemOther (Just url)+	si = SeekInput [keyname, url] start _ = giveup "specify a key and an url"  startMass :: BatchFormat -> CommandStart startMass fmt = -	starting "registerurl" (ActionItemOther (Just "stdin")) $+	starting "registerurl" (ActionItemOther (Just "stdin")) (SeekInput []) $ 		massAdd fmt  massAdd :: BatchFormat -> CommandPerform
Command/Reinit.hs view
@@ -24,7 +24,7 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start ws = starting "reinit" (ActionItemOther (Just s)) $+start ws = starting "reinit" (ActionItemOther (Just s)) (SeekInput ws) $ 	perform s   where 	s = unwords ws
Command/Reinject.hs view
@@ -41,20 +41,22 @@ 	| otherwise = withWords (commandAction . startSrcDest) (params os)  startSrcDest :: [FilePath] -> CommandStart-startSrcDest (src:dest:[])+startSrcDest ps@(src:dest:[]) 	| src == dest = stop 	| otherwise = notAnnexed src $ ifAnnexed (toRawFilePath dest) go stop   where-	go key = starting "reinject" (ActionItemOther (Just src)) $+	go key = starting "reinject" ai si $ 		ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src) 			( perform src key 			, giveup $ src ++ " does not have expected content of " ++ dest 			)+	ai = ActionItemOther (Just src)+	si = SeekInput ps startSrcDest _ = giveup "specify a src file and a dest file"  startKnown :: FilePath -> CommandStart startKnown src = notAnnexed src $-	starting "reinject" (ActionItemOther (Just src)) $ do+	starting "reinject" ai si $ do 		(key, _) <- genKey ks nullMeterUpdate Nothing 		ifM (isKnownKey key) 			( perform src key@@ -65,6 +67,8 @@   where 	ks = KeySource src' src' Nothing 	src' = toRawFilePath src+	ai = ActionItemOther (Just src)+	si = SeekInput [src]  notAnnexed :: FilePath -> CommandStart -> CommandStart notAnnexed src a =
Command/RenameRemote.hs view
@@ -27,7 +27,7 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case+start ps@(oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case 	Just (u, cfg, mcu) -> Annex.SpecialRemote.findExisting newname >>= \case 		Just _ -> giveup $ "The name " ++ newname ++ " is already used by a special remote." 		Nothing -> go u cfg mcu@@ -37,13 +37,14 @@ 	Nothing -> Remote.nameToUUID' oldname >>= \case 		Left e -> giveup e 		Right u -> do-			m <- Logs.Remote.readRemoteLog+			m <- Logs.Remote.remoteConfigMap 			case M.lookup u m of 				Nothing -> giveup "That is not a special remote." 				Just cfg -> go u cfg Nothing   where-	go u cfg mcu = starting "rename" (ActionItemOther Nothing) $-		perform u cfg mcu newname+	ai = ActionItemOther Nothing+	si = SeekInput ps+	go u cfg mcu = starting "rename" ai si $ perform u cfg mcu newname start _ = giveup "Specify an old name (or uuid or description) and a new name."  perform :: UUID -> R.RemoteConfig -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> String -> CommandPerform
Command/Repair.hs view
@@ -25,7 +25,7 @@ seek = withNothing (commandAction start)  start :: CommandStart-start = starting "repair" (ActionItemOther Nothing) $ +start = starting "repair" (ActionItemOther Nothing) (SeekInput []) $  	next $ runRepair =<< Annex.getState Annex.force  runRepair :: Bool -> Annex Bool
Command/ResolveMerge.hs view
@@ -24,7 +24,7 @@ seek = withNothing (commandAction start)  start :: CommandStart-start = starting "resolvemerge" (ActionItemOther Nothing) $ do+start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do 	us <- fromMaybe nobranch <$> inRepo Git.Branch.current 	d <- fromRawFilePath <$> fromRepo Git.localGitDir 	let merge_head = d </> "MERGE_HEAD"
Command/RmUrl.hs view
@@ -30,8 +30,7 @@  seek :: RmUrlOptions -> CommandSeek seek o = case batchOption o of-	Batch fmt -> batchInput fmt batchParser-		(batchCommandAction . start)+	Batch fmt -> batchInput fmt batchParser (batchCommandAction . start) 	NoBatch -> withPairs (commandAction . start) (rmThese o)  -- Split on the last space, since a FilePath can contain whitespace,@@ -45,9 +44,10 @@ 			f' <- liftIO $ relPathCwdToFile f 			return $ Right (f', reverse ru) -start :: (FilePath, URLString) -> CommandStart-start (file, url) = flip whenAnnexed file' $ \_ key ->-	starting "rmurl" (mkActionItem (key, AssociatedFile (Just file'))) $+start :: (SeekInput, (FilePath, URLString)) -> CommandStart+start (si, (file, url)) = flip whenAnnexed file' $ \_ key -> do+	let ai = mkActionItem (key, AssociatedFile (Just file'))+	starting "rmurl" ai si $ 		next $ cleanup url key   where 	file' = toRawFilePath file
Command/Schedule.hs view
@@ -29,9 +29,11 @@ 		u <- Remote.nameToUUID name 		startingCustomOutput (ActionItemOther Nothing) $ 			performGet u-	parse (name:expr:[]) = do+	parse ps@(name:expr:[]) = do 		u <- Remote.nameToUUID name-		startingUsualMessages "schedule" (ActionItemOther (Just name)) $+		let ai = ActionItemOther (Just name)+		let si = SeekInput ps+		startingUsualMessages "schedule" ai si $ 			performSet expr u 	parse _ = giveup "Specify a repository."
Command/SendKey.hs view
@@ -26,8 +26,8 @@ seek :: CmdParams -> CommandSeek seek = withKeys (commandAction . start) -start :: Key -> CommandStart-start key = do+start :: (SeekInput, Key) -> CommandStart+start (_, key) = do 	opts <- filterRsyncSafeOptions . maybe [] words 		<$> getField "RsyncOptions" 	ifM (inAnnex key)
Command/SetKey.hs view
@@ -20,8 +20,11 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start (keyname:file:[]) = starting "setkey" (ActionItemOther (Just file)) $+start ps@(keyname:file:[]) = starting "setkey" ai si $ 	perform file (keyOpt keyname)+  where+	ai = ActionItemOther (Just file)+	si = SeekInput ps start _ = giveup "specify a key and a content file"  keyOpt :: String -> Key
Command/SetPresentKey.hs view
@@ -32,8 +32,8 @@ seek o = case batchOption o of 	Batch fmt -> batchInput fmt 		(pure . parseKeyStatus . words)-		(batchCommandAction . start)-	NoBatch -> either giveup (commandAction . start)+		(batchCommandAction . uncurry start)+	NoBatch -> either giveup (commandAction . start (SeekInput (params o))) 		(parseKeyStatus $ params o)  data KeyStatus = KeyStatus Key UUID LogStatus@@ -46,9 +46,10 @@ 	return $ KeyStatus k u s parseKeyStatus _ = Left "Bad input. Expected: key uuid value" -start :: KeyStatus -> CommandStart-start (KeyStatus k u s) = starting "setpresentkey" (mkActionItem k) $-	perform k u s+start :: SeekInput -> KeyStatus -> CommandStart+start si (KeyStatus k u s) = starting "setpresentkey" ai si $ perform k u s+  where+	ai = mkActionItem k  perform :: Key -> UUID -> LogStatus -> CommandPerform perform k u s = next $ do
Command/Sync.hs view
@@ -57,6 +57,7 @@ import Annex.UUID import Logs.UUID import Logs.Export+import Logs.PreferredContent import Annex.AutoMerge import Annex.AdjustedBranch import Annex.Ssh@@ -65,6 +66,9 @@ import Annex.Export import Annex.TaggedPush import Annex.CurrentBranch+import Annex.Import (canImportKeys)+import Annex.CheckIgnore+import Types.FileMatcher import qualified Database.Export as Export import Utility.Bloom import Utility.OptParse@@ -223,10 +227,13 @@ 				, map (withbranch . pullRemote o mergeConfig) gitremotes 				,  [ mergeAnnex ] 				]-				-			whenM (shouldSyncContent o) $ do-				mapM_ (withbranch . importRemote o mergeConfig) importremotes 			+			content <- shouldSyncContent o++			forM_ importremotes $+				withbranch . importRemote content o mergeConfig+			+			when content $ do 				-- Send content to any exports before other 				-- repositories, in case that lets content 				-- be dropped from other repositories.@@ -308,7 +315,7 @@ 	fastest = fromMaybe [] . headMaybe . Remote.byCost  commit :: SyncOptions -> CommandStart-commit o = stopUnless shouldcommit $ starting "commit" (ActionItemOther Nothing) $ do+commit o = stopUnless shouldcommit $ starting "commit" ai si $ do 	commitmessage <- maybe commitMsg return (messageOption o) 	Annex.Branch.commit =<< Annex.Branch.commitMessage 	next $ do@@ -324,6 +331,8 @@ 		( pure (commitOption o) 		<||> (pure (not (noCommitOption o)) <&&> getGitConfigVal annexAutoCommit) 		)+	ai = ActionItemOther Nothing+	si = SeekInput []  commitMsg :: Annex String commitMsg = do@@ -350,14 +359,18 @@ mergeLocal' mergeconfig o currbranch@(Just branch, _) = 	needMerge currbranch branch >>= \case 		Nothing -> stop-		Just syncbranch ->-			starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $+		Just syncbranch -> do+			let ai = ActionItemOther (Just $ Git.Ref.describe syncbranch)+			let si = SeekInput []+			starting "merge" ai si $ 				next $ merge currbranch mergeconfig o Git.Branch.ManualCommit syncbranch mergeLocal' _ _ currbranch@(Nothing, _) = inRepo Git.Branch.currentUnsafe >>= \case 	Just branch -> needMerge currbranch branch >>= \case 		Nothing -> stop-		Just syncbranch ->-			starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $ do+		Just syncbranch -> do+			let ai = ActionItemOther (Just $ Git.Ref.describe syncbranch)+			let si = SeekInput []+			starting "merge" ai si $ do 				warning $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ Git.fromRef syncbranch ++ " into it." 				next $ return False 	Nothing -> stop@@ -421,7 +434,7 @@  pullRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandStart pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $-	starting "pull" (ActionItemOther (Just (Remote.name remote))) $ do+	starting "pull" ai si $ do 		showOutput 		ifM (onlyAnnex o) 			( do@@ -443,9 +456,11 @@ 				[Param "fetch", Param $ Remote.name remote] 					++ map Param bs 	wantpull = remoteAnnexPull (Remote.gitconfig remote)+	ai = ActionItemOther (Just (Remote.name remote))+	si = SeekInput [] -importRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandSeek-importRemote o mergeconfig remote currbranch+importRemote :: Bool -> SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandSeek+importRemote importcontent o mergeconfig remote currbranch 	| not (pullOption o) || not wantpull = noop 	| otherwise = case remoteAnnexTrackingBranch (Remote.gitconfig remote) of 		Nothing -> noop@@ -455,8 +470,11 @@ 			let subdir = if S.null p 				then Nothing 				else Just (asTopFilePath p)-			Command.Import.seekRemote remote branch subdir True-			void $ mergeRemote remote currbranch mergeconfig o+			if canImportKeys remote importcontent+				then do+					Command.Import.seekRemote remote branch subdir importcontent (CheckGitIgnore True)+					void $ mergeRemote remote currbranch mergeconfig o+				else warning $ "Cannot import from " ++ Remote.name remote ++ " when not syncing content."   where 	wantpull = remoteAnnexPull (Remote.gitconfig remote) @@ -489,7 +507,7 @@ 	onlyannex <- onlyAnnex o 	let mainbranch = if onlyannex then Nothing else Just branch 	stopUnless (pure (pushOption o) <&&> needpush mainbranch) $-		starting "push" (ActionItemOther (Just (Remote.name remote))) $ next $ do+		starting "push" ai si $ next $ do 			repo <- Remote.getRepo remote 			showOutput 			ok <- inRepoWithSshOptionsTo repo gc $@@ -500,6 +518,8 @@ 					warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ] 					return ok   where+	ai = ActionItemOther (Just (Remote.name remote))+	si = SeekInput [] 	gc = Remote.gitconfig remote 	needpush mainbranch 		| remoteAnnexReadOnly gc = return False@@ -623,9 +643,11 @@  - (Or, when in an ajusted branch where some files are hidden, at files in  - the original branch.)  -- - With --all, makes a second pass over all keys.- - This ensures that preferred content expressions that match on- - filenames work, even when in --all mode.+ - With --all, when preferred content expressions look at filenames,+ - makes a first pass over the files in the work tree so those preferred+ - content expressions will match. The second pass is over all keys,+ - and only preferred content expressions that don't look at filenames+ - will match.  -  - Returns true if any file transfers were made.  -@@ -636,7 +658,10 @@ seekSyncContent o rs currbranch = do 	mvar <- liftIO newEmptyMVar 	bloom <- case keyOptions o of-		Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar (WorkTreeItems []))+		Just WantAllKeys -> ifM preferredcontentmatchesfilenames+			( Just <$> genBloomFilter (seekworktree mvar (WorkTreeItems []))+			, pure Nothing+			) 		_ -> case currbranch of                 	(Just origbranch, Just adj) | adjustmentHidesFiles adj -> do 				l <- workTreeItems' (AllowHidden True) ww (contentOfOption o)@@ -646,6 +671,7 @@ 				l <- workTreeItems ww (contentOfOption o) 				seekworktree mvar l (const noop) 				pure Nothing+	waitForAllRunningCommandActions 	withKeyOptions' (keyOptions o) False 		(return (commandAction . gokey mvar bloom)) 		(const noop)@@ -663,26 +689,30 @@ 			seekHelper fst3 ww LsFiles.inRepoDetails l  	seekincludinghidden origbranch mvar l bloomfeeder =-		seekFiltered (\f -> ifAnnexed f (commandAction . gofile bloomfeeder mvar f) noop) $+		seekFiltered (const (pure True)) (\(si, f) -> ifAnnexed f (commandAction . gofile bloomfeeder mvar si f) noop) $ 			seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l   	ww = WarnUnmatchLsFiles -	gofile bloom mvar f k = +	gofile bloom mvar _ f k =  		go (Right bloom) mvar (AssociatedFile (Just f)) k 	-	gokey mvar bloom (k, _) =+	gokey mvar bloom (_, k, _) = 		go (Left bloom) mvar (AssociatedFile Nothing) k  	go ebloom mvar af k = do-		-- Run syncFile as a command action so file transfers run-		-- concurrently. 		let ai = OnlyActionOn k (ActionItemKey k) 		startingNoMessage ai $ do 			whenM (syncFile ebloom rs af k) $ 				void $ liftIO $ tryPutMVar mvar () 			next $ return True +	preferredcontentmatchesfilenames =+		preferredcontentmatchesfilenames' Nothing+		<||> anyM (preferredcontentmatchesfilenames' . Just . Remote.uuid) rs+	preferredcontentmatchesfilenames' =+		introspectPreferredRequiredContent matchNeedsFileName+ {- If it's preferred content, and we don't have it, get it from one of the  - listed remotes (preferring the cheaper earlier ones).  -@@ -708,11 +738,13 @@ 	u <- getUUID 	let locs' = concat [if inhere || got then [u] else [], putrs, locs] -	-- A bloom filter is populated with all the keys in the first pass.-	-- On the second pass, avoid dropping keys that were seen in the-	-- first pass, which would happen otherwise when preferred content-	-- matches on the filename, which is not available in the second-	-- pass.+	-- To handle --all, a bloom filter is populated with all the keys+	-- of files in the working tree in the first pass. On the second+	-- pass, avoid dropping keys that were seen in the first pass, which+	-- would happen otherwise when preferred content matches on the+	-- filename, which is not available in the second pass.+	-- (When the preferred content expressions do not match on+	-- filenames, the first pass is skipped for speed.) 	-- 	-- When there's a false positive in the bloom filter, the result 	-- is keeping a key that preferred content doesn't really want.@@ -725,7 +757,7 @@ 		-- includeCommandAction for drops, 		-- because a failure to drop does not mean 		-- the sync failed.-		handleDropsFrom locs' rs "unwanted" True k af []+		handleDropsFrom locs' rs "unwanted" True k af si [] 			callCommandAction 	 	return (got || not (null putrs))@@ -739,7 +771,7 @@ 		( return [ get have ] 		, return [] 		)-	get have = includeCommandAction $ starting "get" ai $+	get have = includeCommandAction $ starting "get" ai si $ 		stopUnless (getKey' k af have) $ 			next $ return True @@ -755,9 +787,10 @@ 		, return [] 		) 	put dest = includeCommandAction $ -		Command.Move.toStart' dest Command.Move.RemoveNever af k ai+		Command.Move.toStart' dest Command.Move.RemoveNever af k ai si  	ai = mkActionItem (k, af)+	si = SeekInput []  {- When a remote has an annex-tracking-branch configuration, change the export  - to contain the current content of the branch. Otherwise, transfer any files@@ -814,22 +847,21 @@  cleanupLocal :: CurrBranch -> CommandStart cleanupLocal (Nothing, _) = stop-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+cleanupLocal (Just currb, _) = starting "cleanup" ai si $ 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+	ai = ActionItemOther (Just "local")+	si = SeekInput []  cleanupRemote :: Remote -> CurrBranch -> CommandStart cleanupRemote _ (Nothing, _) = stop cleanupRemote remote (Just b, _) =-	starting "cleanup" (ActionItemOther (Just (Remote.name remote))) $+	starting "cleanup" ai si $ 		next $ inRepo $ Git.Command.runBool 			[ Param "push" 			, Param "--quiet"@@ -839,7 +871,10 @@ 			, Param $ Git.fromRef $ syncBranch $ 				Git.Ref.base $ Annex.Branch.name 			]-  +  where+	ai = ActionItemOther (Just (Remote.name remote))+	si = SeekInput []+ shouldSyncContent :: SyncOptions -> Annex Bool shouldSyncContent o 	| noContentOption o = pure False
Command/TestRemote.hs view
@@ -73,7 +73,7 @@ seek = commandAction . start   start :: TestRemoteOptions -> CommandStart-start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do+start o = starting "testremote" (ActionItemOther (Just (testRemote o))) si $ do 	fast <- Annex.getState Annex.fast 	cache <- liftIO newRemoteVariantCache 	r <- either giveup (disableExportTree cache)@@ -98,6 +98,7 @@ 	perform drs unavailr exportr ks   where 	basesz = fromInteger $ sizeOption o+	si = SeekInput [testRemote o]  perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform perform drs unavailr exportr ks = do
Command/TransferKey.hs view
@@ -44,8 +44,8 @@ seek :: TransferKeyOptions -> CommandSeek seek o = withKeys (commandAction . start o) (keyOptions o) -start :: TransferKeyOptions -> Key -> CommandStart-start o key = startingCustomOutput key $ case fromToOptions o of+start :: TransferKeyOptions -> (SeekInput, Key) -> CommandStart+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
Command/Trust.hs view
@@ -28,7 +28,8 @@ 	start ws = do 		let name = unwords ws 		u <- Remote.nameToUUID name-		starting c (ActionItemOther (Just name)) (perform u)+		let si = SeekInput ws+		starting c (ActionItemOther (Just name)) si (perform u) 	perform uuid = do 		trustSet uuid level 		when (level == DeadTrusted) $
Command/Unannex.hs view
@@ -33,9 +33,9 @@ 	, usesLocationLog = False 	} -start :: RawFilePath -> Key -> CommandStart-start file key = -	starting "unannex" (mkActionItem (key, file)) $+start :: SeekInput -> RawFilePath -> Key -> CommandStart+start si file key = +	starting "unannex" (mkActionItem (key, file)) si $ 		perform file key  perform :: RawFilePath -> Key -> CommandPerform
Command/Undo.hs view
@@ -41,8 +41,11 @@ 	withStrings (commandAction . start) ps  start :: FilePath -> CommandStart-start p = starting "undo" (ActionItemOther (Just p)) $+start p = starting "undo" ai si $ 	perform p+  where+	ai = ActionItemOther (Just p)+	si = SeekInput [p]  perform :: FilePath -> CommandPerform perform p = do
Command/Ungroup.hs view
@@ -24,7 +24,7 @@ start :: [String] -> CommandStart start (name:g:[]) = do 	u <- Remote.nameToUUID name-	starting "ungroup" (ActionItemOther (Just name)) $+	starting "ungroup" (ActionItemOther (Just name)) (SeekInput [name, g]) $ 		perform u (toGroup g) start _ = giveup "Specify a repository and a group."
Command/Uninit.hs view
@@ -16,6 +16,7 @@ import qualified Database.Keys import Annex.Content import Annex.Init+import Annex.CheckIgnore import Utility.FileMode import qualified Utility.RawFilePath as R @@ -42,7 +43,11 @@ seek :: CmdParams -> CommandSeek seek ps = do 	l <- workTreeItems ww ps-	withFilesNotInGit (commandAction . whenAnnexed (startCheckIncomplete . fromRawFilePath)) l+	withFilesNotInGit+		(CheckGitIgnore False)+		WarnUnmatchWorkTreeItems +		(\(_, f) -> commandAction $ whenAnnexed (startCheckIncomplete . fromRawFilePath) f)+		l 	Annex.changeState $ \s -> s { Annex.fast = True } 	withFilesInGitAnnex ww Command.Unannex.seeker l 	finish
Command/Unlock.hs view
@@ -36,12 +36,13 @@ 		, usesLocationLog = False 		} -start :: RawFilePath -> Key -> CommandStart-start file key = ifM (isJust <$> isAnnexLink file)-	( starting "unlock" (mkActionItem (key, AssociatedFile (Just file))) $-		perform file key+start :: SeekInput -> RawFilePath -> Key -> CommandStart+start si file key = ifM (isJust <$> isAnnexLink file)+	( starting "unlock" ai si $ perform file key 	, stop 	)+  where+	ai = mkActionItem (key, AssociatedFile (Just file))  perform :: RawFilePath -> Key -> CommandPerform perform dest key = do
Command/Unused.hs view
@@ -73,7 +73,7 @@ 		Just "." -> (".", checkUnused refspec) 		Just "here" -> (".", checkUnused refspec) 		Just n -> (n, checkRemoteUnused n refspec)-	starting "unused" (ActionItemOther (Just name)) perform+	starting "unused" (ActionItemOther (Just name)) (SeekInput []) perform  checkUnused :: RefSpec -> CommandPerform checkUnused refspec = chain 0@@ -337,4 +337,5 @@ 			Nothing -> search rest 			Just key -> starting message 				(ActionItemOther $ Just $ show n)+				(SeekInput []) 				(a key)
Command/Upgrade.hs view
@@ -39,10 +39,10 @@  start :: UpgradeOptions -> CommandStart start (UpgradeOptions { autoOnly = True }) = do-	starting "upgrade" (ActionItemOther Nothing) $ do+	starting "upgrade" (ActionItemOther Nothing) (SeekInput []) $ do 	getVersion >>= maybe noop checkUpgrade 	next $ return True-start _ = starting "upgrade" (ActionItemOther Nothing) $ do+start _ = starting "upgrade" (ActionItemOther Nothing) (SeekInput []) $ do 	whenM (isNothing <$> getVersion) $ do 		initialize Nothing Nothing 	r <- upgrade False latestVersion
Command/VAdd.hs view
@@ -22,7 +22,7 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start params = starting "vadd" (ActionItemOther Nothing) $ +start params = starting "vadd" (ActionItemOther Nothing) (SeekInput params) $  	withCurrentView $ \view -> do 		let (view', change) = refineView view $ 			map parseViewParam $ reverse params
Command/VCycle.hs view
@@ -26,7 +26,7 @@ start = go =<< currentView   where 	go Nothing = giveup "Not in a view."-	go (Just v) = starting "vcycle" (ActionItemOther Nothing) $ do+	go (Just v) = starting "vcycle" (ActionItemOther Nothing) (SeekInput [])$ do 		let v' = v { viewComponents = vcycle [] (viewComponents v) } 		if v == v' 			then do
Command/VFilter.hs view
@@ -20,7 +20,7 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start params = starting "vfilter" (ActionItemOther Nothing) $+start params = starting "vfilter" (ActionItemOther Nothing) (SeekInput params) $ 	withCurrentView $ \view -> do 		let view' = filterView view $ 			map parseViewParam $ reverse params
Command/VPop.hs view
@@ -27,7 +27,7 @@ start ps = go =<< currentView   where 	go Nothing = giveup "Not in a view."-	go (Just v) = starting "vpop" (ActionItemOther (Just $ show num)) $ do+	go (Just v) = starting "vpop" ai si $ do 		removeView v 		(oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v) 			<$> recentViews@@ -46,3 +46,7 @@ 	sameparentbranch a b = viewParentBranch a == viewParentBranch b  	num = fromMaybe 1 $ readish =<< headMaybe ps +	+	ai = ActionItemOther (Just $ show num)+	+	si = SeekInput ps
Command/View.hs view
@@ -36,7 +36,9 @@ 	, giveup "Not safe to enter view." 	)   where-	go view Nothing = starting "view" (ActionItemOther Nothing) $+	ai = ActionItemOther Nothing+	si = SeekInput ps+	go view Nothing = starting "view" ai si $ 		perform view 	go view (Just v) 		| v == view = stop
Command/Wanted.hs view
@@ -36,9 +36,11 @@ 		u <- Remote.nameToUUID rname 		startingCustomOutput (ActionItemOther Nothing) $ 			performGet getter u-	start (rname:expr:[]) = do+	start ps@(rname:expr:[]) = do 		u <- Remote.nameToUUID rname-		startingUsualMessages name (ActionItemOther (Just rname)) $+		let si = SeekInput ps+		let ai = ActionItemOther (Just rname)+		startingUsualMessages name ai si $ 			performSet setter expr u 	start _ = giveup "Specify a repository."
Command/Whereis.hs view
@@ -66,16 +66,16 @@   where 	ww = WarnUnmatchLsFiles -start :: WhereisOptions -> M.Map UUID Remote -> RawFilePath -> Key -> CommandStart-start o remotemap file key = -	startKeys o remotemap (key, mkActionItem (key, afile))+start :: WhereisOptions -> M.Map UUID Remote -> SeekInput -> RawFilePath -> Key -> CommandStart+start o remotemap si file key = +	startKeys o remotemap (si, key, mkActionItem (key, afile))   where 	afile = AssociatedFile (Just file) -startKeys :: WhereisOptions -> M.Map UUID Remote -> (Key, ActionItem) -> CommandStart-startKeys o remotemap (key, ai)+startKeys :: WhereisOptions -> M.Map UUID Remote -> (SeekInput, Key, ActionItem) -> CommandStart+startKeys o remotemap (si, key, ai) 	| isJust (formatOption o) = startingCustomOutput ai go-	| otherwise = starting "whereis" ai go+	| otherwise = starting "whereis" ai si go   where 	go = perform o remotemap key ai
Config/GitConfig.hs view
@@ -20,13 +20,13 @@  - Note: Be sure to add the config to mergeGitConfig and to  - globalConfigs.  -}-getGitConfigVal :: (GitConfig -> Configurable a) -> Annex a+getGitConfigVal :: (GitConfig -> GlobalConfigurable a) -> Annex a getGitConfigVal f = getGitConfigVal' f >>= \case 	HasGlobalConfig c -> return c 	DefaultConfig d -> return d 	HasGitConfig c -> return c -getGitConfigVal' :: (GitConfig -> Configurable a) -> Annex (Configurable a)+getGitConfigVal' :: (GitConfig -> GlobalConfigurable a) -> Annex (GlobalConfigurable a) getGitConfigVal' f = (f <$> Annex.getGitConfig) >>= \case 	DefaultConfig _ -> do 		r <- Annex.gitRepo
Database/Benchmark.hs view
@@ -22,7 +22,6 @@ import Utility.DataUnits  import Criterion.Main-import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Char8 as B8 import System.Random import Control.Concurrent@@ -92,7 +91,7 @@ 	}  fileN :: Integer -> TopFilePath-fileN n = asTopFilePath ("file" ++ show n)+fileN n = asTopFilePath (toRawFilePath ("file" ++ show n))  keyMiss :: Key keyMiss = keyN 0 -- 0 is never stored
Git/Command.hs view
@@ -55,7 +55,7 @@  -  - Also returns an action that should be used when the output is all  - read, that will wait on the command, and- - return True if it succeeded. Failure to wait will result in zombies.+ - return True if it succeeded.  -} pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool) pipeReadLazy params repo = assertLocal repo $ do@@ -133,16 +133,6 @@ pipeNullSplitStrict params repo = do 	s <- pipeReadStrict params repo 	return $ filter (not . S.null) $ S.split 0 s--pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString]-pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo--pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString]-pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo--{- Doesn't run the cleanup action. A zombie results. -}-leaveZombie :: (a, IO Bool) -> a-leaveZombie = fst  {- Runs a git command as a coprocess. -} gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle
Limit.hs view
@@ -1,6 +1,6 @@ {- user-specified limits on files to act on  -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -51,9 +51,12 @@ {- Gets a matcher for the user-specified limits. The matcher is cached for  - speed; once it's obtained the user-specified limits can't change. -} getMatcher :: Annex (MatchInfo -> Annex Bool)-getMatcher = Utility.Matcher.matchM <$> getMatcher'+getMatcher = run <$> getMatcher'+  where+	run matcher i = Utility.Matcher.matchMrun matcher $ \o ->+		matchAction o S.empty i -getMatcher' :: Annex (Utility.Matcher.Matcher (MatchInfo -> Annex Bool))+getMatcher' :: Annex (Utility.Matcher.Matcher (MatchFiles Annex)) getMatcher' = go =<< Annex.getState Annex.limit   where 	go (CompleteMatcher matcher) = return matcher@@ -63,11 +66,16 @@ 			s { Annex.limit = CompleteMatcher matcher } 		return matcher +{- Checks if the user-specified limits contains anything that meets the+ - condition. -}+introspect :: (MatchFiles Annex -> Bool) -> Annex Bool+introspect c = Utility.Matcher.introspect c <$> getMatcher'+ {- Adds something to the limit list, which is built up reversed. -}-add :: Utility.Matcher.Token (MatchInfo -> Annex Bool) -> Annex ()+add :: Utility.Matcher.Token (MatchFiles Annex) -> Annex () add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s }   where-	prepend (BuildingMatcher ls) = BuildingMatcher $ l:ls+	prepend (BuildingMatcher ls) = BuildingMatcher (l:ls) 	prepend _ = error "internal"  {- Adds a new syntax token. -}@@ -76,41 +84,60 @@  {- Adds a new limit. -} addLimit :: Either String (MatchFiles Annex) -> Annex ()-addLimit = either giveup (\l -> add $ Utility.Matcher.Operation $ l S.empty)+addLimit = either giveup (add . Utility.Matcher.Operation)  {- Add a limit to skip files that do not match the glob. -} addInclude :: String -> Annex () addInclude = addLimit . limitInclude  limitInclude :: MkLimit Annex-limitInclude glob = Right $ const $ matchGlobFile glob+limitInclude glob = Right $ MatchFiles+	{ matchAction = const $ matchGlobFile glob+	, matchNeedsFileName = True+	, matchNeedsFileContent = False+	, matchNeedsKey = False+	, matchNeedsLocationLog = False+	}  {- Add a limit to skip files that match the glob. -} addExclude :: String -> Annex () addExclude = addLimit . limitExclude  limitExclude :: MkLimit Annex-limitExclude glob = Right $ const $ not <$$> matchGlobFile glob+limitExclude glob = Right $ MatchFiles+	{ matchAction = const $ not <$$> matchGlobFile glob+	, matchNeedsFileName = True+	, matchNeedsFileContent = False+	, matchNeedsKey = False+	, matchNeedsLocationLog = False+	}  matchGlobFile :: String -> MatchInfo -> Annex Bool matchGlobFile glob = go   where 	cglob = compileGlob glob CaseSensative -- memoized 	go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi))-	go (MatchingInfo p) = matchGlob cglob <$> getInfo (providedFilePath p)+	go (MatchingInfo p) = pure $ matchGlob cglob (fromRawFilePath (providedFilePath p))+	go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (userProvidedFilePath p) 	go (MatchingKey _ (AssociatedFile Nothing)) = pure False 	go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob (fromRawFilePath af)  addMimeType :: String -> Annex ()-addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType+addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType userProvidedMimeType  addMimeEncoding :: String -> Annex ()-addMimeEncoding = addMagicLimit "mimeencoding" getMagicMimeEncoding providedMimeEncoding+addMimeEncoding = addMagicLimit "mimeencoding" getMagicMimeEncoding providedMimeEncoding userProvidedMimeEncoding -addMagicLimit :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> String -> Annex ()-addMagicLimit limitname querymagic selectprovidedinfo glob = do+addMagicLimit+	:: String+	-> (Magic -> FilePath -> Annex (Maybe String))+	-> (ProvidedInfo -> Maybe String)+	-> (UserProvidedInfo -> UserInfo String)+	-> String+	-> Annex ()+addMagicLimit limitname querymagic selectprovidedinfo selectuserprovidedinfo glob = do 	magic <- liftIO initMagicMime-	addLimit $ matchMagic limitname querymagic' selectprovidedinfo magic glob+	addLimit $ matchMagic limitname querymagic' selectprovidedinfo selectuserprovidedinfo magic glob   where 	querymagic' magic f = liftIO (isPointerFile (toRawFilePath f)) >>= \case 		-- Avoid getting magic of a pointer file, which would@@ -123,34 +150,66 @@ 				querymagic magic . fromRawFilePath 			Nothing -> querymagic magic f -matchMagic :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex-matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob = Right $ const go+matchMagic+	:: String+	-> (Magic -> FilePath -> Annex (Maybe String))+	-> (ProvidedInfo -> Maybe String)+	-> (UserProvidedInfo -> UserInfo String)+	-> Maybe Magic+	-> MkLimit Annex+matchMagic _limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just magic) glob = +	Right $ MatchFiles+		{ matchAction = const go+		, matchNeedsFileName = True+		, matchNeedsFileContent = True+		, matchNeedsKey = False+		, matchNeedsLocationLog = False+		}   where  	cglob = compileGlob glob CaseSensative -- memoized 	go (MatchingKey _ _) = pure False-	go (MatchingFile fi) = catchBoolIO $-		maybe False (matchGlob cglob)-			<$> querymagic magic (fromRawFilePath (currFile fi))-	go (MatchingInfo p) =-		matchGlob cglob <$> getInfo (selectprovidedinfo p)-matchMagic limitname _ _ Nothing _ = +	go (MatchingFile fi) = case contentFile fi of+		Just f -> catchBoolIO $+			maybe False (matchGlob cglob)+				<$> querymagic magic (fromRawFilePath f)+		Nothing -> return False+	go (MatchingInfo p) = pure $+		maybe False (matchGlob cglob) (selectprovidedinfo p)+	go (MatchingUserInfo p) =+		matchGlob cglob <$> getUserInfo (selectuserprovidedinfo p)+matchMagic limitname _ _ _ Nothing _ =  	Left $ "unable to load magic database; \""++limitname++"\" cannot be used"  addUnlocked :: Annex ()-addUnlocked = addLimit $ Right $ const $ matchLockStatus False+addUnlocked = addLimit $ Right $ MatchFiles+	{ matchAction = const $ matchLockStatus False+	, matchNeedsFileName = True+	, matchNeedsFileContent = False+	, matchNeedsKey = False+	, matchNeedsLocationLog = False+	}  addLocked :: Annex ()-addLocked = addLimit $ Right $ const $ matchLockStatus True+addLocked = addLimit $ Right $ MatchFiles+	{ matchAction = const $ matchLockStatus True+	, matchNeedsFileName = True+	, matchNeedsFileContent = False+	, matchNeedsKey = False+	, matchNeedsLocationLog = False+	}  matchLockStatus :: Bool -> MatchInfo -> Annex Bool matchLockStatus _ (MatchingKey _ _) = pure False matchLockStatus _ (MatchingInfo _) = pure False-matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do-	islocked <- isPointerFile (currFile fi) >>= \case-		Just _key -> return False-		Nothing -> isSymbolicLink-			<$> getSymbolicLinkStatus (fromRawFilePath (currFile fi))-	return (islocked == wantlocked)+matchLockStatus _ (MatchingUserInfo _) = pure False+matchLockStatus wantlocked (MatchingFile fi) = case contentFile fi of+	Just f -> liftIO $ do+		islocked <- isPointerFile f >>= \case+			Just _key -> return False+			Nothing -> isSymbolicLink+				<$> getSymbolicLinkStatus (fromRawFilePath f)+		return (islocked == wantlocked)+	Nothing -> return False  {- Adds a limit to skip files not believed to be present  - in a specfied repository. Optionally on a prior date. -}@@ -159,19 +218,25 @@ 	u <- Remote.nameToUUID name 	hereu <- getUUID 	addLimit $ if u == hereu && null date-		then use inhere-		else use (inuuid u)+		then use True checkinhere+		else use False (checkinuuid u)   where 	(name, date) = separate (== '@') s-	use a = Right $ checkKey . a-	inuuid u notpresent key+	use inhere a = Right $ MatchFiles+		{ matchAction = checkKey . a+		, matchNeedsFileName = False+		, matchNeedsFileContent = False+		, matchNeedsKey = True+		, matchNeedsLocationLog = not inhere+		}+	checkinuuid u notpresent key 		| null date = do 			us <- Remote.keyLocations key 			return $ u `elem` us && u `S.notMember` notpresent 		| otherwise = do 			us <- loggedLocationsHistorical (RefDate date) key 			return $ u `elem` us-	inhere notpresent key+	checkinhere notpresent key 		| S.null notpresent = inAnnex key 		| otherwise = do 			u <- getUUID@@ -181,22 +246,35 @@  {- Limit to content that is currently present on a uuid. -} limitPresent :: Maybe UUID -> MatchFiles Annex-limitPresent u _ = checkKey $ \key -> do-	hereu <- getUUID-	if u == Just hereu || isNothing u-		then inAnnex key-		else do-			us <- Remote.keyLocations key-			return $ maybe False (`elem` us) u+limitPresent u = MatchFiles+	{ matchAction = const $ checkKey $ \key -> do+		hereu <- getUUID+		if u == Just hereu || isNothing u+			then inAnnex key+			else do+				us <- Remote.keyLocations key+				return $ maybe False (`elem` us) u+	, matchNeedsFileName = False+	, matchNeedsFileContent = False+	, matchNeedsKey = True+	, matchNeedsLocationLog = not (isNothing u)+	}  {- Limit to content that is in a directory, anywhere in the repository tree -} limitInDir :: FilePath -> MatchFiles Annex-limitInDir dir = const go+limitInDir dir = MatchFiles +	{ matchAction = const go+	, matchNeedsFileName = True+	, matchNeedsFileContent = False+	, matchNeedsKey = False+	, matchNeedsLocationLog = False+	}   where 	go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi 	go (MatchingKey _ (AssociatedFile Nothing)) = return False-	go (MatchingKey _ (AssociatedFile (Just af))) = checkf (fromRawFilePath af)-	go (MatchingInfo p) = checkf =<< getInfo (providedFilePath p)+	go (MatchingKey _ (AssociatedFile (Just af))) = checkf $ fromRawFilePath af+	go (MatchingInfo p) = checkf $ fromRawFilePath $ providedFilePath p+	go (MatchingUserInfo p) = checkf =<< getUserInfo (userProvidedFilePath p) 	checkf = return . elem dir . splitPath . takeDirectory  {- Adds a limit to skip files not believed to have the specified number@@ -216,8 +294,14 @@   where 	go num good = case readish num of 		Nothing -> Left "bad number for copies"-		Just n -> Right $ \notpresent -> checkKey $-			go' n good notpresent+		Just n -> Right $ MatchFiles+			{ matchAction = \notpresent -> checkKey $+				go' n good notpresent+			, matchNeedsFileName = False+			, matchNeedsFileContent = False+			, matchNeedsKey = True+			, matchNeedsLocationLog = True+			} 	go' n good notpresent key = do 		us <- filter (`S.notMember` notpresent) 			<$> (filterM good =<< Remote.keyLocations key)@@ -234,8 +318,14 @@  limitLackingCopies :: Bool -> MkLimit Annex limitLackingCopies approx want = case readish want of-	Just needed -> Right $ \notpresent mi -> flip checkKey mi $-		go mi needed notpresent+	Just needed -> Right $ MatchFiles+		{ matchAction = \notpresent mi -> flip checkKey mi $+			go mi needed notpresent+		, matchNeedsFileName = False+		, matchNeedsFileContent = False+		, matchNeedsKey = True+		, matchNeedsLocationLog = True+		} 	Nothing -> Left "bad value for number of lacking copies"   where 	go mi needed notpresent key = do@@ -246,6 +336,7 @@ 					fromRawFilePath $ matchFile fi 				MatchingKey _ _ -> approxNumCopies 				MatchingInfo {} -> approxNumCopies+				MatchingUserInfo {} -> approxNumCopies 		us <- filter (`S.notMember` notpresent) 			<$> (trustExclude UnTrusted =<< Remote.keyLocations key) 		return $ numcopies - length us >= needed@@ -257,19 +348,42 @@  - its key is obviously not unused.  -} limitUnused :: MatchFiles Annex-limitUnused _ (MatchingFile _) = return False-limitUnused _ (MatchingKey k _) = S.member k <$> unusedKeys-limitUnused _ (MatchingInfo p) = do-	k <- getInfo (providedKey p)-	S.member k <$> unusedKeys+limitUnused = MatchFiles+	{ matchAction = go+	, matchNeedsFileName = True+	, matchNeedsFileContent = False+	, matchNeedsKey = True+	, matchNeedsLocationLog = False+	}+  where+ 	go _ (MatchingFile _) = return False+	go _ (MatchingKey k _) = isunused k+	go _ (MatchingInfo p) = maybe (pure False) isunused (providedKey p)+	go _ (MatchingUserInfo p) = do+		k <- getUserInfo (userProvidedKey p)+		isunused k+	+	isunused k = S.member k <$> unusedKeys  {- Limit that matches any version of any file or key. -} limitAnything :: MatchFiles Annex-limitAnything _ _ = return True+limitAnything = MatchFiles+	{ matchAction = \_ _ -> return True+	, matchNeedsFileName = False+	, matchNeedsFileContent = False+	, matchNeedsKey = False+	, matchNeedsLocationLog = False+	}  {- Limit that never matches. -} limitNothing :: MatchFiles Annex-limitNothing _ _ = return False+limitNothing = MatchFiles +	{ matchAction = \_ _ -> return False+	, matchNeedsFileName = False+	, matchNeedsFileContent = False+	, matchNeedsKey = False+	, matchNeedsLocationLog = False+	}  {- Adds a limit to skip files not believed to be present in all  - repositories in the specified group. -}@@ -277,15 +391,21 @@ addInAllGroup groupname = addLimit $ limitInAllGroup groupMap groupname  limitInAllGroup :: Annex GroupMap -> MkLimit Annex-limitInAllGroup getgroupmap groupname = Right $ \notpresent mi -> do-	m <- getgroupmap-	let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m-	if S.null want-		then return True-		-- optimisation: Check if a wanted uuid is notpresent.-		else if not (S.null (S.intersection want notpresent))-			then return False-			else checkKey (check want) mi+limitInAllGroup getgroupmap groupname = Right $ MatchFiles+	{ matchAction = \notpresent mi -> do+		m <- getgroupmap+		let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m+		if S.null want+			then return True+			-- optimisation: Check if a wanted uuid is notpresent.+			else if not (S.null (S.intersection want notpresent))+				then return False+				else checkKey (check want) mi+	, matchNeedsFileName = False+	, matchNeedsFileContent = False+	, matchNeedsKey = True+	, matchNeedsLocationLog = True+	}   where 	check want key = do 		present <- S.fromList <$> Remote.keyLocations key@@ -296,7 +416,13 @@ addInBackend = addLimit . limitInBackend  limitInBackend :: MkLimit Annex-limitInBackend name = Right $ const $ checkKey check+limitInBackend name = Right $ MatchFiles+	{ matchAction = const $ checkKey check+	, matchNeedsFileName = False+	, matchNeedsFileContent = False+	, matchNeedsKey = True+	, matchNeedsLocationLog = False+	}   where 	check key = pure $ fromKey keyVariety key == variety 	variety = parseKeyVariety (encodeBS name)@@ -306,7 +432,13 @@ addSecureHash = addLimit $ Right limitSecureHash  limitSecureHash :: MatchFiles Annex-limitSecureHash _ = checkKey isCryptographicallySecure+limitSecureHash = MatchFiles+	{ matchAction = const $ checkKey isCryptographicallySecure+	, matchNeedsFileName = False+	, matchNeedsFileContent = False+	, matchNeedsKey = True+	, matchNeedsLocationLog = False+	}  {- Adds a limit to skip files that are too large or too small -} addLargerThan :: String -> Annex ()@@ -318,20 +450,33 @@ limitSize :: LimitBy -> (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit Annex limitSize lb vs s = case readSize dataUnits s of 	Nothing -> Left "bad size"-	Just sz -> Right $ go sz+	Just sz -> Right $ MatchFiles+		{ matchAction = go sz+		, matchNeedsFileName = case lb of+			LimitAnnexFiles -> False+			LimitDiskFiles -> True+		, matchNeedsFileContent = False+		, matchNeedsKey = False+		, matchNeedsLocationLog = False+		}   where 	go sz _ (MatchingFile fi) = case lb of-		LimitAnnexFiles -> lookupFileKey fi >>= \case-			Just key -> checkkey sz key-			Nothing -> return False-		LimitDiskFiles -> do-			filesize <- liftIO $ catchMaybeIO $-				getFileSize (fromRawFilePath (currFile fi))-			return $ filesize `vs` Just sz+		LimitAnnexFiles -> goannexed sz fi+		LimitDiskFiles -> case contentFile fi of+			Just f -> do+				filesize <- liftIO $ catchMaybeIO $+					getFileSize (fromRawFilePath f)+				return $ filesize `vs` Just sz+			Nothing -> goannexed sz fi 	go sz _ (MatchingKey key _) = checkkey sz key-	go sz _ (MatchingInfo p) =-		getInfo (providedFileSize p) +	go sz _ (MatchingInfo p) = return $+		Just (providedFileSize p) `vs` Just sz+	go sz _ (MatchingUserInfo p) =+		getUserInfo (userProvidedFileSize p)  			>>= \sz' -> return (Just sz' `vs` Just sz)+	goannexed sz fi = lookupFileKey fi >>= \case+		Just key -> checkkey sz key+		Nothing -> return False 	checkkey sz key = return $ fromKey keySize key `vs` Just sz  addMetaData :: String -> Annex ()@@ -340,7 +485,13 @@ limitMetaData :: MkLimit Annex limitMetaData s = case parseMetaDataMatcher s of 	Left e -> Left e-	Right (f, matching) -> Right $ const $ checkKey (check f matching)+	Right (f, matching) -> Right $ MatchFiles+		{ matchAction = const $ checkKey (check f matching)+		, matchNeedsFileName = False+		, matchNeedsFileContent = False+		, matchNeedsKey = True+		, matchNeedsLocationLog = False+		}   where 	check f matching k = not . S.null  		. S.filter matching@@ -350,19 +501,31 @@ addTimeLimit duration = do 	start <- liftIO getPOSIXTime 	let cutoff = start + durationToPOSIXTime duration-	addLimit $ Right $ const $ const $ do-		now <- liftIO getPOSIXTime-		if now > cutoff-			then do-				warning $ "Time limit (" ++ fromDuration duration ++ ") reached!"-				shutdown True-				liftIO $ exitWith $ ExitFailure 101-			else return True+	addLimit $ Right $ MatchFiles+		{ matchAction = const $ const $ do+			now <- liftIO getPOSIXTime+			if now > cutoff+				then do+					warning $ "Time limit (" ++ fromDuration duration ++ ") reached!"+					shutdown True+					liftIO $ exitWith $ ExitFailure 101+				else return True+		, matchNeedsFileName = False+		, matchNeedsFileContent = False+		, matchNeedsKey = False+		, matchNeedsLocationLog = False+		}  addAccessedWithin :: Duration -> Annex () addAccessedWithin duration = do 	now <- liftIO getPOSIXTime-	addLimit $ Right $ const $ checkKey $ check now+	addLimit $ Right $ MatchFiles+		{ matchAction = const $ checkKey $ check now+		, matchNeedsFileName = False+		, matchNeedsFileContent = False+		, matchNeedsKey = False+		, matchNeedsLocationLog = False+		}   where 	check now k = inAnnexCheck k $ \f -> 		liftIO $ catchDefaultIO False $ do@@ -373,10 +536,12 @@ 	secs = fromIntegral (durationSeconds duration)  lookupFileKey :: FileInfo -> Annex (Maybe Key)-lookupFileKey = lookupKey . currFile+lookupFileKey fi = case contentFile fi of+	Just f -> lookupKey f+	Nothing -> return Nothing  checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a checkKey a (MatchingKey k _) = a k-checkKey a (MatchingInfo p) = a =<< getInfo (providedKey p)-+checkKey a (MatchingInfo p) = maybe (return False) a (providedKey p)+checkKey a (MatchingUserInfo p) = a =<< getUserInfo (userProvidedKey p)
Limit/Wanted.hs view
@@ -1,6 +1,6 @@ {- git-annex limits by wanted status  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -11,16 +11,32 @@ import Annex.Wanted import Limit import Types.FileMatcher+import Logs.PreferredContent  addWantGet :: Annex ()-addWantGet = addLimit $ Right $ const $ checkWant $-	wantGet False Nothing+addWantGet = addPreferredContentLimit $+	checkWant $ wantGet False Nothing  addWantDrop :: Annex ()-addWantDrop = addLimit $ Right $ const $ checkWant $-	wantDrop False Nothing Nothing+addWantDrop = addPreferredContentLimit $+	checkWant $ wantDrop False Nothing Nothing +addPreferredContentLimit :: (MatchInfo -> Annex Bool) -> Annex ()+addPreferredContentLimit a = do+	nfn <- introspectPreferredRequiredContent matchNeedsFileName Nothing+	nfc <- introspectPreferredRequiredContent matchNeedsFileContent Nothing+	nk <- introspectPreferredRequiredContent matchNeedsKey Nothing+	nl <- introspectPreferredRequiredContent matchNeedsLocationLog Nothing+	addLimit $ Right $ MatchFiles+		{ matchAction = const a+		, matchNeedsFileName = nfn+		, matchNeedsFileContent = nfc+		, matchNeedsKey = nk+		, matchNeedsLocationLog = nl+		}+ checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ matchFile fi)) checkWant a (MatchingKey _ af) = a af-checkWant _ (MatchingInfo {}) = return False+checkWant a (MatchingInfo p) = a (AssociatedFile (Just $ providedFilePath p))+checkWant _ (MatchingUserInfo {}) = return False
Logs/Location.hs view
@@ -126,14 +126,15 @@  -  - Keys that have been marked as dead are not included.  -}-loggedKeys :: Annex [Unchecked Key]+loggedKeys :: Annex ([Unchecked Key], IO Bool) loggedKeys = loggedKeys' (not <$$> checkDead) -loggedKeys' :: (Key -> Annex Bool) -> Annex [Unchecked Key]+loggedKeys' :: (Key -> Annex Bool) -> Annex ([Unchecked Key], IO Bool) loggedKeys' check = do 	config <- Annex.getGitConfig-	mapMaybe (defercheck <$$> locationLogFileKey config)-		<$> Annex.Branch.files+	(bfs, cleanup) <- Annex.Branch.files+	let l = mapMaybe (defercheck <$$> locationLogFileKey config) bfs+	return (l, cleanup)   where 	defercheck k = Unchecked $ ifM (check k) 		( return (Just k)@@ -146,9 +147,13 @@  - This does not stream well; use loggedKeysFor' for lazy streaming.  -} loggedKeysFor :: UUID -> Annex [Key]-loggedKeysFor u = catMaybes <$> (mapM finishCheck =<< loggedKeysFor' u)+loggedKeysFor u = do+	(l, cleanup) <- loggedKeysFor' u+	l' <- catMaybes <$> mapM finishCheck l+	liftIO $ void cleanup+	return l' -loggedKeysFor' :: UUID -> Annex [Unchecked Key]+loggedKeysFor' :: UUID -> Annex ([Unchecked Key], IO Bool) loggedKeysFor' u = loggedKeys' isthere   where 	isthere k = do
Logs/PreferredContent.hs view
@@ -1,6 +1,6 @@ {- git-annex preferred content matcher configuration  -- - Copyright 2012-2019 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -21,6 +21,7 @@ 	defaultStandardGroup, 	preferredRequiredMapsLoad, 	preferredRequiredMapsLoad',+	introspectPreferredRequiredContent, 	prop_standardGroups_parse, ) where @@ -61,6 +62,16 @@ 		Nothing -> return d 		Just matcher -> checkMatcher matcher mkey afile notpresent (return d) (return d) +{- Checks if the preferred or required content for the specified repository+ - (or the current repository if none is specified) contains any terms+ - that meet the condition. -}+introspectPreferredRequiredContent :: (MatchFiles Annex -> Bool) -> Maybe UUID -> Annex Bool+introspectPreferredRequiredContent c mu = do+	u <- maybe getUUID return mu+	check u preferredContentMap <||> check u requiredContentMap+  where+	check u mk = mk >>= return . maybe False (any c) . M.lookup u+ preferredContentMap :: Annex (FileMatcherMap Annex) preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad preferredContentTokens) return 	=<< Annex.getState Annex.preferredcontentmap@@ -86,7 +97,7 @@ preferredRequiredMapsLoad' :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (M.Map UUID (Either String (FileMatcher Annex)), M.Map UUID (Either String (FileMatcher Annex))) preferredRequiredMapsLoad' mktokens = do 	groupmap <- groupMap-	configmap <- readRemoteLog+	configmap <- remoteConfigMap 	let genmap l gm =  		let mk u = makeMatcher groupmap configmap gm u mktokens 		in simpleMap
Logs/Remote.hs view
@@ -1,12 +1,13 @@ {- git-annex remote log  - - - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -   - Licensed under the GNU AGPL version 3 or higher.  -}  module Logs.Remote ( 	remoteLog,+	remoteConfigMap, 	readRemoteLog, 	configSet, 	keyValToConfig,@@ -18,6 +19,7 @@ ) where  import Annex.Common+import qualified Annex import qualified Annex.Branch import Types.Remote import Logs@@ -35,8 +37,20 @@ 		buildRemoteConfigLog 			. changeLog c u (removeSameasInherited cfg) 			. parseRemoteConfigLog+	Annex.changeState $ \s -> s { Annex.remoteconfigmap = Nothing } -{- Map of remotes by uuid containing key/value config maps. -}+{- Map of remotes by uuid containing key/value config maps.+ - Cached for speed. -}+remoteConfigMap :: Annex (M.Map UUID RemoteConfig)+remoteConfigMap = maybe remoteConfigMapLoad return+	=<< Annex.getState Annex.remoteconfigmap++remoteConfigMapLoad :: Annex (M.Map UUID RemoteConfig)+remoteConfigMapLoad = do+	m <- readRemoteLog+	Annex.changeState $ \s -> s { Annex.remoteconfigmap = Just m }+	return m+ readRemoteLog :: Annex (M.Map UUID RemoteConfig) readRemoteLog = calcRemoteConfigMap  	<$> Annex.Branch.get remoteLog
Messages.hs view
@@ -9,7 +9,7 @@  module Messages ( 	showStart,-	showStart',+	showStartOther, 	showStartMessage, 	showEndMessage, 	StartMessage(..),@@ -45,6 +45,7 @@ 	disableDebugOutput, 	debugEnabled, 	commandProgressDisabled,+	jsonOutputEnabled, 	outputMessage, 	withMessageState, 	prompt,@@ -64,45 +65,46 @@ import Types.Messages import Types.ActionItem import Types.Concurrency-import Types.Command (StartMessage(..))+import Types.Command (StartMessage(..), SeekInput) import Types.Transfer (transferKey) import Messages.Internal import Messages.Concurrent+import Annex.Concurrent.Utility import qualified Messages.JSON as JSON import qualified Annex -showStart :: String -> RawFilePath -> Annex ()-showStart command file = outputMessage json $+showStart :: String -> RawFilePath -> SeekInput -> Annex ()+showStart command file si = outputMessage json $ 	encodeBS' command <> " " <> file <> " "   where-	json = JSON.start command (Just file) Nothing+	json = JSON.start command (Just file) Nothing si -showStart' :: String -> Maybe String -> Annex ()-showStart' command mdesc = outputMessage json $ encodeBS' $-	command ++ (maybe "" (" " ++) mdesc) ++ " "+showStartKey :: String -> Key -> ActionItem -> SeekInput -> Annex ()+showStartKey command key ai si = outputMessage json $+	encodeBS' command <> " " <> actionItemDesc ai <> " "   where-	json = JSON.start command Nothing Nothing+	json = JSON.start command (actionItemWorkTreeFile ai) (Just key) si -showStartKey :: String -> Key -> ActionItem -> Annex ()-showStartKey command key i = outputMessage json $-	encodeBS' command <> " " <> actionItemDesc i <> " "+showStartOther :: String -> Maybe String -> SeekInput -> Annex ()+showStartOther command mdesc si = outputMessage json $ encodeBS' $+	command ++ (maybe "" (" " ++) mdesc) ++ " "   where-	json = JSON.start command (actionItemWorkTreeFile i) (Just key)+	json = JSON.start command Nothing Nothing si  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+showStartMessage (StartMessage command ai si) = case ai of+	ActionItemAssociatedFile _ k -> showStartKey command k ai si+	ActionItemKey k -> showStartKey command k ai si+	ActionItemBranchFilePath _ k -> showStartKey command k ai si+	ActionItemFailedTransfer t _ -> showStartKey command (transferKey t) ai si+	ActionItemWorkTreeFile file -> showStart command file si+	ActionItemOther msg -> showStartOther command msg si+	OnlyActionOn _ ai' -> showStartMessage (StartMessage command ai' si)+showStartMessage (StartUsualMessages command ai si) = do 	outputType <$> Annex.getState Annex.output >>= \case 		QuietOutput -> Annex.setOutput NormalOutput 		_ -> noop-	showStartMessage (StartMessage command ai)+	showStartMessage (StartMessage command ai si) showStartMessage (StartNoMessage _) = noop showStartMessage (CustomOutput _) = 	outputType <$> Annex.getState Annex.output >>= \case@@ -111,8 +113,8 @@  -- Only show end result if the StartMessage is one that gets displayed. showEndMessage :: StartMessage -> Bool -> Annex ()-showEndMessage (StartMessage _ _) = showEndResult-showEndMessage (StartUsualMessages _ _) = showEndResult+showEndMessage (StartMessage _ _ _) = showEndResult+showEndMessage (StartUsualMessages _ _ _) = showEndResult showEndMessage (StartNoMessage _) = const noop showEndMessage (CustomOutput _) = const noop @@ -238,9 +240,9 @@  - a complete JSON document.  - This is only needed when showStart and showEndOk is not used.  -}-showCustom :: String -> Annex Bool -> Annex ()-showCustom command a = do-	outputMessage (JSON.start command Nothing Nothing) ""+showCustom :: String -> SeekInput -> Annex Bool -> Annex ()+showCustom command si a = do+	outputMessage (JSON.start command Nothing Nothing si) "" 	r <- a 	outputMessage (JSON.end r) "" @@ -287,6 +289,12 @@ 		JSONOutput _ -> True 		NormalOutput -> concurrentOutputEnabled s +jsonOutputEnabled :: Annex Bool+jsonOutputEnabled = withMessageState $ \s -> return $+	case outputType s of+		JSONOutput _ -> True+		_ -> False+ {- Prevents any concurrent console access while running an action, so  - that the action is the only thing using the console, and can eg prompt  - the user.@@ -298,7 +306,7 @@  {- Like prompt, but for a non-annex action that prompts. -} mkPrompter :: (MonadMask m, MonadIO m) => Annex (m a -> m a)-mkPrompter = Annex.getState Annex.concurrency >>= \case+mkPrompter = getConcurrency >>= \case 	NonConcurrent -> return id 	(Concurrent _) -> goconcurrent 	ConcurrentPerCpu -> goconcurrent
Messages/JSON.hs view
@@ -1,6 +1,6 @@ {- git-annex command-line JSON output and input  -- - Copyright 2011-2018 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -39,6 +39,7 @@ import Prelude  import Types.Messages+import Types.Command (SeekInput(..)) import Key import Utility.Metered import Utility.Percentage@@ -64,8 +65,8 @@ none :: JSONBuilder none = id -start :: String -> Maybe RawFilePath -> Maybe Key -> JSONBuilder-start command file key _ = case j of+start :: String -> Maybe RawFilePath -> Maybe Key -> SeekInput -> JSONBuilder+start command file key si _ = case j of 	Object o -> Just (o, False) 	_ -> Nothing   where@@ -74,6 +75,7 @@ 		, itemKey = key 		, itemFile = fromRawFilePath <$> file 		, itemAdded = Nothing+		, itemSeekInput = si 		}  end :: Bool -> JSONBuilder@@ -176,6 +178,7 @@ 	, itemKey :: Maybe Key 	, itemFile :: Maybe FilePath 	, itemAdded :: Maybe a -- for additional fields added by `add`+	, itemSeekInput :: SeekInput 	} 	deriving (Show) @@ -183,10 +186,11 @@ 	toJSON' i = object $ catMaybes 		[ Just $ "command" .= itemCommand i 		, case itemKey i of-			Nothing -> Nothing 			Just k -> Just $ "key" .= toJSON' k+			Nothing -> Nothing 		, Just $ "file" .= toJSON' (itemFile i) 		-- itemAdded is not included; must be added later by 'add'+		, Just $ "input" .= fromSeekInput (itemSeekInput i) 		]  instance FromJSON a => FromJSON (JSONActionItem a) where@@ -195,6 +199,7 @@ 		<*> (maybe (return Nothing) parseJSON =<< (v .:? "key")) 		<*> (v .:? "file") 		<*> parseadded+		<*> pure (SeekInput []) 	  where 		parseadded = (Just <$> parseJSON (Object v)) <|> return Nothing 	parseJSON _ = mempty
NEWS view
@@ -1,4 +1,4 @@-git-annex (8.20200523) UNRELEASED; urgency=medium+git-annex (8.20200523) upstream; urgency=medium    Transition notice: Commands like `git-annex get foo*` silently skip over   files that are not checked into git. Since that can be surprising in many
Remote.hs view
@@ -1,6 +1,6 @@ {- git-annex remotes  -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -73,6 +73,7 @@ import Logs.UUID import Logs.Trust import Logs.Location hiding (logStatus)+import Logs.Remote import Logs.Web import Remote.List import Remote.List.Util@@ -337,31 +338,53 @@  	return (sortBy (comparing cost) validremotes, validtrustedlocations) -{- Displays known locations of a key. -}+{- Displays known locations of a key and helps the user take action+ - to make them accessible. -} showLocations :: Bool -> Key -> [UUID] -> String -> Annex () showLocations separateuntrusted key exclude nolocmsg = do 	u <- getUUID+	remotes <- remoteList 	uuids <- keyLocations key 	untrusteduuids <- if separateuntrusted 		then trustGet UnTrusted 		else pure []-	let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids) +	let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids) 	let uuidsskipped = filteruuids uuids (u:exclude++uuidswanted)-	ppuuidswanted <- prettyPrintUUIDs "wanted" uuidswanted-	ppuuidsskipped <- prettyPrintUUIDs "skipped" uuidsskipped-	let msg = message ppuuidswanted ppuuidsskipped-	unless (null msg) $-		showLongNote msg-	ignored <- remoteList-		>>= filterM (liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig)+	let remoteuuids = map uuid remotes+	let isremoteuuid x = elem x remoteuuids+	let (remotesmakeavailable, uuidsothers) = +		partition isremoteuuid uuidswanted+	isspecialremote <- flip M.member <$> remoteConfigMap+	let (enablespecialremotes, addgitremotes) = +		partition isspecialremote uuidsothers+	+	-- Add "wanted" field to the JSON. While it's since been split+	-- up more, this avoids breaking any JSON parsers that expect it.+	ifM jsonOutputEnabled+		( void $ prettyPrintUUIDs "wanted" uuidswanted+		, do+			ppremotesmakeavailable <- pp "remotes" remotesmakeavailable+				"Try making some of these remotes available"+			ppenablespecialremotes <- pp "enableremote" enablespecialremotes+				"Maybe enable some of these special remotes (git annex initremote ...)"+			ppaddgitremotes <- pp "repos" addgitremotes+				"Maybe add some of these git remotes (git remote add ...)"+			ppuuidsskipped <- pp "skipped" uuidsskipped+				"Also these untrusted repositories may contain the file"+			showLongNote $ case ppremotesmakeavailable ++ ppenablespecialremotes ++ ppaddgitremotes ++ ppuuidsskipped of+				[] -> nolocmsg+				s -> s+		)+	ignored <- filterM (liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig) remotes 	unless (null ignored) $ 		showLongNote $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")"   where 	filteruuids l x = filter (`notElem` x) l-	message [] [] = nolocmsg-	message rs [] = "Try making some of these repositories available:\n" ++ rs-	message [] us = "Also these untrusted repositories may contain the file:\n" ++ us-	message rs us = message rs [] ++ message [] us++	pp jh l h = addheader h <$> prettyPrintUUIDs jh l++	addheader _ [] = []+	addheader h l = h ++ ":\n" ++ l  showTriedRemotes :: [Remote] -> Annex () showTriedRemotes [] = noop
Remote/BitTorrent.hs view
@@ -307,16 +307,16 @@ ariaProgress Nothing _ ps = runAria ps ariaProgress (Just sz) meter ps = do 	oh <- mkOutputHandler-	liftIO . commandMeter (parseAriaProgress sz) oh meter "aria2c"+	liftIO . commandMeter (parseAriaProgress sz) oh Nothing meter "aria2c" 		=<< ariaParams ps  parseAriaProgress :: Integer -> ProgressParser parseAriaProgress totalsize = go [] . reverse . splitc '\r'   where-	go remainder [] = (Nothing, remainder)+	go remainder [] = (Nothing, Nothing, remainder) 	go remainder (x:xs) = case readish (findpercent x) of 		Nothing -> go (x++remainder) xs-		Just p -> (Just (frompercent p), remainder)+		Just p -> (Just (frompercent p), Nothing, remainder)  	-- "(N%)" 	findpercent = takeWhile (/= '%') . drop 1 . dropWhile (/= '(')
Remote/GCrypt.hs view
@@ -109,7 +109,7 @@ 	-- correctly. 	resetup gcryptid r = do 		let u' = genUUIDInNameSpace gCryptNameSpace gcryptid-		v <- M.lookup u' <$> readRemoteLog+		v <- M.lookup u' <$> remoteConfigMap 		case (Git.remoteName baser, v) of 			(Just remotename, Just rc') -> do 				pc <- parsedRemoteConfig remote rc'
Remote/GitLFS.hs view
@@ -187,9 +187,9 @@ configKnownUrl :: Git.Repo -> Annex (Maybe Git.Repo) configKnownUrl r 	| Git.repoIsUrl r = do-		l <- readRemoteLog+		m <- remoteConfigMap 		g <- Annex.gitRepo-		case Annex.SpecialRemote.Config.findByRemoteConfig (match g) l of+		case Annex.SpecialRemote.Config.findByRemoteConfig (match g) m of 			((u, _, mcu):[]) -> Just <$> go u mcu 			_ -> return Nothing 	| otherwise = return Nothing
Remote/HttpAlso.hs view
@@ -105,7 +105,9 @@ 	_url <- maybe (giveup "Specify url=") 		(return . fromProposedAccepted) 		(M.lookup urlField c)-	(c', _encsetup) <- encryptionSetup c gc+	c' <- if isJust (M.lookup encryptionField c)+		then fst <$> encryptionSetup c gc+		else pure c 	gitConfigSpecialRemote u c' [("httpalso", "true")] 	return (c', u)
Remote/List.hs view
@@ -72,7 +72,7 @@  remoteList' :: Bool -> Annex [Remote] remoteList' autoinit = do-	m <- readRemoteLog+	m <- remoteConfigMap 	rs <- concat <$> mapM (process m) remoteTypes 	Annex.changeState $ \s -> s { Annex.remotes = rs } 	return rs@@ -96,7 +96,7 @@ {- Updates a local git Remote, re-reading its git config. -} updateRemote :: Remote -> Annex (Maybe Remote) updateRemote remote = do-	m <- readRemoteLog+	m <- remoteConfigMap 	remote' <- updaterepo =<< getRepo remote 	remoteGen m (remotetype remote) remote'   where
Remote/S3.hs view
@@ -36,6 +36,7 @@ import System.Log.Logger import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar+import Data.Maybe  import Annex.Common import Types.Remote@@ -63,6 +64,7 @@ import Utility.DataUnits import Annex.Content import qualified Annex.Url as Url+import Utility.Url (extractFromResourceT) import Annex.Url (getUrlOptions, withUrlOptions, UrlOptions(..)) import Utility.Env @@ -343,12 +345,11 @@ 		let req = (putObject info object rbody) 			{ S3.poContentType = encodeBS <$> contenttype } 		resp <- sendS3Handle h req-		let vid = mkS3VersionID object (S3.porVersionId resp)-		-- FIXME Actual aws version that supports this is not known,-		-- patch not merged yet.-		-- https://github.com/aristidb/aws/issues/258-#if MIN_VERSION_aws(0,99,0)-		return (Just (S3.porETag resp), vid)+		vid <- mkS3VersionID object+			<$> extractFromResourceT (S3.porVersionId resp)+#if MIN_VERSION_aws(0,22,0)+		etag <- extractFromResourceT (Just (S3.porETag resp))+		return (etag, vid) #else 		return (Nothing, vid) #endif@@ -389,7 +390,9 @@  		resp <- sendS3Handle h $ S3.postCompleteMultipartUpload 			(bucket info) object uploadid (zip [1..] etags)-		return (Just (S3.cmurETag resp), mkS3VersionID object (S3.cmurVersionId resp))+		etag <- extractFromResourceT (Just (S3.cmurETag resp))+		vid <- extractFromResourceT (S3.cmurVersionId resp)+		return (etag, mkS3VersionID object vid) 	getcontenttype = maybe (pure Nothing) (flip getMagicMimeType f) magic  {- Implemented as a fileRetriever, that uses conduit to stream the chunks@@ -474,7 +477,7 @@ checkKeyHelper' :: S3Info -> S3Handle -> S3.Object -> (S3.HeadObject -> S3.HeadObject) -> Annex Bool checkKeyHelper' info h o limit = liftIO $ runResourceT $ do 	rsp <- sendS3Handle h req-	return (isJust $ S3.horMetadata rsp)+	extractFromResourceT (isJust $ S3.horMetadata rsp)   where 	req = limit $ S3.headObject (bucket info) o @@ -552,7 +555,8 @@ 		Nothing -> do 			warning $ needS3Creds (uuid r) 			return Nothing-		Just h -> catchMaybeIO $ liftIO $ runResourceT $ startlist h+		Just h -> catchMaybeIO $ liftIO $ runResourceT $+			extractFromResourceT =<< startlist h   where 	startlist h 		| versioning info = do@@ -678,10 +682,7 @@ storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierS3 hv r rs info magic src k loc _overwritablecids p 	| versioning info = go-	-- FIXME Actual aws version that supports getting Etag for a store-	-- is not known; patch not merged yet.-	-- https://github.com/aristidb/aws/issues/258-#if MIN_VERSION_aws(0,99,0)+#if MIN_VERSION_aws(0,22,0) 	| otherwise = go #else 	| otherwise = giveup "git-annex is built with too old a version of the aws library to support this operation"@@ -733,11 +734,12 @@   where 	go _ _ (Right True) = noop 	go info h _ = do-		v <- liftIO $ tryNonAsync $ runResourceT $-			sendS3Handle h (S3.getBucket $ bucket info)-		case v of-			Right _ -> noop-			Left _ -> do+		r <- liftIO $ tryNonAsync $ runResourceT $ do+			void $ sendS3Handle h (S3.getBucket $ bucket info)+			return True+		case r of+			Right True -> noop+			_ -> do 				showAction $ "creating bucket in " ++ datacenter 				void $ liftIO $ runResourceT $ sendS3Handle h $  					(S3.putBucket (bucket info))@@ -787,8 +789,7 @@ 		Left _ -> return False 		Right r -> do 			v <- AWS.loadToMemory r-			let !ok = check v-			return ok+			extractFromResourceT (check v)   where 	check (S3.GetObjectMemoryResponse _meta rsp) = 		responseStatus rsp == ok200 && responseBody rsp == uuidb
Remote/Web.hs view
@@ -90,9 +90,7 @@ 		r <- untilTrue urls $ \u -> do 			let (u', downloader) = getDownloader u 			case downloader of-				YoutubeDownloader -> do-					showOutput-					youtubeDlTo key u' dest+				YoutubeDownloader -> youtubeDlTo key u' dest p 				_ -> Url.withUrlOptions $ downloadUrl key p [u'] dest 		unless r $ 			giveup "download failed"
Test/Framework.hs view
@@ -245,15 +245,13 @@  finalCleanup :: IO () finalCleanup = whenM (doesDirectoryExist tmpdir) $ do-	Annex.Action.reapZombies 	Command.Uninit.prepareRemoveAnnexDir' tmpdir 	catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do 		print e 		putStrLn "sleeping 10 seconds and will retry directory cleanup" 		Utility.ThreadScheduler.threadDelaySeconds $ 			Utility.ThreadScheduler.Seconds 10-		whenM (doesDirectoryExist tmpdir) $ do-			Annex.Action.reapZombies+		whenM (doesDirectoryExist tmpdir) $ 			removeDirectoryForCleanup tmpdir  checklink :: FilePath -> Assertion
Types/Command.hs view
@@ -38,13 +38,18 @@  -    returns the overall success/fail of the command. -} type CommandCleanup = Annex Bool +{- Input that was seeked on to make an ActionItem. Eg, the input filename,+ - or directory name. -}+newtype SeekInput = SeekInput { fromSeekInput :: [String] }+	deriving (Show)+ {- 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+	= StartMessage String ActionItem SeekInput+	| StartUsualMessages String ActionItem SeekInput 	-- ^ Like StartMessage, but makes sure to enable usual message 	-- display in case it was disabled by cmdnomessages. 	| StartNoMessage ActionItem@@ -56,8 +61,8 @@ 	deriving (Show)  instance MkActionItem StartMessage where-	mkActionItem (StartMessage _ ai) = ai-	mkActionItem (StartUsualMessages _ ai) = ai+	mkActionItem (StartMessage _ ai _) = ai+	mkActionItem (StartUsualMessages _ ai _) = ai 	mkActionItem (StartNoMessage ai) = ai 	mkActionItem (CustomOutput ai) = ai
Types/Concurrency.hs view
@@ -17,3 +17,8 @@ parseConcurrency "cpus" = Just ConcurrentPerCpu parseConcurrency "cpu" = Just ConcurrentPerCpu parseConcurrency s = Concurrent <$> readish s++-- Concurrency can be configured at the command line or by git config.+data ConcurrencySetting+	= ConcurrencyCmdLine Concurrency+	| ConcurrencyGitConfig Concurrency
Types/Export.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE DeriveGeneric #-}+ module Types.Export ( 	ExportLocation, 	mkExportLocation,@@ -20,12 +22,16 @@ import Utility.FileSystemEncoding  import qualified System.FilePath.Posix as Posix+import GHC.Generics+import Control.DeepSeq  -- A location on a remote that a key can be exported to. -- The RawFilePath will be relative to the top of the remote, -- and uses unix-style path separators. newtype ExportLocation = ExportLocation RawFilePath-	deriving (Show, Eq)+	deriving (Show, Eq, Generic)++instance NFData ExportLocation  mkExportLocation :: RawFilePath -> ExportLocation mkExportLocation = ExportLocation . toInternalGitPath
Types/FileMatcher.hs view
@@ -1,6 +1,6 @@ {- git-annex file matcher types  -- - Copyright 2013-2019 Joey Hess <id@joeyh.name>+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -23,31 +23,42 @@ 	= MatchingFile FileInfo 	| MatchingKey Key AssociatedFile 	| MatchingInfo ProvidedInfo+	| MatchingUserInfo UserProvidedInfo  data FileInfo = FileInfo-	{ currFile :: RawFilePath-	-- ^ current path to the file, for operations that examine it+	{ contentFile :: Maybe RawFilePath+	-- ^ path to a file containing the content, for operations+	-- that examine it 	, matchFile :: RawFilePath 	-- ^ filepath to match on; may be relative to top of repo or cwd 	} --- This is used when testing a matcher, with values to match against--- provided in some way, rather than queried from files on disk. data ProvidedInfo = ProvidedInfo-	{ providedFilePath :: OptInfo FilePath-	, providedKey :: OptInfo Key-	, providedFileSize :: OptInfo FileSize-	, providedMimeType :: OptInfo MimeType-	, providedMimeEncoding :: OptInfo MimeEncoding+	{ providedFilePath :: RawFilePath+	, providedKey :: Maybe Key+	, providedFileSize :: FileSize+	, providedMimeType :: Maybe MimeType+	, providedMimeEncoding :: Maybe MimeEncoding 	} -type OptInfo a = Either (IO a) a+-- This is used when testing a matcher, with values to match against+-- provided by the user.+data UserProvidedInfo = UserProvidedInfo+	{ userProvidedFilePath :: UserInfo FilePath+	, userProvidedKey :: UserInfo Key+	, userProvidedFileSize :: UserInfo FileSize+	, userProvidedMimeType :: UserInfo MimeType+	, userProvidedMimeEncoding :: UserInfo MimeEncoding+	} --- If the OptInfo is not available, accessing it may result in eg an+-- This may fail if the user did not provide the information.+type UserInfo a = Either (IO a) a++-- If the UserInfo is not available, accessing it may result in eg an -- exception being thrown.-getInfo :: MonadIO m => OptInfo a -> m a-getInfo (Right i) = return i-getInfo (Left e) = liftIO e+getUserInfo :: MonadIO m => UserInfo a -> m a+getUserInfo (Right i) = return i+getUserInfo (Left e) = liftIO e  type FileMatcherMap a = M.Map UUID (FileMatcher a) @@ -55,12 +66,23 @@  type AssumeNotPresent = S.Set UUID -type MatchFiles a = AssumeNotPresent -> MatchInfo -> a Bool+data MatchFiles a = MatchFiles +	{ matchAction :: AssumeNotPresent -> MatchInfo -> a Bool+	, matchNeedsFileName :: Bool+	-- ^ does the matchAction need a filename in order to match?+	, matchNeedsFileContent :: Bool+	-- ^ does the matchAction need the file content to be present in+	-- order to succeed?+	, matchNeedsKey :: Bool+	-- ^ does the matchAction look at information about the key?+	, matchNeedsLocationLog :: Bool+	-- ^ does the matchAction look at the location log?+	}  type FileMatcher a = Matcher (MatchFiles a)  -- This is a matcher that can have tokens added to it while it's being -- built, and once complete is compiled to an unchangable matcher. data ExpandableMatcher a-	= BuildingMatcher [Token (MatchInfo -> a Bool)]-	| CompleteMatcher (Matcher (MatchInfo -> a Bool))+	= BuildingMatcher [Token (MatchFiles a)]+	| CompleteMatcher (Matcher (MatchFiles a))
Types/GitConfig.hs view
@@ -9,7 +9,7 @@ {-# LANGUAGE OverloadedStrings #-}  module Types.GitConfig ( -	Configurable(..),+	GlobalConfigurable(..), 	ConfigSource(..), 	GitConfig(..), 	extractGitConfig,@@ -53,7 +53,7 @@  -- | A configurable value, that may not be fully determined yet because -- the global git config has not yet been loaded.-data Configurable a+data GlobalConfigurable a 	= HasGitConfig a 	-- ^ The git config has a value. 	| HasGlobalConfig a@@ -84,17 +84,17 @@ 	, annexDelayAdd :: Maybe Int 	, annexHttpHeaders :: [String] 	, annexHttpHeadersCommand :: Maybe String-	, annexAutoCommit :: Configurable Bool-	, annexResolveMerge :: Configurable Bool-	, annexSyncContent :: Configurable Bool-	, annexSyncOnlyAnnex :: Configurable Bool+	, annexAutoCommit :: GlobalConfigurable Bool+	, annexResolveMerge :: GlobalConfigurable Bool+	, annexSyncContent :: GlobalConfigurable Bool+	, annexSyncOnlyAnnex :: GlobalConfigurable Bool 	, annexDebug :: Bool 	, annexWebOptions :: [String] 	, annexYoutubeDlOptions :: [String] 	, annexAriaTorrentOptions :: [String] 	, annexCrippledFileSystem :: Bool-	, annexLargeFiles :: Configurable (Maybe String)-	, annexDotFiles :: Configurable Bool+	, annexLargeFiles :: GlobalConfigurable (Maybe String)+	, annexDotFiles :: GlobalConfigurable Bool 	, annexGitAddToAnnex :: Bool 	, annexAddSmallFiles :: Bool 	, annexFsckNudge :: Bool@@ -111,7 +111,7 @@ 	, annexVerify :: Bool 	, annexPidLock :: Bool 	, annexPidLockTimeout :: Seconds-	, annexAddUnlocked :: Configurable (Maybe String)+	, annexAddUnlocked :: GlobalConfigurable (Maybe String) 	, annexSecureHashesOnly :: Bool 	, annexRetry :: Maybe Integer 	, annexForwardRetry :: Maybe Integer
Types/Import.hs view
@@ -5,10 +5,14 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE DeriveGeneric #-}+ module Types.Import where  import qualified Data.ByteString as S import Data.Char+import Control.DeepSeq+import GHC.Generics  import Types.Export import Utility.QuickCheck@@ -29,8 +33,10 @@  - the repository. It should be reasonably short since it is stored in the  - git-annex branch. -} newtype ContentIdentifier = ContentIdentifier S.ByteString-	deriving (Eq, Ord, Show)+	deriving (Eq, Ord, Show, Generic) +instance NFData ContentIdentifier+ instance Arbitrary ContentIdentifier where 	-- Avoid non-ascii ContentIdentifiers because fully arbitrary 	-- strings may not be encoded using the filesystem@@ -47,4 +53,6 @@ 	-- files that are stored in them. This is equivilant to a git 	-- commit history. 	}-	deriving (Show)+	deriving (Show, Generic)++instance NFData info => NFData (ImportableContents info)
Upgrade/V7.hs view
@@ -17,6 +17,7 @@ import qualified Git.LsFiles as LsFiles import qualified Git import Git.FilePath+import Config  upgrade :: Bool -> Annex Bool upgrade automatic = do@@ -96,7 +97,7 @@ -- annex object. That work is only done once, and then the object will -- finally get its inode cached. populateKeysDb :: Annex ()-populateKeysDb = do+populateKeysDb = unlessM isBareRepo $ do 	top <- fromRepo Git.repoPath 	(l, cleanup) <- inRepo $ LsFiles.inodeCaches [top] 	forM_ l $ \case
Utility/Matcher.hs view
@@ -10,12 +10,12 @@  - Is forgiving about misplaced closing parens, so "foo and (bar or baz"  - will be handled, as will "foo and ( bar or baz ) )"  -- - Copyright 2011-2013 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -} -{-# LANGUAGE Rank2Types, KindSignatures #-}+{-# LANGUAGE Rank2Types, KindSignatures, DeriveFoldable #-}  module Utility.Matcher ( 	Token(..),@@ -27,6 +27,7 @@ 	matchMrun, 	isEmpty, 	combineMatchers,+	introspect,  	prop_matcher_sane ) where@@ -43,7 +44,7 @@ 	| MOr (Matcher op) (Matcher op) 	| MNot (Matcher op) 	| MOp op-	deriving (Show, Eq)+	deriving (Show, Eq, Foldable)  {- Converts a word of syntax into a token. Doesn't handle operations. -} syntaxToken :: String -> Either String (Token op)@@ -146,6 +147,10 @@ 	| isEmpty a = b 	| isEmpty b = a 	| otherwise = a `MOr` b++{- Checks if anything in the matcher meets the condition. -}+introspect :: (a -> Bool) -> Matcher a -> Bool+introspect = any  prop_matcher_sane :: Bool prop_matcher_sane = all (\m -> match dummy m ()) $ map generate
Utility/Metered.hs view
@@ -11,6 +11,7 @@ 	MeterUpdate, 	nullMeterUpdate, 	combineMeterUpdate,+	TotalSize(..), 	BytesProcessed(..), 	toBytesProcessed, 	fromBytesProcessed,@@ -29,6 +30,8 @@ 	ProgressParser, 	commandMeter, 	commandMeter',+	commandMeterExitCode,+	commandMeterExitCode', 	demeterCommand, 	demeterCommandEnv, 	avoidProgress,@@ -228,31 +231,44 @@ 	}  {- Parses the String looking for a command's progress output, and returns- - Maybe the number of bytes done so far, and any any remainder of the- - string that could be an incomplete progress output. That remainder- - should be prepended to future output, and fed back in. This interface- - allows the command's output to be read in any desired size chunk, or- - even one character at a time.+ - Maybe the number of bytes done so far, optionally a total size, + - and any any remainder of the string that could be an incomplete+ - progress output. That remainder should be prepended to future output,+ - and fed back in. This interface allows the command's output to be read+ - in any desired size chunk, or even one character at a time.  -}-type ProgressParser = String -> (Maybe BytesProcessed, String)+type ProgressParser = String -> (Maybe BytesProcessed, Maybe TotalSize, String) +newtype TotalSize = TotalSize Integer+ {- Runs a command and runs a ProgressParser on its output, in order  - to update a meter.+ -+ - If the Meter is provided, the ProgressParser can report the total size,+ - which allows creating a Meter before the size is known.  -}-commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool-commandMeter progressparser oh meterupdate cmd params = do-	ret <- commandMeter' progressparser oh meterupdate cmd params+commandMeter :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool+commandMeter progressparser oh meter meterupdate cmd params =+	commandMeter' progressparser oh meter meterupdate cmd params id++commandMeter' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool+commandMeter' progressparser oh meter meterupdate cmd params mkprocess = do+	ret <- commandMeterExitCode' progressparser oh meter meterupdate cmd params mkprocess 	return $ case ret of 		Just ExitSuccess -> True 		_ -> False -commandMeter' :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode)-commandMeter' progressparser oh meterupdate cmd params = -	outputFilter cmd params Nothing-		(feedprogress zeroBytesProcessed [])+commandMeterExitCode :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode)+commandMeterExitCode progressparser oh meter meterupdate cmd params =+	commandMeterExitCode' progressparser oh meter meterupdate cmd params id++commandMeterExitCode' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO (Maybe ExitCode)+commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess = +	outputFilter cmd params mkprocess Nothing+		(feedprogress mmeter zeroBytesProcessed []) 		handlestderr   where-	feedprogress prev buf h = do+	feedprogress sendtotalsize prev buf h = do 		b <- S.hGetSome h 80 		if S.null b 			then return ()@@ -261,13 +277,18 @@ 					S.hPut stdout b 					hFlush stdout 				let s = decodeBS b-				let (mbytes, buf') = progressparser (buf++s)+				let (mbytes, mtotalsize, buf') = progressparser (buf++s)+				sendtotalsize' <- case (sendtotalsize, mtotalsize) of+					(Just meter, Just (TotalSize n)) -> do+						setMeterTotalSize meter n+						return Nothing+					_ -> return sendtotalsize 				case mbytes of-					Nothing -> feedprogress prev buf' h+					Nothing -> feedprogress sendtotalsize' prev buf' h 					(Just bytes) -> do 						when (bytes /= prev) $ 							meterupdate bytes-						feedprogress bytes buf' h+						feedprogress sendtotalsize' bytes buf' h  	handlestderr h = unlessM (hIsEOF h) $ do 		stderrHandler oh =<< hGetLine h@@ -283,7 +304,7 @@  demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool demeterCommandEnv oh cmd params environ = do-	ret <- outputFilter cmd params environ+	ret <- outputFilter cmd params id environ 		(\outh -> avoidProgress True outh stdouthandler) 		(\errh -> avoidProgress True errh $ stderrHandler oh) 	return $ case ret of@@ -308,11 +329,12 @@ outputFilter 	:: FilePath 	-> [CommandParam]+	-> (CreateProcess -> CreateProcess) 	-> Maybe [(String, String)] 	-> (Handle -> IO ()) 	-> (Handle -> IO ()) 	-> IO (Maybe ExitCode)-outputFilter cmd params environ outfilter errfilter = +outputFilter cmd params mkprocess environ outfilter errfilter =  	catchMaybeIO $ withCreateProcess p go   where 	go _ (Just outh) (Just errh) pid = do@@ -338,7 +360,7 @@ 		return ret 	go _ _ _ _ = error "internal" 	-	p = (proc cmd (toCommand params))+	p = mkprocess (proc cmd (toCommand params)) 		{ env = environ 		, std_out = CreatePipe 		, std_err = CreatePipe
Utility/Path.hs view
@@ -19,7 +19,9 @@ 	relPathDirToFile, 	relPathDirToFileAbs, 	segmentPaths,+	segmentPaths', 	runSegmentPaths,+	runSegmentPaths', 	relHome, 	inPath, 	searchPath,@@ -215,22 +217,33 @@  - that many paths in doesn't care too much about order of the later ones.  -} segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]]-segmentPaths _ [] new = [new]-segmentPaths _ [_] new = [new] -- optimisation-segmentPaths c (l:ls) new = found : segmentPaths c ls rest+segmentPaths = segmentPaths' (\_ r -> r)++segmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[r]]+segmentPaths' f _ [] new = [map (f Nothing) new]+segmentPaths' f _ [i] new = [map (f (Just i)) new] -- optimisation+segmentPaths' f c (i:is) new = +	map (f (Just i)) found : segmentPaths' f c is rest   where-	(found, rest) = if length ls < 100-		then partition inl new-		else break (not . inl) new-	inl f = l' `dirContains` fromRawFilePath (c f)-	l' = fromRawFilePath l+	(found, rest) = if length is < 100+		then partition ini new+		else break (not . ini) new+	ini p = i' `dirContains` fromRawFilePath (c p)+	i' = fromRawFilePath i  {- This assumes that it's cheaper to call segmentPaths on the result,  - than it would be to run the action separately with each path. In  - the case of git file list commands, that assumption tends to hold.  -}-runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]]-runSegmentPaths c a paths = segmentPaths c paths <$> a paths+runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO ([a], v)) -> [RawFilePath] -> IO ([[a]], v)+runSegmentPaths c a paths = do+	(l, cleanup) <- a paths+	return (segmentPaths c paths l, cleanup)++runSegmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> ([RawFilePath] -> IO ([a], v)) -> [RawFilePath] -> IO ([[r]], v)+runSegmentPaths' si c a paths = do+	(l, cleanup) <- a paths+	return (segmentPaths' si c paths l, cleanup)  {- Converts paths in the home directory to use ~/ -} relHome :: FilePath -> IO String
Utility/Process.hs view
@@ -173,8 +173,9 @@ -- | Wrapper around 'System.Process.createProcess' that does debug logging. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do-	debugProcess p-	Utility.Process.Shim.createProcess p+	r@(_, _, _, h) <- Utility.Process.Shim.createProcess p+	debugProcess p h+	return r  -- | Wrapper around 'System.Process.withCreateProcess' that does debug logging. withCreateProcess :: CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a@@ -182,11 +183,14 @@ 	(\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)  -- | Debugging trace for a CreateProcess.-debugProcess :: CreateProcess -> IO ()-debugProcess p = debugM "Utility.Process" $ unwords-	[ action ++ ":"-	, showCmd p-	]+debugProcess :: CreateProcess -> ProcessHandle -> IO ()+debugProcess p h = do+	pid <- getPid h+	debugM "Utility.Process" $ unwords+		[ describePid pid+		, action ++ ":"+		, showCmd p+		]   where 	action 		| piped (std_in p) && piped (std_out p) = "chat"@@ -196,11 +200,17 @@ 	piped Inherit = False 	piped _ = True +describePid :: Maybe Utility.Process.Shim.Pid -> String+describePid Nothing = "process"+describePid (Just p) = "process [" ++  show p ++ "]"+ -- | Wrapper around 'System.Process.waitForProcess' that does debug logging. waitForProcess ::  ProcessHandle -> IO ExitCode waitForProcess h = do+	-- Have to get pid before waiting, which closes the ProcessHandle.+	pid <- getPid h 	r <- Utility.Process.Shim.waitForProcess h-	debugM "Utility.Process" ("process done " ++ show r)+	debugM "Utility.Process" (describePid pid ++ " done " ++ show r) 	return r  cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
Utility/Rsync.hs view
@@ -114,7 +114,7 @@  -} rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool rsyncProgress oh meter ps =-	commandMeter' parseRsyncProgress oh meter "rsync" (rsyncParamsFixup ps) >>= \case+	commandMeterExitCode parseRsyncProgress oh Nothing meter "rsync" (rsyncParamsFixup ps) >>= \case 		Just ExitSuccess -> return True 		Just (ExitFailure exitcode) -> do 			when (exitcode /= 1) $@@ -136,10 +136,10 @@ parseRsyncProgress :: ProgressParser parseRsyncProgress = go [] . reverse . progresschunks   where-	go remainder [] = (Nothing, remainder)+	go remainder [] = (Nothing, Nothing, remainder) 	go remainder (x:xs) = case parsebytes (findbytesstart x) of 		Nothing -> go (delim:x++remainder) xs-		Just b -> (Just (toBytesProcessed b), remainder)+		Just b -> (Just (toBytesProcessed b), Nothing, remainder)  	delim = '\r'
Utility/Url.hs view
@@ -41,6 +41,7 @@ 	GetBasicAuth, 	noBasicAuth, 	applyBasicAuth',+	extractFromResourceT, ) where  import Common@@ -60,8 +61,10 @@ import qualified Data.ByteString.UTF8 as B8 import qualified Data.ByteString.Lazy as L import qualified Data.Set as S-import Control.Exception (throwIO)+import Control.Exception (throwIO, evaluate) import Control.Monad.Trans.Resource+import Control.Monad.IO.Class (MonadIO)+import Control.DeepSeq import Network.HTTP.Conduit import Network.HTTP.Client import Network.HTTP.Simple (getResponseHeader)@@ -269,12 +272,10 @@ 		debugM "url" (show req') 		join $ runResourceT $ do 			resp <- http req' (httpManager uo)-			-- forces processing the response while-			-- within the runResourceT-			liftIO $ if responseStatus resp == ok200+			if responseStatus resp == ok200 				then do-					let !len = extractlen resp-					let !fn = extractfilename resp+					len <- extractFromResourceT (extractlen resp)+					fn <- extractFromResourceT (extractfilename resp) 					return $ found len fn 				else if responseStatus resp == unauthorized401 					then return $ getBasicAuth uo' (show (getUri req)) >>= \case@@ -463,11 +464,13 @@ 				then do 					store zeroBytesProcessed WriteMode resp 					return (return ())-				else if responseStatus resp == unauthorized401-					then return $ getBasicAuth uo (show (getUri req')) >>= \case-						Nothing -> respfailure resp-						Just ba -> retryauthed ba-					else return $ respfailure resp+				else do+					rf <- extractFromResourceT (respfailure resp)+					if responseStatus resp == unauthorized401+						then return $ getBasicAuth uo (show (getUri req')) >>= \case+							Nothing -> giveup rf+							Just ba -> retryauthed ba+						else return $ giveup rf   where 	req' = applyRequest uo $ req 		-- Override http-client's default decompression of gzip@@ -498,11 +501,13 @@ 					then do 						store zeroBytesProcessed WriteMode resp 						return (return ())-					else if responseStatus resp == unauthorized401-						then return $ getBasicAuth uo (show (getUri req'')) >>= \case-							Nothing -> respfailure resp-							Just ba -> retryauthed ba-						else return $ respfailure resp+					else do+						rf <- extractFromResourceT (respfailure resp)+						if responseStatus resp == unauthorized401+							then return $ getBasicAuth uo (show (getUri req'')) >>= \case+								Nothing -> giveup rf+								Just ba -> retryauthed ba+							else return $ giveup rf 	 	alreadydownloaded sz s h = s == requestedRangeNotSatisfiable416  		&& case lookup hContentRange h of@@ -521,7 +526,7 @@ 	store initialp mode resp = 		sinkResponseFile meterupdate initialp file mode resp 	-	respfailure = giveup . B8.toString . statusMessage . responseStatus+	respfailure = B8.toString . statusMessage . responseStatus 	 	retryauthed (ba, signalsuccess) = do 		r <- tryNonAsync $ downloadConduit@@ -710,3 +715,11 @@ applyBasicAuth' ba = applyBasicAuth 	(encodeBS (basicAuthUser ba)) 	(encodeBS (basicAuthPassword ba))++{- Make sure whatever is returned is fully evaluated. Avoids any possible+ - issues with laziness deferring processing until a time when the resource+ - has been freed. -}+extractFromResourceT :: (MonadIO m, NFData a) => a -> ResourceT m a+extractFromResourceT v = do+	liftIO $ evaluate (rnf v)+	return v
doc/git-annex-add.mdwn view
@@ -38,7 +38,7 @@  # OPTIONS -* `--force`+* `--no-check-gitignore`    Add gitignored files.
doc/git-annex-addurl.mdwn view
@@ -85,6 +85,12 @@   Use to adjust the filenames that are created by addurl. For example,   `--suffix=.mp3` can be used to add an extension to the file. +* `--no-check-gitignore`++  By default, gitignores are honored and it will refuse to download an+  url to a file that would be ignored. This makes such files be added+  despite any ignores.+ * `--jobs=N` `-JN`    Enables parallel downloads when multiple urls are being added.
doc/git-annex-import.mdwn view
@@ -31,7 +31,7 @@ You can only import from special remotes that were configured with `importtree=yes` when set up with [[git-annex-initremote]](1). Only some kinds of special remotes will let you configure them this way. A perhaps-non-exhastive list is the directory, s3, and adb special remotes.+non-exhaustive list is the directory, s3, and adb special remotes.  To import from a special remote, you must specify the name of a branch. A corresponding remote tracking branch will be updated by `git annex import`.@@ -72,6 +72,9 @@ 	git config remote.myremote.annex-tracking-branch master 	git annex sync --content +Any files that are gitignored will not be included in the import,+but will be left on the remote.+ When the special remote has a preferred content expression set by [[git-annex-wanted]](1), it will be honored when importing from it. Files that are not preferred content of the remote will not be@@ -91,33 +94,14 @@  * `--content`, `--no-content` -  Controls whether content is downloaded from the special remote.+  Controls whether annexed content is downloaded from the special remote.+   The default is to download content into the git-annex repository.    With --no-content, git-annex keys are generated from information   provided by the special remote, without downloading it. Commands like   `git-annex get` can later be used to download files, as desired.--  The --no-content option is not supported by all special remotes,-  and the kind of git-annex key that is generated is left up to-  each special remote. So while the directory special remote hashes-  the file and generates the same key it usually would, other-  special remotes may use unusual keys like SHA1, or WORM, depending-  on the limitations of the special remote. --  The annex.securehashesonly configuration, if set, will prevent-  --no-content importing from a special remote that uses insecure keys.--  Using --no-content prevents annex.largefiles from being checked,-  because the files are not downloaded. So, when using --no-content,-  files that would usually be considered non-large will be added to the-  annex, rather than adding them directly to the git repository.--  Note that a different git tree will often be generated when using-  --no-content than would be generated when using --content, because-  the options cause different kinds of keys to be used when importing-  new/changed files. So mixing uses of --content and --no-content can-  lead to merge conflicts in some situations.+  The --no-content option is not supported by all special remotes.  # IMPORTING FROM A DIRECTORY @@ -200,6 +184,10 @@   For example: `-J4`      Setting this to "cpus" will run one job per CPU core.++* `--no-check-gitignore`++  Add gitignored files.  * `--json`
doc/git-annex-importfeed.mdwn view
@@ -89,6 +89,12 @@      (These use the UTC time zone, not the local time zone.) +* `--no-check-gitignore`++  By default, gitignores are honored and it will refuse to download an+  url to a file that would be ignored. This makes such files be added+  despite any ignores.+ # SEE ALSO  [[git-annex]](1)
doc/git-annex-sync.mdwn view
@@ -108,12 +108,14 @@   This behavior can be overridden by configuring the preferred content   of a repository. See [[git-annex-preferred-content]](1). -  When `remote.<name>.annex-tracking-branch` is configured for a special remote-  and that branch is checked out, syncing content will import changes from-  the remote, merge them into the branch, and export any changes that have-  been committed to the branch back to the remote. See -  See [[git-annex-import]](1) and [[git-annex-export]](1) for details about-  how importing and exporting work.+  When `remote.<name>.annex-tracking-branch` is configured for a special+  remote and that branch is checked out, syncing with --content will+  import changes from the remote, merge them into the branch, and export+  any changes that have been committed to the branch back to the remote.+  With --no-content, imports will only be made from special remotes that+  support importing without transferting files, and no exports will be done.+  See [[git-annex-import]](1) and [[git-annex-export]](1) for details+  about how importing and exporting work.  * `--content-of=path` `-C path`
doc/git-annex.mdwn view
@@ -1014,6 +1014,8 @@    Setting this to "cpus" will run one job per CPU core. +  When the `--batch` option is used, this configuration is ignored.+ * `annex.queuesize`    git-annex builds a queue of git commands, in order to combine similar
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20200908+Version: 8.20201007 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -270,7 +270,7 @@  Flag Benchmark   Description: Enable benchmarking-  Default: False+  Default: True  Flag DebugLocks   Description: Debug location of MVar/STM deadlocks
stack.yaml view
@@ -8,7 +8,7 @@     magicmime: false     dbus: false     debuglocks: false-    benchmark: false+    benchmark: true     networkbsd: true     gitlfs: true     httpclientrestricted: true@@ -28,4 +28,4 @@ - network-3.1.0.1 explicit-setup-deps:   git-annex: true-resolver: lts-16.10+resolver: lts-16.16