git-annex 8.20200522 → 8.20200617

raw patch · 125 files changed

+1477/−977 lines, 125 filesdep ~process

Dependency ranges changed: process

Files

• Annex/AutoMerge.hs +3/−2
• Annex/GitOverlay.hs +59/−0
• Annex/Import.hs +2/−1
• Annex/Ingest.hs +0/−1
• Annex/Init.hs +76/−21
• Annex/Link.hs +9/−7
• Annex/LockFile.hs +1/−1
• Annex/LockPool/PosixOrPid.hs +2/−1
• Annex/SpecialRemote/Config.hs +11/−11
• Annex/Ssh.hs +21/−17
• Annex/View.hs +7/−8
• Annex/WorkTree.hs +9/−5
• Annex/YoutubeDl.hs +10/−6
• Assistant.hs +5/−3
• Assistant/DeleteRemote.hs +2/−2
• Assistant/MakeRemote.hs +5/−3
• Assistant/Monad.hs +3/−0
• Assistant/Restart.hs +2/−4
• Assistant/Sync.hs +8/−3
• Assistant/Threads/ConfigMonitor.hs +2/−2
• Assistant/Threads/RemoteControl.hs +16/−9
• Assistant/Threads/SanityChecker.hs +1/−1
• Assistant/Threads/TransferScanner.hs +1/−1
• Assistant/Threads/Watcher.hs +2/−2
• Assistant/WebApp/Configurators/AWS.hs +3/−5
• Assistant/WebApp/Configurators/Edit.hs +3/−3
• Assistant/WebApp/DashBoard.hs +2/−2
• Assistant/WebApp/RepoList.hs +2/−2
• BuildFlags.hs +4/−1
• CHANGELOG +63/−0
• COPYRIGHT +1/−1
• CmdLine.hs +1/−2
• CmdLine/Action.hs +10/−1
• CmdLine/Seek.hs +65/−40
• Command/Add.hs +8/−3
• Command/AddUrl.hs +1/−1
• Command/CheckPresentKey.hs +7/−1
• Command/Copy.hs +4/−2
• Command/Drop.hs +4/−3
• Command/Export.hs +11/−4
• Command/Find.hs +3/−2
• Command/Fix.hs +4/−2
• Command/Fsck.hs +4/−2
• Command/Get.hs +5/−3
• Command/Import.hs +1/−1
• Command/Init.hs +16/−3
• Command/Inprogress.hs +4/−2
• Command/List.hs +4/−3
• Command/Lock.hs +4/−2
• Command/Log.hs +4/−2
• Command/LookupKey.hs +1/−1
• Command/Map.hs +9/−3
• Command/MetaData.hs +5/−4
• Command/Migrate.hs +4/−1
• Command/Mirror.hs +8/−3
• Command/Move.hs +9/−3
• Command/Multicast.hs +3/−1
• Command/PreCommit.hs +2/−1
• Command/Sync.hs +10/−7
• Command/Unannex.hs +4/−1
• Command/Undo.hs +1/−1
• Command/Uninit.hs +4/−2
• Command/Unlock.hs +4/−1
• Command/Unused.hs +2/−2
• Command/View.hs +1/−1
• Command/WebApp.hs +5/−4
• Command/Whereis.hs +4/−2
• Creds.hs +29/−15
• Crypto.hs +15/−4
• Git/CatFile.hs +7/−5
• Git/Command.hs +28/−13
• Git/Config.hs +26/−14
• Git/Fsck.hs +24/−20
• Git/GCrypt.hs +6/−6
• Git/History.hs +15/−12
• Git/LsFiles.hs +26/−70
• Git/Queue.hs +10/−4
• Git/UpdateIndex.hs +34/−26
• NEWS +11/−0
• P2P/IO.hs +28/−27
• Remote.hs +2/−1
• Remote/Bup.hs +31/−11
• Remote/Ddar.hs +23/−9
• Remote/Directory.hs +18/−10
• Remote/External.hs +44/−20
• Remote/External/Types.hs +1/−1
• Remote/Git.hs +35/−20
• Remote/Glacier.hs +19/−7
• Remote/Helper/Chunked/Legacy.hs +2/−3
• Remote/Helper/Encryptable.hs +2/−2
• Remote/Helper/Ssh.hs +9/−10
• Remote/List.hs +0/−12
• Remote/List/Util.hs +24/−0
• Remote/Rsync.hs +8/−6
• Remote/S3.hs +5/−6
• RemoteDaemon/Transport/Ssh.hs +11/−9
• Test.hs +2/−2
• Test/Framework.hs +3/−3
• Types/Crypto.hs +1/−0
• Types/GitConfig.hs +2/−0
• Types/WorkerPool.hs +7/−6
• Upgrade.hs +2/−1
• Upgrade/V1.hs +1/−1
• Utility/Batch.hs +3/−17
• Utility/CoProcess.hs +37/−19
• Utility/CopyFile.hs +6/−5
• Utility/Env/Set.hs +6/−0
• Utility/Exception.hs +10/−1
• Utility/Gpg.hs +54/−27
• Utility/LockFile/PidLock.hs +74/−41
• Utility/LockFile/Posix.hs +8/−5
• Utility/Lsof.hs +9/−4
• Utility/MagicWormhole.hs +12/−16
• Utility/Metered.hs +13/−9
• Utility/Parallel.hs +0/−34
• Utility/Process.hs +60/−160
• Utility/Process/Transcript.hs +33/−24
• Utility/SafeCommand.hs +3/−3
• doc/git-annex-checkpresentkey.mdwn +4/−4
• doc/git-annex-export.mdwn +21/−0
• doc/git-annex-import.mdwn +4/−0
• doc/git-annex-init.mdwn +6/−1
• doc/git-annex-initremote.mdwn +4/−4
• doc/git-annex.mdwn +22/−0
• git-annex.cabal +6/−5

@@ -120,7 +120,7 @@ 	void $ liftIO cleanup  	unless inoverlay $ do-		(deleted, cleanup2) <- inRepo (LsFiles.deleted [top])+		(deleted, cleanup2) <- inRepo (LsFiles.deleted [] [top]) 		unless (null deleted) $ 			Annex.Queue.addCommand "rm" 				[Param "--quiet", Param "-f", Param "--"]@@ -130,7 +130,8 @@ 	when merged $ do 		Annex.Queue.flush 		unless inoverlay $ do-			unstagedmap <- inodeMap $ inRepo $ LsFiles.notInRepo False [top]+			unstagedmap <- inodeMap $ inRepo $+				LsFiles.notInRepo [] False [top] 			cleanConflictCruft mergedks' mergedfs' unstagedmap 		showLongNote "Merge conflict was automatically resolved; you may want to examine the result." 	return merged

@@ -20,6 +20,11 @@ import Git.Env import qualified Annex import qualified Annex.Queue+import qualified Utility.LockFile.PidLock as PidF+import qualified Utility.LockPool.PidLock as PidP+import Utility.LockPool (dropLock)+import Utility.Env+import Annex.LockPool.PosixOrPid (pidLockFile)  {- Runs an action using a different git index file. -} withIndexFile :: AltIndexFile -> (FilePath -> Annex a) -> Annex a@@ -125,3 +130,57 @@ 		, Annex.repoqueue = Just q 		} 	either E.throw return v++{- Wrap around actions that may run a git-annex child process.+ -+ - When pid locking is in use, this tries to take the pid lock, and if+ - successful, holds it while running the child process. The action+ - is run with the Annex monad modified so git commands are run with+ - an env var set, which prevents child git annex processes from t+ - rying to take the pid lock themselves.+ -+ - This way, any locking the parent does will not get in the way of+ - the child. The child is assumed to not do any locking that conflicts+ - with the parent, but if it did happen to do that, it would be noticed+ - when git-annex is used without pid locking.+ -}+runsGitAnnexChildProcess :: Annex a -> Annex a+runsGitAnnexChildProcess a = pidLockFile >>= \case+	Nothing -> a+	Just pidlock -> bracket (setup pidlock) cleanup (go pidlock)+  where+	setup pidlock = liftIO $ PidP.tryLock pidlock+	+	cleanup (Just h) = liftIO $ dropLock h+	cleanup Nothing = return ()+	+	go _ Nothing = a+	go pidlock (Just _h) = do+		v <- liftIO $ PidF.pidLockEnv pidlock+		let addenv g = do+			g' <- liftIO $ addGitEnv g v "1"+			return (g', ())+		let rmenv oldg g+			| any (\(k, _) -> k == v) (fromMaybe [] (Git.gitEnv oldg)) = g+			| otherwise = +				let e' = case Git.gitEnv g of+					Just e -> Just (delEntry v e)+					Nothing -> Nothing+				in g { Git.gitEnv = e' }+		withAltRepo addenv rmenv (const a)++runsGitAnnexChildProcess' :: Git.Repo -> (Git.Repo -> IO a) -> Annex a+runsGitAnnexChildProcess' r a = pidLockFile >>= \case+	Nothing -> liftIO $ a r+	Just pidlock -> liftIO $ bracket (setup pidlock) cleanup (go pidlock)+  where+	setup pidlock = PidP.tryLock pidlock+	+	cleanup (Just h) = dropLock h+	cleanup Nothing = return ()+	+	go _ Nothing = a r+	go pidlock (Just _h) = do+		v <- PidF.pidLockEnv pidlock+		r' <- addGitEnv r v "1"+		a r'

@@ -50,6 +50,7 @@ import qualified Database.Export as Export import qualified Database.ContentIdentifier as CIDDb import qualified Logs.ContentIdentifier as CIDLog+import Backend.Utilities  import Control.Concurrent.STM import qualified Data.Map.Strict as M@@ -404,7 +405,7 @@  - content, before generating its real key. -} importKey :: ContentIdentifier -> Integer -> Key importKey (ContentIdentifier cid) size = mkKey $ \k -> k-	{ keyName = cid+	{ keyName = genKeyName (decodeBS cid) 	, keyVariety = OtherKey "CID" 	, keySize = Just size 	}

@@ -18,7 +18,6 @@ 	addLink, 	makeLink, 	addUnlocked,-	restoreFile, 	forceParams, 	addAnnexedFile, ) where

@@ -1,6 +1,6 @@ {- git-annex repository initialization  -- - 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.  -}@@ -10,6 +10,7 @@  module Annex.Init ( 	ensureInitialized,+	autoInitialize, 	isInitialized, 	initialize, 	initialize',@@ -35,17 +36,21 @@ import Annex.UUID import Annex.WorkTree import Annex.Fixup+import Annex.Path+import Annex.GitOverlay import Config import Config.Files import Config.Smudge import qualified Upgrade.V5.Direct as Direct import qualified Annex.AdjustedBranch as AdjustedBranch+import Remote.List.Util (remotesChanged) import Annex.Environment import Annex.Hook import Annex.InodeSentinal import Upgrade import Annex.Tmp import Utility.UserInfo+import Utility.ThreadScheduler #ifndef mingw32_HOST_OS import Annex.Perms import Utility.FileMode@@ -55,9 +60,10 @@ #endif  import qualified Data.Map as M+import Control.Concurrent.Async  checkCanInitialize :: Annex a -> Annex a-checkCanInitialize a = inRepo (noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree) >>= \case+checkCanInitialize a = canInitialize' >>= \case 	Nothing -> a 	Just noannexmsg -> do 		warning "Initialization prevented by .noannex file (remove the file to override)"@@ -65,6 +71,12 @@ 			warning noannexmsg 		giveup "Not initialized." +canInitialize :: Annex Bool+canInitialize = isNothing <$> canInitialize'++canInitialize' :: Annex (Maybe String)+canInitialize' = inRepo (noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree)+ genDescription :: Maybe String -> Annex UUIDDesc genDescription (Just d) = return $ UUIDDesc $ encodeBS d genDescription Nothing = do@@ -150,10 +162,23 @@ ensureInitialized = getVersion >>= maybe needsinit checkUpgrade   where 	needsinit = ifM Annex.Branch.hasSibling-		( initialize Nothing Nothing-		, giveup $ "First run: git-annex init"+		( do+			initialize Nothing Nothing+			autoEnableSpecialRemotes+		, giveup "First run: git-annex init" 		) +{- Initialize if it can do so automatically.+ -+ - Checks repository version and handles upgrades too.+ -}+autoInitialize :: Annex ()+autoInitialize = getVersion >>= maybe needsinit checkUpgrade+  where+	needsinit = whenM (canInitialize <&&> Annex.Branch.hasSibling) $ do+			initialize Nothing Nothing+			autoEnableSpecialRemotes+ {- Checks if a repository is initialized. Does not check version for ugrade. -} isInitialized :: Annex Bool isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion@@ -214,21 +239,28 @@ 			(Git.Config.boolConfig False)  probeLockSupport :: Annex Bool-probeLockSupport = do #ifdef mingw32_HOST_OS-	return True+probeLockSupport = return True #else-	withEventuallyCleanedOtherTmp $ \tmp -> do-		let f = tmp </> "lockprobe"-		mode <- annexFileMode-		liftIO $ do-			nukeFile f-			let locktest = -				Posix.lockExclusive (Just mode) f-					>>= Posix.dropLock-			ok <- isRight <$> tryNonAsync locktest-			nukeFile f-			return ok+probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do+	let f = tmp </> "lockprobe"+	mode <- annexFileMode+	liftIO $ withAsync warnstall (const (go f mode))+  where+	go f mode = do+		nukeFile f+		let locktest = bracket+			(Posix.lockExclusive (Just mode) f)+			Posix.dropLock+			(const noop)+		ok <- isRight <$> tryNonAsync locktest+		nukeFile f+		return ok+	+	warnstall = do+		threadDelaySeconds (Seconds 10)+		warningIO "Probing the filesystem for POSIX fcntl lock support is taking a long time."+		warningIO "(Setting annex.pidlock will avoid this probe.)" #endif  probeFifoSupport :: Annex Bool@@ -252,10 +284,12 @@ #endif  checkLockSupport :: Annex ()-checkLockSupport = unlessM probeLockSupport $ do-	warning "Detected a filesystem without POSIX fcntl lock support."-	warning "Enabling annex.pidlock."-	setConfig (annexConfig "pidlock") (Git.Config.boolConfig True)+checkLockSupport =+	unlessM (annexPidLock <$> Annex.getGitConfig) $+		unlessM probeLockSupport $ do+			warning "Detected a filesystem without POSIX fcntl lock support."+			warning "Enabling annex.pidlock."+			setConfig (annexConfig "pidlock") (Git.Config.boolConfig True)  checkFifoSupport :: Annex () checkFifoSupport = unlessM probeFifoSupport $ do@@ -287,3 +321,24 @@ fixupUnusualReposAfterInit = do 	gc <- Annex.getGitConfig 	void $ inRepo $ \r -> fixupUnusualRepos r gc++{- Try to enable any special remotes that are configured to do so.+ - + - The enabling is done in a child process to avoid it using stdio.+ -}+autoEnableSpecialRemotes :: Annex ()+autoEnableSpecialRemotes = runsGitAnnexChildProcess $ do+	rp <- fromRawFilePath <$> fromRepo Git.repoPath+	cmd <- liftIO programPath+	liftIO $ withNullHandle $ \nullh -> do+		let p = (proc cmd +			[ "init"+			, "--autoenable"+			])+			{ std_out = UseHandle nullh+			, std_err = UseHandle nullh+			, std_in = UseHandle nullh+			, cwd = Just rp+			}+		withCreateProcess p $ \_ _ _ pid -> void $ waitForProcess pid+	remotesChanged

@@ -30,6 +30,7 @@ import Git.Config import Annex.HashObject import Annex.InodeSentinal+import Annex.GitOverlay import Utility.FileMode import Utility.InodeCache import Utility.Tmp.Dir@@ -204,23 +205,24 @@ 		    go (Just _) = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex" $ \tmpdir -> do 			let tmpindex = tmpdir </> "index" 			let updatetmpindex = do-				r' <- Git.Env.addGitEnv r Git.Index.indexEnv +				r' <- liftIO $ Git.Env.addGitEnv r Git.Index.indexEnv  					=<< Git.Index.indexEnvVal tmpindex 				-- Avoid git warning about CRLF munging. 				let r'' = r' { gitGlobalOpts = gitGlobalOpts r' ++ 					[ Param "-c" 					, Param $ "core.safecrlf=" ++ boolConfig False 					] }-				Git.UpdateIndex.refreshIndex r'' $ \feed ->-					forM_ l $ \(f', checkunmodified) ->-						whenM checkunmodified $-							feed f'+				runsGitAnnexChildProcess' r'' $ \r''' ->+					liftIO $ Git.UpdateIndex.refreshIndex r''' $ \feed ->+						forM_ l $ \(f', checkunmodified) ->+							whenM checkunmodified $+								feed f' 			let replaceindex = catchBoolIO $ do 				moveFile tmpindex realindex 				return True-			ok <- liftIO $ createLinkOrCopy realindex tmpindex+			ok <- liftIO (createLinkOrCopy realindex tmpindex) 				<&&> updatetmpindex-				<&&> replaceindex+				<&&> liftIO replaceindex 			unless ok showwarning 		bracket lockindex unlockindex go 

@@ -1,6 +1,6 @@ {- git-annex lock files.  -- - 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.  -}

@@ -18,6 +18,7 @@ 	LockStatus(..), 	getLockStatus, 	checkSaneLock,+	pidLockFile, ) where  import Common@@ -94,4 +95,4 @@ -- avoid complicating any code that might expect to be able to see that -- lock file. But, it's not locked. dummyPosixLock :: Maybe FileMode -> LockFile -> IO ()-dummyPosixLock m f = closeFd =<< openLockFile ReadLock m f+dummyPosixLock m f = bracket (openLockFile ReadLock m f) closeFd (const noop)

@@ -104,11 +104,11 @@ 	, optionalStringParser sameasUUIDField HiddenField 	, optionalStringParser typeField 		(FieldDesc "type of special remote")-	, trueFalseParser autoEnableField False+	, trueFalseParser autoEnableField (Just False) 		(FieldDesc "automatically enable special remote")-	, yesNoParser exportTreeField False+	, yesNoParser exportTreeField (Just False) 		(FieldDesc "export trees of files to this remote")-	, yesNoParser importTreeField False+	, yesNoParser importTreeField (Just False) 		(FieldDesc "import trees of files from this remote") 	, optionalStringParser preferreddirField 		(FieldDesc "directory whose content is preferred")@@ -232,16 +232,16 @@ 	p (Just v) _c = Right (Just (RemoteConfigValue (fromProposedAccepted v))) 	p Nothing _c = Right Nothing -yesNoParser :: RemoteConfigField -> Bool -> FieldDesc -> RemoteConfigFieldParser-yesNoParser f v fd = genParser yesno f v fd+yesNoParser :: RemoteConfigField -> Maybe Bool -> FieldDesc -> RemoteConfigFieldParser+yesNoParser f mdef fd = genParser yesno f mdef fd 	(Just (ValueDesc "yes or no"))   where 	yesno "yes" = Just True 	yesno "no" = Just False 	yesno _ = Nothing -trueFalseParser :: RemoteConfigField -> Bool -> FieldDesc -> RemoteConfigFieldParser-trueFalseParser f v fd = genParser trueFalseParser' f v fd+trueFalseParser :: RemoteConfigField -> Maybe Bool -> FieldDesc -> RemoteConfigFieldParser+trueFalseParser f mdef fd = genParser trueFalseParser' f mdef fd 	(Just (ValueDesc "true or false"))  -- Not using Git.Config.isTrueFalse because git supports@@ -256,22 +256,22 @@ 	:: Typeable t 	=> (String -> Maybe t) 	-> RemoteConfigField-	-> t -- ^ fallback value+	-> Maybe t -- ^ default if not configured 	-> FieldDesc 	-> Maybe ValueDesc 	-> RemoteConfigFieldParser-genParser parse f fallback fielddesc valuedesc = RemoteConfigFieldParser	+genParser parse f mdef fielddesc valuedesc = RemoteConfigFieldParser	 	{ parserForField = f 	, valueParser = p 	, fieldDesc = fielddesc 	, valueDesc = valuedesc 	}   where-	p Nothing _c = Right (Just (RemoteConfigValue fallback))+	p Nothing _c = Right (fmap RemoteConfigValue mdef) 	p (Just v) _c = case parse (fromProposedAccepted v) of 		Just b -> Right (Just (RemoteConfigValue b)) 		Nothing -> case v of-			Accepted _ -> Right (Just (RemoteConfigValue fallback))+			Accepted _ -> Right (fmap RemoteConfigValue mdef) 			Proposed _ -> Left $ 				"Bad value for " ++ fromProposedAccepted f ++ 				case valuedesc of

@@ -258,19 +258,19 @@ 	-- (Except there's an unlikely false positive where a forced 	-- ssh command exits 255.) 	tryssh extraps = liftIO $ withNullHandle $ \nullh -> do-		let p = proc "ssh" $ concat+		let p = (proc "ssh" $ concat 			[ extraps 			, toCommand sshparams 			, [fromSshHost sshhost, "true"]-			]-		(Nothing, Nothing, Nothing, pid) <- createProcess $ p+			]) 			{ std_out = UseHandle nullh 			, std_err = UseHandle nullh 			}-		exitcode <- waitForProcess pid-		return $ case exitcode of-			ExitFailure 255 -> False-			_ -> True+		withCreateProcess p $ \_ _ _ pid -> do+			exitcode <- waitForProcess pid+			return $ case exitcode of+				ExitFailure 255 -> False+				_ -> True  {- Find ssh socket files.  -@@ -319,16 +319,19 @@ forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles  forceStopSsh :: FilePath -> Annex ()-forceStopSsh socketfile = do+forceStopSsh socketfile = withNullHandle $ \nullh -> do 	let (dir, base) = splitFileName socketfile-	let params = sshConnectionCachingParams base-	-- "ssh -O stop" is noisy on stderr even with -q-	void $ liftIO $ catchMaybeIO $-		withQuietOutput createProcessSuccess $-			(proc "ssh" $ toCommand $-				[ Param "-O", Param "stop" ] ++ -				params ++ [Param "localhost"])-				{ cwd = Just dir }+	let p = (proc "ssh" $ toCommand $+		[ Param "-O", Param "stop" ] ++ +		sshConnectionCachingParams base ++ +		[Param "localhost"])+		{ cwd = Just dir+		-- "ssh -O stop" is noisy on stderr even with -q+		, std_out = UseHandle nullh+		, std_err = UseHandle nullh+		}+	void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid ->+		forceSuccessProcess p pid 	liftIO $ nukeFile socketfile  {- This needs to be as short as possible, due to limitations on the length@@ -458,7 +461,8 @@ runSshOptions args s = do 	let args' = toCommand (fromSshOptionsEnv s) ++ args 	let p = proc "ssh" args'-	exitWith =<< waitForProcess . processHandle =<< createProcess p+	exitcode <- withCreateProcess p $ \_ _ _ pid -> waitForProcess pid+	exitWith exitcode  {- When this env var is set, git-annex is being used as a ssh-askpass  - program, and should read the password from the specified location,

@@ -347,14 +347,13 @@ 	top <- fromRepo Git.repoPath 	(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top] 	liftIO . nukeFile =<< fromRepo gitAnnexViewIndex-	uh <- withViewIndex $ inRepo Git.UpdateIndex.startUpdateIndex-	forM_ l $ \(f, sha, mode) -> do-		topf <- inRepo (toTopFilePath f)-		go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f-	liftIO $ do-		void $ stopUpdateIndex uh-		void clean-	genViewBranch view+	viewg <- withViewIndex gitRepo+	withUpdateIndex viewg $ \uh -> do+		forM_ l $ \(f, sha, mode) -> do+			topf <- inRepo (toTopFilePath f)+			go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f+		liftIO $ void clean+		genViewBranch view   where 	genviewedfiles = viewedFiles view mkviewedfile -- enables memoization 

@@ -1,6 +1,6 @@ {- git-annex worktree files  -- - 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.  -}@@ -24,6 +24,8 @@ import Config import qualified Utility.RawFilePath as R +import Control.Concurrent+ {- Looks up the key corresponding to an annexed file in the work tree,  - by examining what the file links to.  -@@ -77,12 +79,13 @@  -} scanUnlockedFiles :: Annex () scanUnlockedFiles = whenM (inRepo Git.Ref.headExists <&&> not <$> isBareRepo) $ do-	Database.Keys.runWriter $-		liftIO . Database.Keys.SQL.dropAllAssociatedFiles+	dropold <- liftIO $ newMVar $ +		Database.Keys.runWriter $+			liftIO . Database.Keys.SQL.dropAllAssociatedFiles 	(l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.LsTree.LsTreeRecursive Git.Ref.headRef 	forM_ l $ \i ->  		when (isregfile i) $-			maybe noop (add i)+			maybe noop (add dropold i) 				=<< catKey (Git.LsTree.sha i) 	liftIO $ void cleanup   where@@ -90,7 +93,8 @@ 		Just Git.Types.TreeFile -> True 		Just Git.Types.TreeExecutable -> True 		_ -> False-	add i k = do+	add dropold i k = do+		join $ fromMaybe noop <$> liftIO (tryTakeMVar dropold) 		let tf = Git.LsTree.file i 		Database.Keys.runWriter $ 			liftIO . Database.Keys.SQL.addAssociatedFileFast k tf

@@ -205,12 +205,14 @@ 			, Param "--no-warnings" 			, Param "--no-playlist" 			]-		(Nothing, Just o, Just e, pid) <- liftIO $ createProcess-			(proc "youtube-dl" (toCommand opts))-				{ std_out = CreatePipe-				, std_err = CreatePipe-				}-		output <- liftIO $ fmap fst $ +		let p = (proc "youtube-dl" (toCommand opts))+			{ std_out = CreatePipe+			, std_err = CreatePipe+			}+		liftIO $ withCreateProcess p waitproc+	+	waitproc Nothing (Just o) (Just e) pid = do+		output <- fmap fst $  			hGetContentsStrict o 				`concurrently` 			hGetContentsStrict e@@ -218,6 +220,8 @@ 		return $ case (ok, lines output) of 			(True, (f:_)) | not (null f) -> Right f 			_ -> nomedia+	waitproc _ _ _ _ = error "internal"+ 	nomedia = Left "no media in url"  youtubeDlOpts :: [CommandParam] -> Annex [CommandParam]

@@ -100,18 +100,20 @@ 		let flag = "GIT_ANNEX_OUTPUT_REDIR" 		createAnnexDirectory (parentDir logfile) 		ifM (liftIO $ isNothing <$> getEnv flag)-			( liftIO $ withFile devNull WriteMode $ \nullh -> do+			( liftIO $ withNullHandle $ \nullh -> do 				loghandle <- openLog logfile 				e <- getEnvironment 				cmd <- programPath 				ps <- getArgs-				(_, _, _, pid) <- createProcess (proc cmd ps)+				let p = (proc cmd ps) 					{ env = Just (addEntry flag "1" e) 					, std_in = UseHandle nullh 					, std_out = UseHandle loghandle 					, std_err = UseHandle loghandle 					}-				exitWith =<< waitForProcess pid+				exitcode <- withCreateProcess p $ \_ _ _ pid ->+					waitForProcess pid+				exitWith exitcode 			, start (Utility.Daemon.foreground (Just pidfile)) $ 				case startbrowser of 					Nothing -> Nothing

@@ -16,7 +16,7 @@ import Logs.Location import Assistant.DaemonStatus import qualified Remote-import Remote.List+import Remote.List.Util import qualified Git.Remote.Remove import Logs.Trust import qualified Annex@@ -35,7 +35,7 @@ 		<$> liftAnnex (Remote.remoteFromUUID uuid) 	liftAnnex $ do 		inRepo $ Git.Remote.Remove.remove (Remote.name remote)-		void $ remoteListRefresh+		remotesChanged 	updateSyncRemotes 	return remote 

@@ -13,7 +13,7 @@ import Assistant.Ssh import qualified Types.Remote as R import qualified Remote-import Remote.List+import Remote.List.Util import qualified Remote.Rsync as Rsync import qualified Remote.GCrypt as GCrypt import qualified Git@@ -46,7 +46,7 @@ addRemote :: Annex RemoteName -> Annex Remote addRemote a = do 	name <- a-	void remoteListRefresh+	remotesChanged 	maybe (error "failed to add remote") return 		=<< Remote.byName (Just name) @@ -174,7 +174,9 @@ 	-> (Remote -> Bool) 	-> Annex (Maybe CredPair) previouslyUsedCredPair getstorage remotetype criteria =-	getM fromstorage =<< filter criteria . filter sametype <$> remoteList+	getM fromstorage+		=<< filter criteria . filter sametype +		<$> Remote.remoteList   where 	sametype r = R.typename (R.remotetype r) == R.typename remotetype 	fromstorage r = do

@@ -50,6 +50,9 @@ 		Monad, 		MonadIO, 		MonadReader AssistantData,+		MonadCatch,+		MonadThrow,+		MonadMask, 		Fail.MonadFail, 		Functor, 		Applicative

@@ -113,7 +113,5 @@ startAssistant :: FilePath -> IO () startAssistant repo = void $ forkIO $ do 	program <- programPath-	(_, _, _, pid) <- -		createProcess $-			(proc program ["assistant"]) { cwd = Just repo }-	void $ checkSuccessProcess pid+	let p = (proc program ["assistant"]) { cwd = Just repo }+	withCreateProcess p $ \_ _ _ pid -> void $ checkSuccessProcess pid

@@ -17,13 +17,12 @@ import Assistant.ScanRemotes import Assistant.RemoteControl import qualified Command.Sync-import Utility.Parallel import qualified Git import qualified Git.Command import qualified Remote import qualified Types.Remote as Remote-import qualified Remote.List as Remote import qualified Annex.Branch+import Remote.List.Util import Annex.UUID import Annex.TaggedPush import Annex.Ssh@@ -43,6 +42,7 @@ import Data.Time.Clock import qualified Data.Map as M import Control.Concurrent+import Control.Concurrent.Async  {- Syncs with remotes that may have been disconnected for a while.  - @@ -177,6 +177,11 @@ 		<*> (Remote.getRepo r >>= \repo -> 			sshOptionsTo repo (Remote.gitconfig r) g) +inParallel :: (v -> IO Bool) -> [v] -> IO ([v], [v])+inParallel a l = (\(t,f) -> (map fst t, map fst f)) +	. partition snd +	. zip l <$> mapConcurrently a l+ {- Displays an alert while running an action that syncs with some remotes,  - and returns any remotes that it failed to sync with.  -@@ -268,7 +273,7 @@ 	repo <- Remote.getRepo r 	let key = Config.remoteAnnexConfig repo "sync" 	Config.setConfig key (boolConfig enabled)-	void Remote.remoteListRefresh+	remotesChanged  updateExportTreeFromLogAll :: Assistant () updateExportTreeFromLogAll = do

@@ -18,7 +18,7 @@ import Logs.PreferredContent import Logs.Group import Logs.NumCopies-import Remote.List (remoteListRefresh)+import Remote.List.Util import qualified Git.LsTree as LsTree import Git.Types import Git.FilePath@@ -60,7 +60,7 @@ configFilesActions :: [(RawFilePath, Assistant ())] configFilesActions = 	[ (uuidLog, void $ liftAnnex uuidDescMapLoad)-	, (remoteLog, void $ liftAnnex remoteListRefresh)+	, (remoteLog, void $ liftAnnex remotesChanged) 	, (trustLog, void $ liftAnnex trustMapLoad) 	, (groupLog, void $ liftAnnex groupMapLoad) 	, (numcopiesLog, void $ liftAnnex globalNumCopiesLoad)

@@ -32,20 +32,27 @@ 	(cmd, params) <- liftIO $ toBatchCommand 		(program, [Param "remotedaemon", Param "--foreground"]) 	let p = proc cmd (toCommand params)-	(Just toh, Just fromh, _, pid) <- liftIO $ createProcess p+	bracket (setup p) cleanup (go p)+  where+	setup p = liftIO $ createProcess $ p 		{ std_in = CreatePipe 		, std_out = CreatePipe 		}-	-	urimap <- liftIO . newMVar =<< liftAnnex getURIMap+	cleanup = liftIO . cleanupProcess -	controller <- asIO $ remoteControllerThread toh-	responder <- asIO $ remoteResponderThread fromh urimap+	go p (Just toh, Just fromh, _, pid) = do+		urimap <- liftIO . newMVar =<< liftAnnex getURIMap -	-- run controller and responder until the remotedaemon dies-	liftIO $ void $ tryNonAsync $ controller `concurrently` responder-	debug ["remotedaemon exited"]-	liftIO $ forceSuccessProcess p pid+		controller <- asIO $ remoteControllerThread toh+		responder <- asIO $ remoteResponderThread fromh urimap++		-- run controller and responder until the remotedaemon dies+		liftIO $ void $ tryNonAsync $+			controller `concurrently` responder+		debug ["remotedaemon exited"]+		liftIO $ forceSuccessProcess p pid	+	go _ _ = error "internal"+		  -- feed from the remoteControl channel into the remotedaemon remoteControllerThread :: Handle -> Assistant ()

@@ -152,7 +152,7 @@ 	batchmaker <- liftIO getBatchCommandMaker  	-- Find old unstaged symlinks, and add them to git.-	(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g+	(unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo [] False ["."] g 	now <- liftIO getPOSIXTime 	forM_ unstaged $ \file -> do 		let file' = fromRawFilePath file

@@ -128,7 +128,7 @@ 		<$> filterM inUnwantedGroup us  	g <- liftAnnex gitRepo-	(files, cleanup) <- liftIO $ LsFiles.inRepo [] g+	(files, cleanup) <- liftIO $ LsFiles.inRepo [] [] g 	removablers <- scan unwantedrs files 	void $ liftIO cleanup 

@@ -136,7 +136,7 @@ 		-- Notice any files that were deleted before 		-- watching was started. 		top <- liftAnnex $ fromRepo Git.repoPath-		(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top]+		(fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [] [top] 		forM_ fs $ \f -> do 			let f' = fromRawFilePath f 			liftAnnex $ onDel' f'@@ -362,7 +362,7 @@ onDelDir :: Handler onDelDir dir _ = do 	debug ["directory deleted", dir]-	(fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [toRawFilePath dir]+	(fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [] [toRawFilePath dir] 	let fs' = map fromRawFilePath fs  	liftAnnex $ mapM_ onDel' fs'

@@ -43,13 +43,14 @@   where 	needglaciercli = $(widgetFile "configurators/needglaciercli") -data StorageClass = StandardRedundancy | StandardInfrequentAccess | ReducedRedundancy+data StorageClass+	= StandardRedundancy+	| StandardInfrequentAccess 	deriving (Eq, Enum, Bounded)  instance Show StorageClass where 	show StandardRedundancy = "STANDARD"  	show StandardInfrequentAccess = "STANDARD_IA"-	show ReducedRedundancy = "REDUCED_REDUNDANCY"  data AWSInput = AWSInput 	{ accessKeyID :: Text@@ -78,10 +79,7 @@ 	storageclasses :: [(Text, StorageClass)] 	storageclasses = 		[ ("Standard redundancy", StandardRedundancy)-#ifdef WITH_S3 		, ("Infrequent access (cheaper for backups and archives)", StandardInfrequentAccess)-#endif-		, ("Reduced redundancy (costs less)", ReducedRedundancy) 		]  glacierInputAForm :: Maybe CredPair -> MkAForm AWSInput

@@ -25,7 +25,7 @@ #endif import qualified Remote import qualified Types.Remote as Remote-import qualified Remote.List as Remote+import Remote.List.Util import Logs.UUID import Logs.Group import Logs.PreferredContent@@ -116,7 +116,7 @@ 				, Param $ T.unpack $ repoName oldc 				, Param name 				]-			void Remote.remoteListRefresh+			remotesChanged 		liftAssistant updateSyncRemotes 	when associatedDirectoryChanged $ case repoAssociatedDirectory newc of 		Nothing -> noop@@ -309,7 +309,7 @@ 			setConfig 				(remoteAnnexConfig repo "ignore") 				(Git.Config.boolConfig False)-		liftAnnex $ void Remote.remoteListRefresh+		liftAnnex remotesChanged 		liftAssistant updateSyncRemotes 		liftAssistant $ syncRemote rmt 		redirect DashboardR

@@ -137,8 +137,8 @@ 	ifM (liftIO $ inPath cmd) 		( do 			let run = void $ liftIO $ forkIO $ do-				(Nothing, Nothing, Nothing, pid) <- createProcess p-				void $ waitForProcess pid+				withCreateProcess p $ \_ _ _ pid -> void $+					waitForProcess pid 			run #ifdef mingw32_HOST_OS 			{- On windows, if the file browser is not

@@ -14,7 +14,7 @@ import Assistant.WebApp.Notifications import qualified Remote import qualified Types.Remote as Remote-import Remote.List (remoteListRefresh)+import Remote.List.Util import Annex.UUID (getUUID) import Logs.Remote import Logs.Trust@@ -242,7 +242,7 @@ 			when (Remote.cost r /= newcost) $ do 				repo <- Remote.getRepo r 				setRemoteCost repo newcost-		void remoteListRefresh+		remotesChanged 	fromjs = fromMaybe (RepoUUID NoUUID) . readish . T.unpack  reorderCosts :: Remote -> [Remote] -> [(Remote, Cost)]

@@ -62,6 +62,9 @@ #ifdef WITH_MAGICMIME 	, "MagicMime" #endif+#ifdef DEBUGLOCKS+	, "DebugLocks"+#endif 	-- Always enabled now, but users may be used to seeing these flags 	-- listed. 	, "Feeds"@@ -89,7 +92,7 @@ #endif #ifdef WITH_WEBAPP 	, ("yesod", VERSION_yesod)-#endif +#endif #ifdef TOOL_VERSION_ghc 	, ("ghc", TOOL_VERSION_ghc) #endif

@@ -1,3 +1,66 @@+git-annex (8.20200617) upstream; urgency=medium++  * Added annex.skipunknown git config, that can be set to false to change+    the behavior of commands like `git annex get foo*`, to not skip+    over files/dirs that are not checked into git and are explicitly listed in+    the command line.+  * annex.skipunknown is planned to change to default to false in a+    git-annex release in early 2022. If you prefer the current behavior,+    you can explicitly set it to true.+  * Try to enable special remotes configured with autoenable=yes+    when git-annex auto-initialization happens in a new clone of an+    existing repo. Previously, git-annex init had to be explicitly run to+    enable them. Special remotes cannot display anything when autoenabled+    this way, to avoid interfering with the output of git-annex query+    commands.+  * export: Added options for json output.+  * import: Added --json-progress.+  * addurl: Make --preserve-filename also apply when eg a torrent contains+    multiple files.+  * Fix a crash or potentially not all files being exported when +    sync -J --content is used with an export remote.+  * export: Let concurrent transfers be done with -J or annex.jobs.+  * move --to, copy --to, mirror --to: When concurrency is enabled, run+    cleanup actions in separate job pool from uploads. +  * init: If lock probing stalls for a long time (eg a broken NFS server),+    display a message to let the user know what's taking so long.+  * init: When annex.pidlock is set, skip lock probing.+  * Fix file descriptor leak when importing from a directory special remote+    that is configured with exporttree=yes.+  * Note that external special remote programs should not block SIGINT or+    SIGTERM.+  * Avoid creating the keys database during init when there are no unlocked+    files, to prevent init failing when sqlite does not work in the+    filesystem.+  * import: Avoid using some strange names for temporary keys,+    which broke importing from a directory special remote onto a vfat+    filesystem.+  * S3: The REDUCED_REDUNDANCY storage class is no longer cheaper so+    stop documenting it, and stop offering it as a choice in the assistant.+  * Improve display of problems auto-initializing or upgrading local git+    remotes.+  * When a local git remote cannot be initialized because it has no+    git-annex branch or a .noannex file, avoid displaying a message about it.+  * checkpresentkey: When no remote is specified, try all remotes, not+    only ones that the location log says contain the key. This is what+    the documentation has always said it did.+  * Fix regression in external special remote handling: GETCONFIG did not+    return a value that was set with SETCONFIG immediately before.+    (Regression introduced in version 7.20200202.7)+  * Fix bug that made initremote of extrnal special remotes with+    embedcreds=yes or gpg encryption not store the creds in the git-annex+    branch. git-annex-remote-googledrive one was special remote affected by+    this bug.+    (Regression introduced in version 7.20200202.7)+  * Fix bug that made creds not be stored in git when a special remote+    was initialized with gpg encryption, but without an explicit+    embedcreds=yes.+    (Regression introduced in version 7.20200202.7)+  * Fix a annex.pidlock issue that made eg git-annex get of an unlocked+    file hang until the annex.pidlocktimeout and then fail.++ -- Joey Hess <id@joeyh.name>  Wed, 17 Jun 2020 15:58:59 -0400+ git-annex (8.20200522) upstream; urgency=medium    * Fix bug that made enableremote of S3 and webdav remotes, that

@@ -15,7 +15,7 @@ License: GPL-3+  Files: Remote/Ddar.hs-Copyright: © 2011 Joey Hess <id@joeyh.name>+Copyright: © 2011-2020 Joey Hess <id@joeyh.name>            © 2014 Robie Basak <robie@justgohome.co.uk> License: GPL-3+ 

@@ -14,7 +14,6 @@  import qualified Options.Applicative as O import qualified Options.Applicative.Help as H-import qualified Control.Exception as E import Control.Exception (throw)  import Annex.Common@@ -31,7 +30,7 @@ dispatch :: Bool -> CmdParams -> [Command] -> [GlobalOption] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progdesc = do 	setupConsole-	go =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo))+	go =<< tryNonAsync getgitrepo   where 	go (Right g) = do 		state <- Annex.new g

@@ -1,6 +1,6 @@ {- git-annex command-line actions and concurrency  -- - 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.  -}@@ -135,6 +135,15 @@ 				then return (spareVals pool) 				else retry 		mapM_ mergeState sts++{- Waits for all worker threads that have been started so far to finish. -}+waitForAllRunningCommandActions :: Annex ()+waitForAllRunningCommandActions = Annex.getState Annex.workers >>= \case+	Nothing -> noop+	Just tv -> liftIO $ atomically $ do+		pool <- readTMVar tv+		unless (allIdle pool)+			retry  {- Like commandAction, but without the concurrency. -} includeCommandAction :: CommandStart -> CommandCleanup

@@ -4,7 +4,7 @@  - the values a user passes to a command, and prepare actions operating  - on them.  -- - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -35,13 +35,13 @@ import qualified Database.Keys import qualified Utility.RawFilePath as R -withFilesInGit :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek-withFilesInGit a l = seekActions $ prepFiltered a $-	seekHelper LsFiles.inRepo l+withFilesInGit :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek+withFilesInGit ww a l = seekActions $ prepFiltered a $+	seekHelper ww LsFiles.inRepo l -withFilesInGitNonRecursive :: String -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek-withFilesInGitNonRecursive needforce a l = ifM (Annex.getState Annex.force)-	( withFilesInGit a l+withFilesInGitNonRecursive :: WarnUnmatchWhen -> String -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek+withFilesInGitNonRecursive ww needforce a l = ifM (Annex.getState Annex.force)+	( withFilesInGit ww a l 	, if null l 		then giveup needforce 		else seekActions $ prepFiltered a (getfiles [] l)@@ -49,7 +49,8 @@   where 	getfiles c [] = return (reverse c) 	getfiles c ((WorkTreeItem p):ps) = do-		(fs, cleanup) <- inRepo $ LsFiles.inRepo [toRawFilePath p]+		os <- seekOptions ww+		(fs, cleanup) <- inRepo $ LsFiles.inRepo os [toRawFilePath p] 		case fs of 			[f] -> do 				void $ liftIO $ cleanup@@ -66,7 +67,7 @@ 		force <- Annex.getState Annex.force 		g <- gitRepo 		liftIO $ Git.Command.leaveZombie-			<$> LsFiles.notInRepo force (map (\(WorkTreeItem f) -> toRawFilePath f) l) g+			<$> LsFiles.notInRepo [] force (map (\(WorkTreeItem f) -> toRawFilePath f) l) g 	go fs = seekActions $ prepFiltered a $ 		return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> toRawFilePath f) l) fs @@ -104,7 +105,7 @@  withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesToBeCommitted a l = seekActions $ prepFiltered a $-	seekHelper LsFiles.stagedNotDeleted l+	seekHelper WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l  isOldUnlocked :: RawFilePath -> Annex Bool isOldUnlocked f = liftIO (notSymlink f) <&&> @@ -112,12 +113,12 @@  {- unlocked pointer files that are staged, and whose content has not been  - modified-}-withUnmodifiedUnlockedPointers :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek-withUnmodifiedUnlockedPointers a l = seekActions $+withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek+withUnmodifiedUnlockedPointers ww a l = seekActions $ 	prepFiltered a unlockedfiles   where 	unlockedfiles = filterM isUnmodifiedUnlocked -		=<< seekHelper LsFiles.typeChangedStaged l+		=<< seekHelper ww (const LsFiles.typeChangedStaged) l  isUnmodifiedUnlocked :: RawFilePath -> Annex Bool isUnmodifiedUnlocked f = catKeyFile f >>= \case@@ -125,9 +126,9 @@ 	Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k  {- Finds files that may be modified. -}-withFilesMaybeModified :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek-withFilesMaybeModified a params = seekActions $-	prepFiltered a $ seekHelper LsFiles.modified params+withFilesMaybeModified :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek+withFilesMaybeModified ww a params = seekActions $+	prepFiltered a $ seekHelper ww LsFiles.modified params  withKeys :: (Key -> CommandSeek) -> CmdParams -> CommandSeek withKeys a l = seekActions $ return $ map (a . parse) l@@ -228,13 +229,25 @@ seekActions :: Annex [CommandSeek] -> Annex () seekActions gen = sequence_ =<< gen -seekHelper :: ([RawFilePath] -> Git.Repo -> IO ([RawFilePath], IO Bool)) -> [WorkTreeItem] -> Annex [RawFilePath]-seekHelper a l = inRepo $ \g ->-	concat . concat <$> forM (segmentXargsOrdered l')-		(runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) . map toRawFilePath)+seekHelper :: WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([RawFilePath], IO Bool)) -> [WorkTreeItem] -> Annex [RawFilePath]+seekHelper ww a l = do+	os <- seekOptions ww+	inRepo $ \g ->+		concat . concat <$> forM (segmentXargsOrdered l')+			(runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath)   where 	l' = map (\(WorkTreeItem f) -> f) l +data WarnUnmatchWhen = WarnUnmatchLsFiles | WarnUnmatchWorkTreeItems++seekOptions :: WarnUnmatchWhen -> Annex [LsFiles.Options]+seekOptions WarnUnmatchLsFiles =+	ifM (annexSkipUnknown <$> Annex.getGitConfig)+		( return [] +		, return [LsFiles.ErrorUnmatch]+		)+seekOptions WarnUnmatchWorkTreeItems = return []+ -- An item in the work tree, which may be a file or a directory. newtype WorkTreeItem = WorkTreeItem FilePath @@ -243,30 +256,42 @@ -- seeking for such files. newtype AllowHidden = AllowHidden Bool --- Many git commands like ls-files seek work tree items matching some criteria,--- and silently skip over anything that does not exist. But users expect--- an error message when one of the files they provided as a command-line--- parameter doesn't exist, so this checks that each exists.---+-- git ls-files without --error-unmatch seeks work tree items matching+-- some criteria, and silently skips over anything that does not exist.+ -- Also, when two directories are symlinked, referring to a file--- inside the symlinked directory will be silently skipped by git commands--- like ls-files. But, the user would be surprised for it to be skipped, so--- check if the parent directories are symlinks.-workTreeItems :: CmdParams -> Annex [WorkTreeItem]+-- inside the symlinked directory will be silently skipped by+-- git ls-files without --error-unmatch. +--+-- Sometimes a command needs to use git-lsfiles that way, perhaps repeatedly.+-- But users expect an error message when one of the files they provided+-- as a command-line parameter doesn't exist, so this checks that each+-- exists when run with WarnUnmatchWorkTreeItems.+--+-- Note that, unlike --error-unmatch, using this does not warn+-- about command-line parameters that exist, but are not checked into git.+workTreeItems :: WarnUnmatchWhen -> CmdParams -> Annex [WorkTreeItem] workTreeItems = workTreeItems' (AllowHidden False) -workTreeItems' :: AllowHidden -> CmdParams -> Annex [WorkTreeItem]-workTreeItems' (AllowHidden allowhidden) ps = do-	currbranch <- getCurrentBranch-	forM_ ps $ \p -> do-		relf <- liftIO $ relPathCwdToFile p-		ifM (not <$> (exists p <||> hidden currbranch relf))-			( prob (p ++ " not found")-			, whenM (viasymlink (upFrom relf)) $-				prob (p ++ " is beyond a symbolic link")-			)-	return (map (WorkTreeItem) ps)+workTreeItems' :: AllowHidden -> WarnUnmatchWhen -> CmdParams -> Annex [WorkTreeItem]+workTreeItems' (AllowHidden allowhidden) ww ps = do+	case ww of+		WarnUnmatchWorkTreeItems -> runcheck+		WarnUnmatchLsFiles -> +			whenM (annexSkipUnknown <$> Annex.getGitConfig)+				runcheck+	return (map WorkTreeItem ps)   where+	runcheck = do+		currbranch <- getCurrentBranch+		forM_ ps $ \p -> do+			relf <- liftIO $ relPathCwdToFile p+			ifM (not <$> (exists p <||> hidden currbranch relf))+				( prob (p ++ " not found")+				, whenM (viasymlink (upFrom relf)) $+					prob (p ++ " is beyond a symbolic link")+				)+	 	exists p = isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)  	viasymlink Nothing = return False

@@ -82,10 +82,15 @@ 				giveup "--update --batch is not supported" 			| otherwise -> batchFilesMatching fmt (gofile . toRawFilePath) 		NoBatch -> do-			l <- workTreeItems (addThese o)-			let go a = a (commandAction . gofile) l+			-- Avoid git ls-files complaining about files that+			-- are not known to git yet, since this will add+			-- them. Instead, have workTreeItems warn about other+			-- problems, like files that don't exist.+			let ww = WarnUnmatchWorkTreeItems+			l <- workTreeItems ww (addThese o)+			let go a = a ww (commandAction . gofile) l 			unless (updateOnly o) $-				go withFilesNotInGit+				go (const withFilesNotInGit) 			go withFilesMaybeModified 			go withUnmodifiedUnlockedPointers 

@@ -144,7 +144,7 @@ 		Nothing -> 			forM_ l $ \(u', sz, f) -> do 				f' <- sanitizeOrPreserveFilePath o f-				let f'' = adjustFile o (deffile </> sanitizeFilePath f')+				let f'' = adjustFile o (deffile </> f') 				void $ commandAction $ startRemote addunlockedmatcher r o f'' u' sz 		Just f -> case l of 			[] -> noop

@@ -9,6 +9,7 @@  import Command import qualified Remote+import Remote.List  cmd :: Command cmd = noCommit $ noMessages $@@ -46,8 +47,13 @@  check :: String -> Maybe Remote -> Annex Result check ks mr = case mr of-	Nothing -> go Nothing =<< Remote.keyPossibilities k 	Just r -> go Nothing [r]+	Nothing -> do+		mostlikely <- Remote.keyPossibilities k+		otherremotes <- flip Remote.remotesWithoutUUID +			(map Remote.uuid mostlikely)+			<$> remoteList+		go Nothing (mostlikely ++ otherremotes)   where 	k = toKey ks 	go Nothing [] = return NotPresent

@@ -51,8 +51,10 @@ 		NoBatch -> withKeyOptions 			(keyOptions o) (autoMode o) 			(commandAction . Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever)-			(withFilesInGit $ commandAction . go)-			=<< workTreeItems (copyFiles o)+			(withFilesInGit ww $ commandAction . go)+			=<< workTreeItems ww (copyFiles o)+  where+	ww = WarnUnmatchLsFiles  {- A copy is just a move that does not delete the source file.  - However, auto mode avoids unnecessary copies, and avoids getting or

@@ -52,15 +52,16 @@ 	)  seek :: DropOptions -> CommandSeek-seek o = startConcurrency transferStages $+seek o = startConcurrency commandStages $ 	case batchOption o of 		Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) 		NoBatch -> withKeyOptions (keyOptions o) (autoMode o) 			(commandAction . startKeys o)-			(withFilesInGit (commandAction . go))-			=<< workTreeItems (dropFiles o)+			(withFilesInGit ww (commandAction . go))+			=<< workTreeItems ww (dropFiles o)   where 	go = whenAnnexed $ start o+	ww = WarnUnmatchLsFiles  start :: DropOptions -> RawFilePath -> Key -> CommandStart start o file key = start' o key afile ai

@@ -44,9 +44,10 @@ import Control.Concurrent  cmd :: Command-cmd = command "export" SectionCommon-	"export content to a remote"-	paramTreeish (seek <$$> optParser)+cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption] $+	command "export" SectionCommon+		"export content to a remote"+		paramTreeish (seek <$$> optParser)  data ExportOptions = ExportOptions 	{ exportTreeish :: Git.Ref@@ -76,7 +77,7 @@ 	".git-annex-tmp-content-" ++ serializeKey (asKey (ek))  seek :: ExportOptions -> CommandSeek-seek o = do+seek o = startConcurrency commandStages $ do 	r <- getParsed (exportRemote o) 	unlessM (isExportSupported r) $ 		giveup "That remote does not support exports."@@ -135,6 +136,7 @@ 			(Git.DiffTree.file diff) 	forM_ (incompleteExportedTreeishes old) $ \incomplete -> 		mapdiff recover incomplete new+	waitForAllRunningCommandActions  	-- Diff the old and new trees, and delete or rename to new name all 	-- changed files in the export. After this, every file that remains@@ -157,12 +159,14 @@ 					(Just oldf, Nothing) -> 						startUnexport' r db oldf ek 					_ -> stop+			waitForAllRunningCommandActions 			-- Rename from temp to new files. 			seekdiffmap $ \(ek, (moldf, mnewf)) -> 				case (moldf, mnewf) of 					(Just _oldf, Just newf) -> 						startMoveFromTempName r db ek newf 					_ -> stop+			waitForAllRunningCommandActions 		ts -> do 			warning "Resolving export conflict.." 			forM_ ts $ \oldtreesha -> do@@ -180,6 +184,7 @@ 					(\diff -> commandAction $ startUnexport r db (Git.DiffTree.file diff) (unexportboth diff)) 					oldtreesha new 			updateExportTree db emptyTree new+			waitForAllRunningCommandActions 	liftIO $ recordExportTreeCurrent db new  	-- Waiting until now to record the export guarantees that,@@ -238,6 +243,7 @@ 	allfilledvar <- liftIO $ newMVar (AllFilled True) 	commandActions $ map (startExport r db cvar allfilledvar) l 	void $ liftIO $ cleanup+	waitForAllRunningCommandActions  	case mtbcommitsha of 		Nothing -> noop@@ -483,3 +489,4 @@ 					) 			-- Always export non-annexed files. 			Nothing -> return (Just ti)+

@@ -57,11 +57,12 @@ seek o = case batchOption o of 	NoBatch -> withKeyOptions (keyOptions o) False 		(commandAction . startKeys o)-		(withFilesInGit (commandAction . go))-		=<< workTreeItems (findThese o)+		(withFilesInGit ww (commandAction . go))+		=<< workTreeItems ww (findThese o) 	Batch fmt -> batchFilesMatching fmt (go . toRawFilePath)   where 	go = whenAnnexed $ start o+	ww = WarnUnmatchLsFiles  -- only files inAnnex are shown, unless the user has requested -- others via a limit

@@ -32,9 +32,11 @@  seek :: CmdParams -> CommandSeek seek ps = unlessM crippledFileSystem $ do -	withFilesInGit+	withFilesInGit ww 		(commandAction . (whenAnnexed $ start FixAll))-		=<< workTreeItems ps+		=<< workTreeItems ww ps+  where+	ww = WarnUnmatchLsFiles  data FixWhat = FixSymlinks | FixAll 

@@ -94,10 +94,12 @@ 	i <- prepIncremental u (incrementalOpt o) 	withKeyOptions (keyOptions o) False 		(\kai -> commandAction . startKey from i kai =<< getNumCopies)-		(withFilesInGit $ commandAction . (whenAnnexed (start from i)))-		=<< workTreeItems (fsckFiles o)+		(withFilesInGit ww $ commandAction . (whenAnnexed (start from i)))+		=<< workTreeItems ww (fsckFiles o) 	cleanupIncremental i 	void $ tryIO $ recordActivity Fsck u+  where+	ww = WarnUnmatchLsFiles  checkDeadRepo :: UUID -> Annex () checkDeadRepo u =

@@ -38,15 +38,17 @@ 	<*> parseBatchOption  seek :: GetOptions -> CommandSeek-seek o = startConcurrency transferStages $ do+seek o = startConcurrency downloadStages $ do 	from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) 	let go = whenAnnexed $ start o from 	case batchOption o of 		Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) 		NoBatch -> withKeyOptions (keyOptions o) (autoMode o) 			(commandAction . startKeys from)-			(withFilesInGit (commandAction . go))-			=<< workTreeItems (getFiles o)+			(withFilesInGit ww (commandAction . go))+			=<< workTreeItems ww (getFiles o)+  where+	ww = WarnUnmatchLsFiles  start :: GetOptions -> Maybe Remote -> RawFilePath -> Key -> CommandStart start o from file key = start' expensivecheck from key afile ai

@@ -38,7 +38,7 @@  cmd :: Command cmd = notBareRepo $-	withGlobalOptions [jobsOption, jsonOptions, fileMatchingOptions] $+	withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, fileMatchingOptions] $ 		command "import" SectionCommon  			"add a tree of files to the repository" 			(paramPaths ++ "|BRANCH[:SUBDIR]")

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -24,6 +24,7 @@ data InitOptions = InitOptions 	{ initDesc :: String 	, initVersion :: Maybe RepoVersion+	, autoEnableOnly :: Bool 	}  optParser :: CmdParamsDesc -> Parser InitOptions@@ -33,6 +34,10 @@ 		( long "version" <> metavar paramValue 		<> help "Override default annex.version" 		))+	<*> switch+		( long "autoenable"+		<> help "only enable special remotes configured with autoenable=true"+		)  parseRepoVersion :: MonadFail m => String -> m RepoVersion parseRepoVersion s = case RepoVersion <$> readish s of@@ -47,8 +52,11 @@ seek = commandAction . start  start :: InitOptions -> CommandStart-start os = starting "init" (ActionItemOther (Just $ initDesc os)) $-	perform os+start os+	| autoEnableOnly os = starting "init" (ActionItemOther (Just "autoenable")) $+		performAutoEnableOnly+	| otherwise = starting "init" (ActionItemOther (Just $ initDesc os)) $+		perform os  perform :: InitOptions -> CommandPerform perform os = do@@ -61,5 +69,10 @@ 	initialize 		(if null (initDesc os) then Nothing else Just (initDesc os)) 		(initVersion os)+	Annex.SpecialRemote.autoEnable+	next $ return True++performAutoEnableOnly :: CommandPerform+performAutoEnableOnly = do 	Annex.SpecialRemote.autoEnable 	next $ return True

@@ -38,9 +38,11 @@ 			| otherwise -> commandAction stop 		_ -> do 			let s = S.fromList ts-			withFilesInGit+			withFilesInGit ww 				(commandAction . (whenAnnexed (start s)))-				=<< workTreeItems (inprogressFiles o)+				=<< workTreeItems ww (inprogressFiles o)+  where+	ww = WarnUnmatchLsFiles  start :: S.Set Key -> RawFilePath -> Key -> CommandStart start s _file k

@@ -44,9 +44,10 @@ seek o = do 	list <- getList o 	printHeader list-	withFilesInGit-		(commandAction . (whenAnnexed $ start list))-		=<< workTreeItems (listThese o)+	withFilesInGit ww (commandAction . (whenAnnexed $ start list))+		=<< workTreeItems ww (listThese o)+  where+	ww = WarnUnmatchLsFiles  getList :: ListOptions -> Annex [(UUID, RemoteName, TrustLevel)] getList o

@@ -30,8 +30,10 @@  seek :: CmdParams -> CommandSeek seek ps = do-	l <- workTreeItems ps-	withFilesInGit (commandAction . (whenAnnexed startNew)) l+	l <- workTreeItems ww ps+	withFilesInGit ww (commandAction . (whenAnnexed startNew)) l+  where+	ww = WarnUnmatchLsFiles  startNew :: RawFilePath -> Key -> CommandStart startNew file key = ifM (isJust <$> isAnnexLink file)

@@ -86,11 +86,13 @@ 	zone <- liftIO getCurrentTimeZone 	let outputter = mkOutputter m zone o 	case (logFiles o, allOption o) of-		(fs, False) -> withFilesInGit+		(fs, False) -> withFilesInGit ww 			(commandAction . (whenAnnexed $ start o outputter)) -			=<< workTreeItems fs+			=<< workTreeItems ww fs 		([], True) -> commandAction (startAll o outputter) 		(_, True) -> giveup "Cannot specify both files and --all"+  where+	ww = WarnUnmatchLsFiles  start :: LogOptions -> (FilePath -> Outputter) -> RawFilePath -> Key -> CommandStart start o outputter file key = do

@@ -31,7 +31,7 @@ -- But, this plumbing command does not recurse through directories. seekSingleGitFile :: FilePath -> Annex (Maybe RawFilePath) seekSingleGitFile file = do-	(l, cleanup) <- inRepo (Git.LsFiles.inRepo [toRawFilePath file])+	(l, cleanup) <- inRepo (Git.LsFiles.inRepo [] [toRawFilePath file]) 	r <- case l of 		(f:[]) | takeFileName (fromRawFilePath f) == takeFileName file -> 			return (Just f)

@@ -223,10 +223,16 @@ 	| otherwise = liftIO $ safely $ Git.Config.read r   where 	pipedconfig st pcmd params = liftIO $ safely $-		withHandle StdoutHandle createProcessSuccess p $-			Git.Config.hRead r st+		withCreateProcess p (pipedconfig' st p) 	  where-		p = proc pcmd $ toCommand params+		p = (proc pcmd $ toCommand params)+			{ std_out = CreatePipe }++	pipedconfig' st p _ (Just h) _ pid = +		forceSuccessProcess p pid+			`after`+		Git.Config.hRead r st h+	pipedconfig' _ _ _ _ _ _ = error "internal"  	configlist = Ssh.onRemote NoConsumeStdin r 		(pipedconfig Git.Config.ConfigList, return Nothing) "configlist" [] []

@@ -75,15 +75,16 @@ seek o = case batchOption o of 	NoBatch -> do 		c <- liftIO currentVectorClock+		let ww = WarnUnmatchLsFiles 		let seeker = case getSet o of-			Get _ -> withFilesInGit-			GetAll -> withFilesInGit-			Set _ -> withFilesInGitNonRecursive+			Get _ -> withFilesInGit ww+			GetAll -> withFilesInGit ww+			Set _ -> withFilesInGitNonRecursive ww 				"Not recursively setting metadata. Use --force to do that." 		withKeyOptions (keyOptions o) False 			(commandAction . startKeys c o) 			(seeker (commandAction . (whenAnnexed (start c o))))-			=<< workTreeItems (forFiles o)+			=<< workTreeItems ww (forFiles o) 	Batch fmt -> withMessageState $ \s -> case outputType s of 		JSONOutput _ -> ifM limited 			( giveup "combining --batch with file matching options is not currently supported"

@@ -26,7 +26,10 @@ 		paramPaths (withParams seek)  seek :: CmdParams -> CommandSeek-seek = withFilesInGit (commandAction . (whenAnnexed start)) <=< workTreeItems+seek = withFilesInGit ww (commandAction . (whenAnnexed start))+	<=< workTreeItems ww+  where+	ww = WarnUnmatchLsFiles  start :: RawFilePath -> Key -> CommandStart start file key = do

@@ -41,11 +41,16 @@ 		<*> pure (keyOptions v)  seek :: MirrorOptions -> CommandSeek-seek o = startConcurrency transferStages $ +seek o = startConcurrency stages $  	withKeyOptions (keyOptions o) False 		(commandAction . startKey o (AssociatedFile Nothing))-		(withFilesInGit (commandAction . (whenAnnexed $ start o)))-		=<< workTreeItems (mirrorFiles o)+		(withFilesInGit ww (commandAction . (whenAnnexed $ start o)))+		=<< workTreeItems ww (mirrorFiles o)+  where+	stages = case fromToOptions o of+		FromRemote _ -> downloadStages+		ToRemote _ -> commandStages+	ww = WarnUnmatchLsFiles  start :: MirrorOptions -> RawFilePath -> Key -> CommandStart start o file k = startKey o afile (k, ai)

@@ -54,14 +54,20 @@ 	deriving (Show, Eq)  seek :: MoveOptions -> CommandSeek-seek o = startConcurrency transferStages $ do+seek o = startConcurrency stages $ do 	let go = whenAnnexed $ start (fromToOptions o) (removeWhen o) 	case batchOption o of 		Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) 		NoBatch -> withKeyOptions (keyOptions o) False 			(commandAction . startKey (fromToOptions o) (removeWhen o))-			(withFilesInGit (commandAction . go))-			=<< workTreeItems (moveFiles o)+			(withFilesInGit ww (commandAction . go))+			=<< workTreeItems ww (moveFiles o)+  where+	stages = case fromToOptions o of+		Right (FromRemote _) -> downloadStages+		Right (ToRemote _) -> commandStages+		Left ToHere -> downloadStages+	ww = WarnUnmatchLsFiles  start :: FromToHereOptions -> RemoveWhen -> RawFilePath -> Key -> CommandStart start fromto removewhen f k = start' fromto removewhen afile k ai

@@ -129,7 +129,9 @@ 	-- expensive. 	starting "sending files" (ActionItemOther Nothing) $ 		withTmpFile "send" $ \t h -> do-			fs' <- seekHelper LsFiles.inRepo =<< workTreeItems fs+			let ww = WarnUnmatchLsFiles+			fs' <- seekHelper ww LsFiles.inRepo+				=<< workTreeItems ww fs 			matcher <- Limit.getMatcher 			let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $ 				liftIO $ hPutStrLn h o

@@ -32,7 +32,8 @@  seek :: CmdParams -> CommandSeek seek ps = do-	l <- workTreeItems ps+	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)

@@ -65,6 +65,7 @@ import Annex.Export import Annex.TaggedPush import Annex.CurrentBranch+import Annex.GitOverlay import qualified Database.Export as Export import Utility.Bloom import Utility.OptParse@@ -194,7 +195,7 @@ seek :: SyncOptions -> CommandSeek seek o = do 	prepMerge-	startConcurrency transferStages (seek' o)+	startConcurrency downloadStages (seek' o) 	 seek' :: SyncOptions -> CommandSeek seek' o = do@@ -513,7 +514,7 @@ 	postpushupdate repo = case Git.repoWorkTree repo of 		Nothing -> return True 		Just wt -> ifM needemulation-			( liftIO $ do+			( runsGitAnnexChildProcess $ liftIO $ do 				p <- programPath 				boolSystem' p [Param "post-receive"] 					(\cp -> cp { cwd = Just (fromRawFilePath wt) })@@ -636,27 +637,29 @@ 		Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar []) 		_ -> case currbranch of                 	(Just origbranch, Just adj) | adjustmentHidesFiles adj -> do-				l <- workTreeItems' (AllowHidden True) (contentOfOption o)+				l <- workTreeItems' (AllowHidden True) ww (contentOfOption o) 				seekincludinghidden origbranch mvar l (const noop) 				pure Nothing 			_ -> do-				l <- workTreeItems (contentOfOption o)+				l <- workTreeItems ww (contentOfOption o) 				seekworktree mvar l (const noop) 				pure Nothing 	withKeyOptions' (keyOptions o) False 		(return (gokey mvar bloom)) 		(const noop) 		[]-	finishCommandActions+	waitForAllRunningCommandActions 	liftIO $ not <$> isEmptyMVar mvar   where 	seekworktree mvar l bloomfeeder = -		seekHelper LsFiles.inRepo l+		seekHelper ww LsFiles.inRepo l 			>>= gofiles bloomfeeder mvar  	seekincludinghidden origbranch mvar l bloomfeeder = -		seekHelper (LsFiles.inRepoOrBranch origbranch) l +		seekHelper ww (LsFiles.inRepoOrBranch origbranch) l  			>>= gofiles bloomfeeder mvar++	ww = WarnUnmatchLsFiles  	gofiles bloomfeeder mvar = mapM_ $ \f -> 		ifAnnexed f

@@ -23,7 +23,10 @@ 		paramPaths (withParams seek)  seek :: CmdParams -> CommandSeek-seek ps = (withFilesInGit $ commandAction . whenAnnexed start) =<< workTreeItems ps+seek ps = (withFilesInGit ww $ commandAction . whenAnnexed start)+	=<< workTreeItems ww ps+  where+	ww = WarnUnmatchLsFiles  start :: RawFilePath -> Key -> CommandStart start file key = stopUnless (inAnnex key) $

@@ -27,7 +27,7 @@ seek ps = do 	-- Safety first; avoid any undo that would touch files that are not 	-- in the index.-	(fs, cleanup) <- inRepo $ LsFiles.notInRepo False (map toRawFilePath ps)+	(fs, cleanup) <- inRepo $ LsFiles.notInRepo [] False (map toRawFilePath ps) 	unless (null fs) $ 		giveup $ "Cannot undo changes to files that are not checked into git: " ++ unwords (map fromRawFilePath fs) 	void $ liftIO $ cleanup

@@ -41,11 +41,13 @@  seek :: CmdParams -> CommandSeek seek ps = do-	l <- workTreeItems ps+	l <- workTreeItems ww ps 	withFilesNotInGit (commandAction . whenAnnexed (startCheckIncomplete . fromRawFilePath)) l 	Annex.changeState $ \s -> s { Annex.fast = True }-	withFilesInGit (commandAction . whenAnnexed Command.Unannex.start) l+	withFilesInGit ww (commandAction . whenAnnexed Command.Unannex.start) l 	finish+  where+	ww = WarnUnmatchLsFiles  {- git annex symlinks that are not checked into git could be left by an  - interrupted add. -}

@@ -27,7 +27,10 @@ 	command n SectionCommon d paramPaths (withParams seek)  seek :: CmdParams -> CommandSeek-seek ps = withFilesInGit (commandAction . whenAnnexed start) =<< workTreeItems ps+seek ps = withFilesInGit ww (commandAction . whenAnnexed start)+	=<< workTreeItems ww ps+  where+	ww = WarnUnmatchLsFiles  start :: RawFilePath -> Key -> CommandStart start file key = ifM (isJust <$> isAnnexLink file)

@@ -210,9 +210,9 @@ 			( return ([], return True) 			, do 				top <- fromRepo Git.repoPath-				inRepo $ LsFiles.allFiles [top]+				inRepo $ LsFiles.allFiles [] [top] 			)-		Just dir -> inRepo $ LsFiles.inRepo [toRawFilePath dir]+		Just dir -> inRepo $ LsFiles.inRepo [] [toRawFilePath dir] 	go v [] = return v 	go v (f:fs) = do 		mk <- lookupFile f

@@ -101,7 +101,7 @@ 		 - removed.) -} 		top <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath 		(l, cleanup) <- inRepo $-			LsFiles.notInRepoIncludingEmptyDirectories False+			LsFiles.notInRepoIncludingEmptyDirectories [] False 				[toRawFilePath top] 		forM_ l (removeemptydir top) 		liftIO $ void cleanup

@@ -220,14 +220,15 @@ 		hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url 		hFlush stdout 		environ <- cleanEnvironment-		(_, _, _, pid) <- createProcess p+		let p' = p 			{ env = environ 			, std_out = maybe Inherit UseHandle outh 			, std_err = maybe Inherit UseHandle errh 			}-		exitcode <- waitForProcess pid-		unless (exitcode == ExitSuccess) $-			hPutStrLn (fromMaybe stderr errh) "failed to start web browser"+		withCreateProcess p' $ \_ _ _ pid -> do+			exitcode <- waitForProcess pid+			unless (exitcode == ExitSuccess) $+				hPutStrLn (fromMaybe stderr errh) "failed to start web browser"  {- web.browser is a generic git config setting for a web browser program -} webBrowser :: Git.Repo -> Maybe FilePath

@@ -57,8 +57,10 @@ 		NoBatch ->  			withKeyOptions (keyOptions o) False 				(commandAction . startKeys o m)-				(withFilesInGit (commandAction . go))-				=<< workTreeItems (whereisFiles o)+				(withFilesInGit ww (commandAction . go))+				=<< workTreeItems ww (whereisFiles o)+  where+	ww = WarnUnmatchLsFiles  start :: WhereisOptions -> M.Map UUID Remote -> RawFilePath -> Key -> CommandStart start o remotemap file key = 

@@ -35,6 +35,7 @@ import Utility.Env (getEnv)  import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as S import qualified Data.Map as M import Utility.Base64 @@ -56,20 +57,25 @@  - if that's going to be done, so that the creds can be encrypted using the  - cipher. The EncryptionIsSetup is witness to that being the case.  -}-setRemoteCredPair :: EncryptionIsSetup -> ParsedRemoteConfig -> RemoteGitConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig-setRemoteCredPair encsetup pc = setRemoteCredPair' id (const pc) encsetup (unparsedRemoteConfig pc)+setRemoteCredPair+	:: EncryptionIsSetup+	-> ParsedRemoteConfig+	-> RemoteGitConfig+	-> CredPairStorage+	-> Maybe CredPair+	-> Annex RemoteConfig+setRemoteCredPair encsetup pc gc storage mcreds = unparsedRemoteConfig <$>+	setRemoteCredPair' pc encsetup gc storage mcreds  setRemoteCredPair'-	:: (ProposedAccepted String -> a)-	-> (M.Map RemoteConfigField a -> ParsedRemoteConfig)+	:: ParsedRemoteConfig 	-> EncryptionIsSetup-	-> M.Map RemoteConfigField a 	-> RemoteGitConfig 	-> CredPairStorage 	-> Maybe CredPair-	-> Annex (M.Map RemoteConfigField a)-setRemoteCredPair' mkval parseconfig encsetup c gc storage mcreds = case mcreds of-	Nothing -> maybe (return c) (setRemoteCredPair' mkval parseconfig encsetup c gc storage . Just)+	-> Annex ParsedRemoteConfig+setRemoteCredPair' pc encsetup gc storage mcreds = case mcreds of+	Nothing -> maybe (return pc) (setRemoteCredPair' pc encsetup gc storage . Just) 		=<< getRemoteCredPair pc gc storage 	Just creds 		| embedCreds pc -> do@@ -78,7 +84,7 @@ 			storeconfig creds key =<< remoteCipher pc gc 		| otherwise -> do 			localcache creds-			return c+			return pc   where 	localcache creds = writeCacheCredPair creds storage @@ -86,12 +92,15 @@ 		cmd <- gpgCmd <$> Annex.getGitConfig 		s <- liftIO $ encrypt cmd (pc, gc) cipher 			(feedBytes $ L.pack $ encodeCredPair creds)-			(readBytes $ return . L.unpack)-		return $ M.insert key (mkval (Accepted (toB64 s))) c+			(readBytesStrictly $ return . S.unpack)+		storeconfig' key (Accepted (toB64 s)) 	storeconfig creds key Nothing =-		return $ M.insert key (mkval (Accepted (toB64 $ encodeCredPair creds))) c+		storeconfig' key (Accepted (toB64 $ encodeCredPair creds)) 	-	pc = parseconfig c+	storeconfig' key val = return $ pc+		{ parsedRemoteConfigMap = M.insert key (RemoteConfigValue val) (parsedRemoteConfigMap pc)+		, unparsedRemoteConfig = M.insert key val (unparsedRemoteConfig pc)+		}  {- Gets a remote's credpair, from the environment if set, otherwise  - from the cache in gitAnnexCredsDir, or failing that, from the@@ -104,7 +113,12 @@ 	fromconfig = do 		let key = credPairRemoteField storage 		mcipher <- remoteCipher' c gc-		case (getRemoteConfigValue key c, mcipher) of+		-- The RemoteConfig value may be passed through.+		-- Check for those first, because getRemoteConfigValue+		-- will throw an error if it does not find it.+		let getval = M.lookup key (getRemoteConfigPassedThrough c)+			<|> getRemoteConfigValue key c			+		case (getval, mcipher) of 			(Nothing, _) -> return Nothing 			(Just enccreds, Just (cipher, storablecipher)) -> 				fromenccreds enccreds cipher storablecipher@@ -114,7 +128,7 @@ 		cmd <- gpgCmd <$> Annex.getGitConfig 		mcreds <- liftIO $ catchMaybeIO $ decrypt cmd (c, gc) cipher 			(feedBytes $ L.pack $ fromB64 enccreds)-			(readBytes $ return . L.unpack)+			(readBytesStrictly $ return . S.unpack) 		case mcreds of 			Just creds -> fromcreds creds 			Nothing -> do

@@ -28,6 +28,7 @@ 	feedFile, 	feedBytes, 	readBytes,+	readBytesStrictly, 	encrypt, 	decrypt, 	LensGpgEncParams(..),@@ -187,25 +188,35 @@ readBytes :: (MonadIO m) => (L.ByteString -> m a) -> Reader m a readBytes a h = liftIO (L.hGetContents h) >>= a +readBytesStrictly :: (MonadIO m) => (S.ByteString -> m a) -> Reader m a+readBytesStrictly a h = liftIO (S.hGetContents h) >>= a++ {- Runs a Feeder action, that generates content that is symmetrically  - encrypted with the Cipher (unless it is empty, in which case  - public-key encryption is used) using the given gpg options, and then- - read by the Reader action. -}+ - read by the Reader action. + -+ - Note that the Reader must fully consume gpg's input before returning.+ -} encrypt :: (MonadIO m, MonadMask m, LensGpgEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a encrypt cmd c cipher = case cipher of 	Cipher{} -> Gpg.feedRead cmd (params ++ Gpg.stdEncryptionParams True) $ 			cipherPassphrase cipher-	MacOnlyCipher{} -> Gpg.pipeLazy cmd $ params ++ Gpg.stdEncryptionParams False+	MacOnlyCipher{} -> Gpg.feedRead' cmd $ params ++ Gpg.stdEncryptionParams False   where 	params = getGpgEncParams c  {- Runs a Feeder action, that generates content that is decrypted with the  - Cipher (or using a private key if the Cipher is empty), and read by the- - Reader action. -}+ - Reader action.+ -+ - Note that the Reader must fully consume gpg's input before returning.+ - -} decrypt :: (MonadIO m, MonadMask m, LensGpgEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a decrypt cmd c cipher = case cipher of 	Cipher{} -> Gpg.feedRead cmd params $ cipherPassphrase cipher-	MacOnlyCipher{} -> Gpg.pipeLazy cmd params+	MacOnlyCipher{} -> Gpg.feedRead' cmd params   where 	params = Param "--decrypt" : getGpgDecParams c 

@@ -180,14 +180,16 @@ 			, std_in = Inherit 			, std_out = CreatePipe 			}-		pid <- createProcess p'-		let h = stdoutHandle pid-		output <- reader h-		hClose h-		ifM (checkSuccessProcess (processHandle pid))+		withCreateProcess p' go+  where+	go _ (Just outh) _ pid = do+		output <- reader outh+		hClose outh+		ifM (checkSuccessProcess pid) 			( return (Just output) 			, return Nothing 			)+	go _ _ _ _ = error "internal"  querySize :: Ref -> Repo -> IO (Maybe FileSize) querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n'))

@@ -1,6 +1,6 @@ {- running git commands  -- - Copyright 2010-2013 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -43,9 +43,13 @@  {- Runs git and forces it to be quiet, throwing an error if it fails. -} runQuiet :: [CommandParam] -> Repo -> IO ()-runQuiet params repo = withQuietOutput createProcessSuccess $-	(proc "git" $ toCommand $ gitCommandLine (params) repo)-		{ env = gitEnv repo }+runQuiet params repo = withNullHandle $ \nullh ->+	let p = (proc "git" $ toCommand $ gitCommandLine (params) repo)+		{ env = gitEnv repo+		, std_out = UseHandle nullh+		, std_err = UseHandle nullh+		}+	in withCreateProcess p $ \_ _ _ -> forceSuccessProcess p  {- Runs a git command and returns its output, lazily.  -@@ -70,14 +74,18 @@  {- The reader action must be strict. -} pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a-pipeReadStrict' reader params repo = assertLocal repo $-	withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do-		output <- reader h-		hClose h-		return output+pipeReadStrict' reader params repo = assertLocal repo $ withCreateProcess p go   where-	p  = gitCreateProcess params repo+	p  = (gitCreateProcess params repo)+		{ std_out = CreatePipe } +	go _ (Just outh) _ pid = do+		output <- reader outh+		hClose outh+		void $ waitForProcess pid+		return output+	go _ _ _ _ = error "internal"+ {- Runs a git command, feeding it an input, and returning its output,  - which is expected to be fairly small, since it's all read into memory  - strictly. -}@@ -95,9 +103,16 @@  {- Runs a git command, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO ()-pipeWrite params repo = assertLocal repo $ -	withHandle StdinHandle createProcessSuccess $-		gitCreateProcess params repo+pipeWrite params repo feeder = assertLocal repo $+	let p = (gitCreateProcess params repo)+		{ std_in = CreatePipe }+	in withCreateProcess p (go p)+  where+	go p (Just hin) _ _ pid = do+		feeder hin+		hClose hin+		forceSuccessProcess p pid+	go _ _ _ _ _ = error "internal"  {- Reads null terminated output of a git command (as enabled by the -z   - parameter), and splits it. -}

@@ -58,29 +58,37 @@ 	go Repo { location = Local { gitdir = d } } = git_config d 	go Repo { location = LocalUnknown d } = git_config d 	go _ = assertLocal repo $ error "internal"-	git_config d = withHandle StdoutHandle createProcessSuccess p $-		hRead repo ConfigNullList+	git_config d = withCreateProcess p (git_config' p) 	  where 		params = ["config", "--null", "--list"] 		p = (proc "git" params) 			{ cwd = Just (fromRawFilePath d) 			, env = gitEnv repo+			, std_out = CreatePipe  			}+	git_config' p _ (Just hout) _ pid = +		forceSuccessProcess p pid+			`after`+		hRead repo ConfigNullList hout+	git_config' _ _ _ _ _ = error "internal"  {- Gets the global git config, returning a dummy Repo containing it. -} global :: IO (Maybe Repo) global = do 	home <- myHomeDir 	ifM (doesFileExist $ home </> ".gitconfig")-		( do-			repo <- withHandle StdoutHandle createProcessSuccess p $-				hRead (Git.Construct.fromUnknown) ConfigNullList-			return $ Just repo+		( Just <$> withCreateProcess p go 		, return Nothing 		)   where 	params = ["config", "--null", "--list", "--global"] 	p = (proc "git" params)+		{ std_out = CreatePipe }+	go _ (Just hout) _ pid = +		forceSuccessProcess p pid+			`after`+		hRead (Git.Construct.fromUnknown) ConfigNullList hout+	go _ _ _ _ = error "internal"  {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> ConfigStyle -> Handle -> IO Repo@@ -200,16 +208,20 @@  - and returns a repo populated with the configuration, as well as the raw  - output and any standard output of the command. -} fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString))-fromPipe r cmd params st = try $-	withOEHandles createProcessSuccess p $ \(hout, herr) -> do-		geterr <- async $ S.hGetContents herr-		getval <- async $ S.hGetContents hout-		val <- wait getval-		err <- wait geterr+fromPipe r cmd params st = tryNonAsync $ withCreateProcess p go+  where+	p = (proc cmd $ toCommand params)+		{ std_out = CreatePipe+		, std_err = CreatePipe+		}+	go _ (Just hout) (Just herr) pid = do+		(val, err) <- concurrently +			(S.hGetContents hout)+			(S.hGetContents herr)+		forceSuccessProcess p pid 		r' <- store val st r 		return (r', val, err)-  where-	p = proc cmd $ toCommand params+	go _ _ _ _ = error "internal"  {- Reads git config from a specified file and returns the repo populated  - with the configuration. -}

@@ -77,27 +77,31 @@ 		then toBatchCommand (command, params) 		else return (command, params) 	-	p@(_, _, _, pid) <- createProcess $-		(proc command' (toCommand params'))-			{ std_out = CreatePipe-			, std_err = CreatePipe-			}-	(o1, o2) <- concurrently-		(parseFsckOutput maxobjs r (stdoutHandle p))-		(parseFsckOutput maxobjs r (stderrHandle p))-	fsckok <- checkSuccessProcess pid-	case mappend o1 o2 of-		FsckOutput badobjs truncated-			| S.null badobjs && not fsckok -> return FsckFailed-			| otherwise -> return $ FsckFoundMissing badobjs truncated-		NoFsckOutput-			| not fsckok -> return FsckFailed-			| otherwise -> return noproblem-		-- If all fsck output was duplicateEntries warnings,-		-- the repository is not broken, it just has some unusual-		-- tree objects in it. So ignore nonzero exit status.-		AllDuplicateEntriesWarning -> return noproblem+	let p = (proc command' (toCommand params'))+		{ std_out = CreatePipe+		, std_err = CreatePipe+		}+	withCreateProcess p go   where+	go _ (Just outh) (Just errh) pid = do+		(o1, o2) <- concurrently+			(parseFsckOutput maxobjs r outh)+			(parseFsckOutput maxobjs r errh)+		fsckok <- checkSuccessProcess pid+		case mappend o1 o2 of+			FsckOutput badobjs truncated+				| S.null badobjs && not fsckok -> return FsckFailed+				| otherwise -> return $ FsckFoundMissing badobjs truncated+			NoFsckOutput+				| not fsckok -> return FsckFailed+				| otherwise -> return noproblem+			-- If all fsck output was duplicateEntries warnings,+			-- the repository is not broken, it just has some+			-- unusual tree objects in it. So ignore nonzero+			-- exit status.+			AllDuplicateEntriesWarning -> return noproblem+	go _ _ _ _ = error "internal"+	 	maxobjs = 10000 	noproblem = FsckFoundMissing S.empty False 

@@ -66,12 +66,12 @@ 		, Param "--check" 		, Param loc 		] baserepo-	(_, _, _, pid) <- createProcess p-	code <- waitForProcess pid-	return $ case code of-		ExitSuccess -> Decryptable-		ExitFailure 1 -> NotDecryptable-		ExitFailure _ -> NotEncrypted+	withCreateProcess p $ \_ _ _ pid -> do+		code <- waitForProcess pid+		return $ case code of+			ExitSuccess -> Decryptable+			ExitFailure 1 -> NotDecryptable+			ExitFailure _ -> NotEncrypted  type GCryptId = String 

@@ -50,19 +50,22 @@ {- Gets a History starting with the provided commit, and down to the  - requested depth. -} getHistoryToDepth :: Integer -> Ref -> Repo -> IO (Maybe (History HistoryCommit))-getHistoryToDepth n commit r = do-	(_, Just inh, _, pid) <- createProcess (gitCreateProcess params r)-		{ std_out = CreatePipe }-	!h <- fmap (truncateHistoryToDepth n) -		. build Nothing -		. map parsehistorycommit-		. map L.toStrict-		. L8.lines-		<$> L.hGetContents inh-	hClose inh-	void $ waitForProcess pid-	return h+getHistoryToDepth n commit r = withCreateProcess p go   where+	p = (gitCreateProcess params r)+		{ std_out = CreatePipe }+	go _ (Just inh) _ pid = do+		!h <- fmap (truncateHistoryToDepth n) +			. build Nothing +			. map parsehistorycommit+			. map L.toStrict+			. L8.lines+			<$> L.hGetContents inh+		hClose inh+		void $ waitForProcess pid+		return h+	go _ _ _ _ = error "internal"+ 	build h [] = fmap (mapHistory fst) h 	build _ (Nothing:_) = Nothing 	build Nothing (Just v:rest) =

@@ -1,11 +1,12 @@ {- git ls-files interface  -- - 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.  -}  module Git.LsFiles (+	Options(..), 	inRepo, 	inRepoOrBranch, 	notInRepo,@@ -13,10 +14,8 @@ 	allFiles, 	deleted, 	modified,-	modifiedOthers, 	staged, 	stagedNotDeleted,-	stagedOthersDetails, 	stagedDetails, 	typeChanged, 	typeChangedStaged,@@ -63,101 +62,63 @@ 	| safeForLsFiles r = a 	| otherwise = error $ "git ls-files is unsafe to run on repository " ++ repoDescribe r +data Options = ErrorUnmatch+ {- Lists files that are checked into git's index at the specified paths.  - With no paths, all files are listed.  -}-inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-inRepo = inRepo' [] +inRepo :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+inRepo = inRepo' [Param "--cached"]  -inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-inRepo' ps l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo+inRepo' :: [CommandParam] -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+inRepo' ps os l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo   where 	params =  		Param "ls-files" :-		Param "--cached" : 		Param "-z" :-		ps +++		map op os ++ ps ++ 		(Param "--" : map (File . fromRawFilePath) l)+	op ErrorUnmatch = Param "--error-unmatch"   {- Files that are checked into the index or have been committed to a  - branch. -}-inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-inRepoOrBranch b = inRepo' [Param $ "--with-tree=" ++ fromRef b]+inRepoOrBranch :: Branch -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+inRepoOrBranch b = inRepo'+	[ Param "--cached"+	, Param ("--with-tree=" ++ fromRef b)+	]  {- Scans for files at the specified locations that are not checked into git. -}-notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+notInRepo :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepo = notInRepo' [] -notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-notInRepo' ps include_ignored l repo = guardSafeForLsFiles repo $-	pipeNullSplit' params repo+notInRepo' :: [CommandParam] -> [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+notInRepo' ps os include_ignored = +	inRepo' (Param "--others" : ps ++ exclude) os   where-	params = concat-		[ [ Param "ls-files", Param "--others"]-		, ps-		, exclude-		, [ Param "-z", Param "--" ]-		, map (File . fromRawFilePath) l-		] 	exclude 		| include_ignored = [] 		| otherwise = [Param "--exclude-standard"]  {- Scans for files at the specified locations that are not checked into  - git. Empty directories are included in the result. -}-notInRepoIncludingEmptyDirectories :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+notInRepoIncludingEmptyDirectories :: [Options] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"]  {- Finds all files in the specified locations, whether checked into git or  - not. -}-allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-allFiles l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo-  where-	params =-		Param "ls-files" :-		Param "--cached" :-		Param "--others" :-		Param "-z" :-		Param "--" :-		map (File . fromRawFilePath) l+allFiles :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+allFiles = inRepo' [Param "--cached", Param "--others"]  {- Returns a list of files in the specified locations that have been  - deleted. -}-deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-deleted l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo-  where-	params =-		Param "ls-files" :-		Param "--deleted" :-		Param "-z" :-		Param "--" :-		map (File . fromRawFilePath) l+deleted :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+deleted = inRepo' [Param "--deleted"]  {- Returns a list of files in the specified locations that have been  - modified. -}-modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-modified l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo-  where-	params = -		Param "ls-files" :-		Param "--modified" :-		Param "-z" :-		Param "--" :-		map (File . fromRawFilePath) l--{- Files that have been modified or are not checked into git (and are not- - ignored). -}-modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)-modifiedOthers l repo = guardSafeForLsFiles repo $ pipeNullSplit' params repo-  where-	params = -		Param "ls-files" :-		Param "--modified" :-		Param "--others" :-		Param "--exclude-standard" :-		Param "-z" :-		Param "--" :-		map (File . fromRawFilePath) l+modified :: [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+modified = inRepo' [Param "--modified"]  {- Returns a list of all files that are staged for commit. -} staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)@@ -176,11 +137,6 @@ 	suffix = Param "--" : map (File . fromRawFilePath) l  type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode)--{- Returns details about files that are staged in the index,- - as well as files not yet in git. Skips ignored files. -}-stagedOthersDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)-stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"]  {- Returns details about all files that are staged in the index. -} stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool)

@@ -191,10 +191,11 @@ 	liftIO $ Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers runAction repo action@(CommandAction {}) = liftIO $ do #ifndef mingw32_HOST_OS-	let p = (proc "xargs" $ "-0":"git":toCommand gitparams) { env = gitEnv repo }-	withHandle StdinHandle createProcessSuccess p $ \h -> do-		hPutStr h $ intercalate "\0" $ toCommand $ getFiles action-		hClose h+	let p = (proc "xargs" $ "-0":"git":toCommand gitparams)+		{ env = gitEnv repo+		, std_in = CreatePipe+		}+	withCreateProcess p (go p) #else 	-- Using xargs on Windows is problematic, so just run the command 	-- once per file (not as efficient.)@@ -206,6 +207,11 @@   where 	gitparams = gitCommandLine 		(Param (getSubcommand action):getParams action) repo+	go p (Just h) _ _ pid = do+		hPutStr h $ intercalate "\0" $ toCommand $ getFiles action+		hClose h+		forceSuccessProcess p pid+	go _ _ _ _ _ = error "internal" runAction repo action@(InternalAction {}) = 	let InternalActionRunner _ runner = getRunner action 	in runner repo (getInternalFiles action)

@@ -1,6 +1,6 @@ {- git-update-index library  -- - 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.  -}@@ -12,8 +12,7 @@ 	pureStreamer, 	streamUpdateIndex, 	streamUpdateIndex',-	startUpdateIndex,-	stopUpdateIndex,+	withUpdateIndex, 	lsTree, 	lsSubTree, 	updateIndexLine,@@ -33,6 +32,7 @@ import qualified Git.DiffTreeItem as Diff  import qualified Data.ByteString.Lazy as L+import Control.Monad.IO.Class  {- Streamers are passed a callback and should feed it lines in the form  - read by update-index, and generated by ls-tree. -}@@ -44,28 +44,32 @@  {- Streams content into update-index from a list of Streamers. -} streamUpdateIndex :: Repo -> [Streamer] -> IO ()-streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $-	(\h -> forM_ as $ streamUpdateIndex' h)+streamUpdateIndex repo as = withUpdateIndex repo $ \h ->+	forM_ as $ streamUpdateIndex' h -data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle+data UpdateIndexHandle = UpdateIndexHandle Handle  streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()-streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do+streamUpdateIndex' (UpdateIndexHandle h) a = a $ \s -> do 	L.hPutStr h s 	L.hPutStr h "\0" -startUpdateIndex :: Repo -> IO UpdateIndexHandle-startUpdateIndex repo = do-	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)-		{ std_in = CreatePipe }-	return $ UpdateIndexHandle p h+withUpdateIndex :: (MonadIO m, MonadMask m) => Repo -> (UpdateIndexHandle -> m a) -> m a+withUpdateIndex repo a = bracket setup cleanup go   where 	params = map Param ["update-index", "-z", "--index-info"]--stopUpdateIndex :: UpdateIndexHandle -> IO Bool-stopUpdateIndex (UpdateIndexHandle p h) = do-	hClose h-	checkSuccessProcess p+	+	setup = liftIO $ createProcess $ +		(gitCreateProcess params repo)+			{ std_in = CreatePipe }+	go p = do+		r <- a (UpdateIndexHandle (stdinHandle p))+		liftIO $ do+			hClose (stdinHandle p)+			void $ checkSuccessProcess (processHandle p)+		return r+	+	cleanup = liftIO . cleanupProcess  {- A streamer that adds the current tree for a ref. Useful for eg, copying  - and modifying branches. -}@@ -132,15 +136,7 @@  {- Refreshes the index, by checking file stat information.  -} refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool-refreshIndex repo feeder = do-	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)-		{ std_in = CreatePipe }-	feeder $ \f -> do-		hPutStr h f-		hPutStr h "\0"-	hFlush h-	hClose h-	checkSuccessProcess p+refreshIndex repo feeder = withCreateProcess p go   where 	params =  		[ Param "update-index"@@ -149,3 +145,15 @@ 		, Param "-z" 		, Param "--stdin" 		]+	+	p = (gitCreateProcess params repo)+		{ std_in = CreatePipe }++	go (Just h) _ _ pid = do+		feeder $ \f -> do+			hPutStr h f+			hPutStr h "\0"+		hFlush h+		hClose h+		checkSuccessProcess pid+	go _ _ _ _ = error "internal"

@@ -1,3 +1,14 @@+git-annex (8.20200523) UNRELEASED; 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+  cases, the behavior will change to erroring out when one of the listed+  files is not checked into git. This change is planned for a git-annex+  release in early 2022. If you would like to keep the current+  behavior, use git config to set annex.skipunknown to true.++ -- Joey Hess <id@joeyh.name>  Thu, 28 May 2020 13:23:40 -0400+ git-annex (8.20200226) upstream; urgency=medium      This version of git-annex uses repository version 8 for all repositories.

@@ -272,19 +272,21 @@   where 	setup = do 		v <- newEmptyMVar-		void $ async $ relayFeeder runner v hin-		void $ async $ relayReader v hout-		return v+		t1 <- async $ relayFeeder runner v hin+		t2 <- async $ relayReader v hout+		return (v, t1, t2) 	-	cleanup _ = do+	cleanup (_, t1, t2) = do 		hClose hin 		hClose hout+		cancel t1+		cancel t2 	-	go v = relayHelper runner v+	go (v, _, _) = relayHelper runner v  runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Either ProtoFailure ())-runRelayService conn runner service = -	bracket setup cleanup go+runRelayService conn runner service =+	withCreateProcess serviceproc' go 		`catchNonAsync` (return . Left . ProtoFailureException)   where 	cmd = case service of@@ -295,30 +297,29 @@ 		[ Param cmd 		, File (fromRawFilePath (repoPath (connRepo conn))) 		] (connRepo conn)+	serviceproc' = serviceproc +		{ std_out = CreatePipe+		, std_in = CreatePipe+		} -	setup = do-		(Just hin, Just hout, _, pid) <- createProcess serviceproc-			{ std_out = CreatePipe-			, std_in = CreatePipe-			}+	go (Just hin) (Just hout) _ pid = do 		v <- newEmptyMVar-		void $ async $ relayFeeder runner v hin-		void $ async $ relayReader v hout-		waiter <- async $ waitexit v pid-		return (v, waiter, hin, hout, pid)--	cleanup (_, waiter, hin, hout, pid) = do-		hClose hin-		hClose hout-		cancel waiter+		r <- withAsync (relayFeeder runner v hin) $ \_ ->+			withAsync (relayReader v hout) $ \_ ->+				withAsync (waitexit v pid) $ \_ -> do+					r <- runrelay v+					hClose hin+					hClose hout+					return r 		void $ waitForProcess pid--	go (v, _, _, _, _) = do-		r <- relayHelper runner v-		case r of-			Left e -> return $ Left e-			Right exitcode -> runner $ net $ relayToPeer (RelayDone exitcode)+		return r+	go _ _ _ _ = error "internal" 	+	runrelay v = relayHelper runner v >>= \case+		Left e -> return $ Left e+		Right exitcode -> runner $+			net $ relayToPeer (RelayDone exitcode)+ 	waitexit v pid = putMVar v . RelayDone =<< waitForProcess pid  -- Processes RelayData as it is put into the MVar.

@@ -74,6 +74,7 @@ import Logs.Location hiding (logStatus) import Logs.Web import Remote.List+import Remote.List.Util import Config import Config.DynamicConfig import Git.Types (RemoteName, ConfigKey(..), fromConfigValue)@@ -286,7 +287,7 @@ 	findinmap = M.lookup u <$> remoteMap id 	{- Re-read remote list in case a new remote has popped up. -} 	tryharder = do-		void remoteListRefresh+		remotesChanged 		findinmap  {- Filters a list of remotes to ones that have the listed uuids. -}

@@ -152,22 +152,42 @@  store :: Remote -> BupRepo -> Storer store r buprepo = byteStorer $ \k b p -> do-	let params = bupSplitParams r buprepo k [] 	showOutput -- make way for bup output-	let cmd = proc "bup" (toCommand params) 	quiet <- commandProgressDisabled-	let feeder = \h -> meteredWrite p h b-	liftIO $ if quiet-		then feedWithQuietOutput createProcessSuccess cmd feeder-		else withHandle StdinHandle createProcessSuccess cmd feeder+	liftIO $ withNullHandle $ \nullh ->+		let params = bupSplitParams r buprepo k []+		    cmd = (proc "bup" (toCommand params))+			{ std_in = CreatePipe }+		    cmd' = if quiet+			then cmd +				{ std_out = UseHandle nullh+				, std_err = UseHandle nullh+				}+			else cmd+		    feeder = \h -> do+			meteredWrite p h b+			hClose h+		in withCreateProcess cmd' (go feeder cmd')+  where+	go feeder p (Just h) _ _ pid =+		forceSuccessProcess p pid+			`after`+		feeder h+	go _ _ _ _ _ _ = error "internal"  retrieve :: BupRepo -> Retriever retrieve buprepo = byteRetriever $ \k sink -> do 	let params = bupParams "join" buprepo [Param $ bupRef k]-	let p = proc "bup" (toCommand params)-	(_, Just h, _, pid) <- liftIO $ createProcess $ p { std_out = CreatePipe }-	liftIO (hClose h >> forceSuccessProcess p pid)-		`after` (sink =<< liftIO (L.hGetContents h))+	let p = (proc "bup" (toCommand params))+		{ std_out = CreatePipe }+	bracketIO (createProcess p) cleanupProcess (go sink p)+  where+	go sink p (_, Just h, _, pid) = do+		() <- sink =<< liftIO (L.hGetContents h)+		liftIO $ do+			hClose h+			forceSuccessProcess p pid+	go _ _ _ = error "internal"  {- Cannot revert having stored a key in bup, but at least the data for the  - key will be used for deltaing data of other keys stored later.@@ -177,7 +197,7 @@ remove :: BupRepo -> Remover remove buprepo k = do 	go =<< liftIO (bup2GitRemote buprepo)-	giveup "content cannot be completely removed from bup remote"+	warning "content cannot be completely removed from bup remote"   where 	go r 		| Git.repoIsUrl r = void $ onBupRemote r boolSystem "git" params

@@ -1,11 +1,13 @@ {- Using ddar as a remote. Based on bup and rsync remotes.  -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  - Copyright 2014 Robie Basak <robie@justgohome.co.uk>  -  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE BangPatterns #-}+ module Remote.Ddar (remote) where  import qualified Data.Map as M@@ -157,10 +159,16 @@ retrieve :: DdarRepo -> Retriever retrieve ddarrepo = byteRetriever $ \k sink -> do 	(cmd, params) <- ddarExtractRemoteCall NoConsumeStdin ddarrepo k-	let p = (proc cmd $ toCommand params) { std_out = CreatePipe }-	(_, Just h, _, pid) <- liftIO $ createProcess p-	liftIO (hClose h >> forceSuccessProcess p pid)-		`after` (sink =<< liftIO (L.hGetContents h))+	let p = (proc cmd $ toCommand params)+		{ std_out = CreatePipe }+	bracketIO (createProcess p) cleanupProcess (go sink p)+  where+	go sink p (_, Just h, _, pid) = do+		() <- sink =<< liftIO (L.hGetContents h)+		liftIO $ do+			hClose h+			forceSuccessProcess p pid+	go _ _ _ = error "internal"  remove :: DdarRepo -> Remover remove ddarrepo key = do@@ -195,12 +203,18 @@ inDdarManifest :: DdarRepo -> Key -> Annex (Either String Bool) inDdarManifest ddarrepo k = do 	(cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 't' []-	let p = proc cmd $ toCommand params-	liftIO $ catchMsgIO $ withHandle StdoutHandle createProcessSuccess p $ \h -> do-		contents <- hGetContents h-		return $ elem k' $ lines contents+	let p = (proc cmd $ toCommand params)+		{ std_out = CreatePipe }+	liftIO $ catchMsgIO $ withCreateProcess p (go p)   where 	k' = serializeKey k+	+	go p _ (Just hout) _ pid = do+		contents <- hGetContents hout+		let !r = elem k' (lines contents)+		forceSuccessProcess p pid+		return r+	go _ _ _ _ _ = error "internal"  checkKey :: DdarRepo -> CheckPresent checkKey ddarrepo key = do

@@ -350,20 +350,28 @@  	docopy cont = do #ifndef mingw32_HOST_OS-		-- Need a duplicate fd for the post check, since-		-- hGetContentsMetered closes its handle.-		fd <- liftIO $ openFd f ReadOnly Nothing defaultFileFlags-		dupfd <- liftIO $ dup fd-		h <- liftIO $ fdToHandle fd+		let open = do+			-- Need a duplicate fd for the post check, since+			-- hGetContentsMetered closes its handle.+			fd <- openFd f ReadOnly Nothing defaultFileFlags+			dupfd <- dup fd+			h <- fdToHandle fd+			return (h, dupfd)+		let close (h, dupfd) = do+			hClose h+			closeFd dupfd+		bracketIO open close $ \(h, dupfd) -> do #else-		h <- liftIO $ openBinaryFile f ReadMode+		let open = openBinaryFile f ReadMode+		let close = hClose+		bracketIO setup close $ \h -> do #endif-		liftIO $ hGetContentsMetered h p >>= L.writeFile dest-		k <- mkkey+			liftIO $ hGetContentsMetered h p >>= L.writeFile dest+			k <- mkkey #ifndef mingw32_HOST_OS-		cont dupfd (return k)+			cont dupfd (return k) #else-		cont (return k)+			cont (return k) #endif 	 	-- Check before copy, to avoid expensive copy of wrong file

@@ -414,9 +414,13 @@ 					(Accepted setting) 					(RemoteConfigValue (PassedThrough value)) 					m-				in ParsedRemoteConfig m' c+				    c' = M.insert+				    	(Accepted setting)+					(Accepted value)+					c+				in ParsedRemoteConfig m' c' 			modifyTVar' (externalConfigChanges st) $ \f ->-				f . M.insert (Accepted setting) (Accepted value)+				M.insert (Accepted setting) (Accepted value) . f 	handleRemoteRequest (GETCONFIG setting) = do 		value <- maybe "" fromProposedAccepted 			. (M.lookup (Accepted setting))@@ -426,11 +430,18 @@ 	handleRemoteRequest (SETCREDS setting login password) = case (externalUUID external, externalGitConfig external) of 		(Just u, Just gc) -> do 			let v = externalConfig st-			(ParsedRemoteConfig m c) <- liftIO $ atomically $ readTVar v-			m' <- setRemoteCredPair' RemoteConfigValue (\m' -> ParsedRemoteConfig m' c) encryptionAlreadySetup m gc+			pc <- liftIO $ atomically $ readTVar v+			pc' <- setRemoteCredPair' pc encryptionAlreadySetup gc 				(credstorage setting u) 				(Just (login, password))-			void $ liftIO $ atomically $ swapTVar v (ParsedRemoteConfig m' c)+			let configchanges = M.differenceWithKey+				(\_k a b -> if a == b then Nothing else Just a)+				(unparsedRemoteConfig pc')+				(unparsedRemoteConfig pc)+			void $ liftIO $ atomically $ do+				_ <- swapTVar v pc'+				modifyTVar' (externalConfigChanges st) $ \f ->+					M.union configchanges . f 		_ -> senderror "cannot send SETCREDS here" 	handleRemoteRequest (GETCREDS setting) = case (externalUUID external, externalGitConfig external) of 		(Just u, Just gc) -> do@@ -560,13 +571,24 @@ {- While the action is running, the ExternalState provided to it will not  - be available to any other calls.  -- - Starts up a new process if no ExternalStates are available. -}+ - Starts up a new process if no ExternalStates are available.+ -+ - If the action is interrupted by an async exception, the external process+ - is in an unknown state, and may eg be still performing a transfer. So it+ - is killed. The action should not normally throw any exception itself,+ - unless perhaps there's a problem communicating with the external+ - process.+ -} withExternalState :: External -> (ExternalState -> Annex a) -> Annex a-withExternalState external = bracket alloc dealloc+withExternalState external a = do+	st <- get+	r <- a st `onException` liftIO (externalShutdown st True)+	put st -- only when no exception is thrown+	return r   where 	v = externalState external -	alloc = do+	get = do 		ms <- liftIO $ atomically $ do 			l <- readTVar v 			case l of@@ -576,7 +598,7 @@ 					return (Just st) 		maybe (startExternal external) return ms 	-	dealloc st = liftIO $ atomically $ modifyTVar' v (st:)+	put st = liftIO $ atomically $ modifyTVar' v (st:)  {- Starts an external remote process running, and checks VERSION and  - exchanges EXTENSIONS. -}@@ -611,7 +633,7 @@ 			, std_err = CreatePipe 			} 		p <- propgit g basep-		(Just hin, Just hout, Just herr, ph) <- +		pall@(Just hin, Just hout, Just herr, ph) <-  			createProcess p `catchNonAsync` runerr cmdpath 		stderrelay <- async $ errrelayer herr 		cv <- newTVarIO $ externalDefaultConfig external@@ -621,13 +643,20 @@ 			n <- succ <$> readTVar (externalLastPid external) 			writeTVar (externalLastPid external) n 			return n+		let shutdown forcestop = do+			cancel stderrelay+			if forcestop+				then cleanupProcess pall+				else flip onException (cleanupProcess pall) $ do+					hClose herr+					hClose hin+					hClose hout+					void $ waitForProcess ph 		return $ ExternalState 			{ externalSend = hin 			, externalReceive = hout 			, externalPid = pid-			, externalShutdown = do-				cancel stderrelay-				void $ waitForProcess ph+			, externalShutdown = shutdown 			, externalPrepared = pv 			, externalConfig = cv 			, externalConfigChanges = ccv@@ -657,12 +686,7 @@ stopExternal :: External -> Annex () stopExternal external = liftIO $ do 	l <- atomically $ swapTVar (externalState external) []-	mapM_ stop l-  where-	stop st = do-		hClose $ externalSend st-		hClose $ externalReceive st-		externalShutdown st+	mapM_ (flip externalShutdown False) l  externalRemoteProgram :: ExternalType -> String externalRemoteProgram externaltype = "git-annex-remote-" ++ externaltype@@ -811,7 +835,7 @@ 	{ remoteConfigFieldParsers = 		[ optionalStringParser externaltypeField 			(FieldDesc "type of external special remote to use")-		, trueFalseParser readonlyField False+		, trueFalseParser readonlyField (Just False) 			(FieldDesc "enable readonly mode") 		] 	, remoteConfigRestPassthrough = Just

@@ -77,7 +77,7 @@ data ExternalState = ExternalState 	{ externalSend :: Handle 	, externalReceive :: Handle-	, externalShutdown :: IO ()+	, externalShutdown :: Bool -> IO () 	, externalPid :: PID 	, externalPrepared :: TVar PrepareStatus 	, externalConfig :: TVar ParsedRemoteConfig

@@ -337,7 +337,9 @@ 	readlocalannexconfig = do 		let check = do 			Annex.BranchState.disableUpdate-			catchNonAsync ensureInitialized (warning . show)+			catchNonAsync autoInitialize $ \e ->+				warning $ "remote " ++ Git.repoDescribe r +++					" :"  ++ show e 			Annex.getState Annex.repo 		s <- Annex.new r 		Annex.eval s $ check `finally` stopCoProcesses@@ -469,18 +471,18 @@ 		P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback 	| otherwise = failedlock   where-	fallback = do+	fallback = withNullHandle $ \nullh -> do 		Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin 			repo "lockcontent" 			[Param $ serializeKey key] []-		(Just hin, Just hout, Nothing, p) <- liftIO $ -			withFile devNull WriteMode $ \nullh ->-				createProcess $-					 (proc cmd (toCommand params))-						{ std_in = CreatePipe-						, std_out = CreatePipe-						, std_err = UseHandle nullh-						}+		let p = (proc cmd (toCommand params))+			{ std_in = CreatePipe+			, std_out = CreatePipe+			, std_err = UseHandle nullh+			}+		bracketIO (createProcess p) cleanupProcess fallback'++	fallback' (Just hin, Just hout, Nothing, p) = do 		v <- liftIO $ tryIO $ getProtocolLine hout 		let signaldone = void $ tryNonAsync $ liftIO $ mapM_ tryNonAsync 			[ hPutStrLn hout ""@@ -507,6 +509,8 @@ 					showNote "lockcontent failed" 					signaldone 					failedlock+	fallback' _ = error "internal"+ 	failedlock = giveup "can't lock content"  {- Tries to copy a key's content from a remote's annex to a file. -}@@ -587,7 +591,7 @@ 			repo "transferinfo"  			[Param $ serializeKey key] fields 		v <- liftIO (newEmptySV :: IO (MSampleVar Integer))-		pidv <- liftIO $ newEmptyMVar+		pv <- liftIO $ newEmptyMVar 		tid <- liftIO $ forkIO $ void $ tryIO $ do 			bytes <- readSV v 			p <- createProcess $@@ -595,7 +599,7 @@ 					{ std_in = CreatePipe 					, std_err = CreatePipe 					}-			putMVar pidv (processHandle p)+			putMVar pv p 			hClose $ stderrHandle p 			let h = stdinHandle p 			let send b = do@@ -614,10 +618,18 @@ 		-- do it in the background. 		let cleanup = forkIO $ do 			void $ tryIO $ killThread tid-			void $ tryNonAsync $-				maybe noop (void . waitForProcess)-					=<< tryTakeMVar pidv+			void $ tryNonAsync $ +				maybe noop (void . waitForProcess . processHandle)+					=<< tryTakeMVar pv++		let forcestop = do+			void $ tryIO $ killThread tid+			void $ tryNonAsync $ +				maybe noop cleanupProcess+					=<< tryTakeMVar pv+ 		bracketIO noop (const cleanup) (const $ a feeder)+			`onException` liftIO forcestop  copyFromRemoteCheap :: Remote -> State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) copyFromRemoteCheap r st repo@@ -824,7 +836,7 @@ 		| not $ Git.repoIsUrl repo = onLocalFast st $ 			doQuietSideAction $ 				Annex.Branch.commit =<< Annex.Branch.commitMessage-		| otherwise = void $ do+		| otherwise = do 			Just (shellcmd, shellparams) <- 				Ssh.git_annex_shell NoConsumeStdin 					repo "commit" [] []@@ -832,10 +844,13 @@ 			-- Throw away stderr, since the remote may not 			-- have a new enough git-annex shell to 			-- support committing.-			liftIO $ catchMaybeIO $-				withQuietOutput createProcessSuccess $-					proc shellcmd $-						toCommand shellparams+			liftIO $ void $ catchMaybeIO $ withNullHandle $ \nullh ->+				let p = (proc shellcmd (toCommand shellparams))+					{ std_out = UseHandle nullh+					, std_err = UseHandle nullh+					}+				in withCreateProcess p $ \_ _ _ ->+					forceSuccessProcess p  wantHardLink :: Annex Bool wantHardLink = (annexHardLink <$> Annex.getGitConfig)

@@ -162,10 +162,15 @@ 		, Param "-" 		] 	go Nothing = giveup "Glacier not usable."-	go (Just e) = liftIO $ do+	go (Just e) = 		let cmd = (proc "glacier" (toCommand params)) { env = Just e }-		withHandle StdinHandle createProcessSuccess cmd $ \h ->-			meteredWrite p h b+			{ std_in = CreatePipe }+		in liftIO $ withCreateProcess cmd (go' cmd)+	go' cmd (Just hin) _ _ pid = do+		meteredWrite p hin b+		hClose hin+		forceSuccessProcess cmd pid+	go' _ _ _ _ _ = error "internal"  retrieve :: Remote -> Retriever retrieve = byteRetriever . retrieve'@@ -185,14 +190,15 @@ 		] 	go Nothing = giveup "cannot retrieve from glacier" 	go (Just environ) = do-		let cmd = (proc "glacier" (toCommand params))+		let p = (proc "glacier" (toCommand params)) 			{ env = Just environ 			, std_out = CreatePipe 			}-		(_, Just h, _, pid) <- liftIO $ createProcess cmd+		bracketIO (createProcess p) cleanupProcess (go' p)+	go' p (_, Just h, _, pid) = do 		let cleanup = liftIO $ do 			hClose h-			forceSuccessProcess cmd pid+			forceSuccessProcess p pid 		flip finally cleanup $ do 			-- Glacier cannot store empty files, so if 			-- the output is empty, the content is not@@ -200,6 +206,7 @@ 			whenM (liftIO $ hIsEOF h) $ 				giveup "Content is not available from glacier yet. Recommend you wait up to 4 hours, and then run this command again." 			sink =<< liftIO (L.hGetContents h)+	go' _ _ = error "internal"  remove :: Remote -> Remover remove r k = unlessM go $@@ -351,5 +358,10 @@ 		giveup wrongcmd   where 	test = proc "glacier" ["--compatibility-test-git-annex"]-	shouldfail = withQuietOutput createProcessSuccess test+	shouldfail = withNullHandle $ \nullh ->+		let p = test+			{ std_out = UseHandle nullh+			, std_err = UseHandle nullh+			}+		in withCreateProcess p $ \_ _ _ -> forceSuccessProcess p 	wrongcmd = "The glacier program in PATH seems to be from boto, not glacier-cli. Cannot use this program."

@@ -12,7 +12,6 @@ import Utility.Metered  import qualified Data.ByteString.Lazy as L-import qualified Control.Exception as E  {- This is an extension that's added to the usual file (or whatever)  - where the remote stores a key. -}@@ -87,8 +86,8 @@  - writes a whole L.ByteString at a time.  -} storeChunked :: ChunkSize -> [FilePath] -> (FilePath -> L.ByteString -> IO ()) -> L.ByteString -> IO [FilePath]-storeChunked chunksize dests storer content = either onerr return-	=<< (E.try (go (Just chunksize) dests) :: IO (Either E.SomeException [FilePath]))+storeChunked chunksize dests storer content = +	either onerr return =<< tryNonAsync (go (Just chunksize) dests)   where 	go _ [] = return [] -- no dests!? 	go Nothing (d:_) = do

@@ -59,7 +59,7 @@ 	, optionalStringParser cipherField HiddenField 	, optionalStringParser cipherkeysField HiddenField 	, optionalStringParser pubkeysField HiddenField-	, yesNoParser embedCredsField False+	, yesNoParser embedCredsField Nothing 		(FieldDesc "embed credentials into git repository") 	, macFieldParser 	, optionalStringParser (Accepted "keyid")@@ -242,7 +242,7 @@ embedCreds c = case getRemoteConfigValue embedCredsField c of 	Just v -> v 	Nothing -> case (getRemoteConfigValue cipherkeysField c, getRemoteConfigValue cipherField c) of-		(Just (_ :: ProposedAccepted String), Just (_ :: ProposedAccepted String)) -> True+		(Just (_ :: String), Just (_ :: String)) -> True 		_ -> False  {- Gets encryption Cipher, and key encryptor. -}

@@ -29,7 +29,6 @@ import Control.Concurrent.STM import Control.Concurrent.Async import qualified Data.ByteString as B-import Data.Unique  toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam]) toRepo cs r gc remotecmd = do@@ -199,11 +198,13 @@  closeP2PSshConnection :: P2PSshConnection -> IO (P2PSshConnection, Maybe ExitCode) closeP2PSshConnection P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing)-closeP2PSshConnection (P2P.OpenConnection (_st, conn, pid, stderrhandlerst)) = do-	P2P.closeConnection conn-	atomically $ writeTVar stderrhandlerst EndStderrHandler-	exitcode <- waitForProcess pid-	return (P2P.ClosedConnection, Just exitcode)+closeP2PSshConnection (P2P.OpenConnection (_st, conn, pid, stderrhandlerst)) =+	-- mask async exceptions, avoid cleanup being interrupted+	uninterruptibleMask_ $ do+		P2P.closeConnection conn+		atomically $ writeTVar stderrhandlerst EndStderrHandler+		exitcode <- waitForProcess pid+		return (P2P.ClosedConnection, Just exitcode)  -- Pool of connections over ssh to git-annex-shell p2pstdio. type P2PSshConnectionPool = TVar (Maybe P2PSshConnectionPoolState)@@ -262,16 +263,14 @@ 				, std_out = CreatePipe 				, std_err = CreatePipe 				}-		-- Could use getPid, but need to build with older versions-		-- of process, so instead a unique connection number.-		connnum <- hashUnique <$> newUnique+		pidnum <- getPid pid 		let conn = P2P.P2PConnection 			{ P2P.connRepo = repo 			, P2P.connCheckAuth = const False 			, P2P.connIhdl = to 			, P2P.connOhdl = from 			, P2P.connIdent = P2P.ConnIdent $-				Just $ "ssh connection " ++ show connnum+				Just $ "ssh connection " ++ show pidnum 			} 		stderrhandlerst <- newStderrHandler err 		runst <- P2P.mkRunState P2P.Client

@@ -21,7 +21,6 @@ import Remote.Helper.ReadOnly import Remote.Helper.ExportImport import qualified Git-import qualified Git.Config  import qualified Remote.Git import qualified Remote.GCrypt@@ -89,17 +88,6 @@ 	process m t = enumerate t autoinit  		>>= mapM (remoteGen m t)  		>>= return . catMaybes--{- Forces the remoteList to be re-generated, re-reading the git config. -}-remoteListRefresh :: Annex [Remote]-remoteListRefresh = do-	newg <- inRepo Git.Config.reRead-	Annex.changeState $ \s -> s -		{ Annex.remotes = []-		, Annex.gitremotes = Nothing-		, Annex.repo = newg-		}-	remoteList  {- Generates a Remote. -} remoteGen :: M.Map UUID RemoteConfig -> RemoteType -> Git.Repo -> Annex (Maybe Remote)

@@ -0,0 +1,24 @@+{- git-annex remote list utils+ -+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Remote.List.Util where++import Annex.Common+import qualified Annex+import qualified Git.Config++{- Call when remotes have changed. Re-reads the git config, and+ - invalidates the cache so the remoteList will be re-generated next time+ - it's used. -}+remotesChanged :: Annex ()+remotesChanged = do+	newg <- inRepo Git.Config.reRead+	Annex.changeState $ \s -> s +		{ Annex.remotes = []+		, Annex.gitremotes = Nothing+		, Annex.repo = newg+		}

@@ -128,8 +128,8 @@ -- Things used by genRsyncOpts rsyncRemoteConfigs :: [RemoteConfigFieldParser] rsyncRemoteConfigs = -	[ yesNoParser shellEscapeField True-		(FieldDesc "avoid usual shell escaping (not recommended)")+	[ yesNoParser shellEscapeField (Just True)+		(FieldDesc "set to no to avoid usual shell escaping (not recommended)") 	]  genRsyncOpts :: ParsedRemoteConfig -> RemoteGitConfig -> Annex [CommandParam] -> RsyncUrl -> RsyncOpts@@ -288,10 +288,12 @@ 	-- note: Does not currently differentiate between rsync failing 	-- to connect, and the file not being present. 	untilTrue rsyncurls $ \u -> -		liftIO $ catchBoolIO $ do-			withQuietOutput createProcessSuccess $-				proc "rsync" $ toCommand $ opts ++ [Param u]-			return True+		liftIO $ catchBoolIO $ withNullHandle $ \nullh ->+			let p = (proc "rsync" $ toCommand $ opts ++ [Param u])+				{ std_out = UseHandle nullh+				, std_err = UseHandle nullh+				}+			in withCreateProcess p $ \_ _ _ -> checkSuccessProcess  storeExportM :: RsyncOpts -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM o src _k loc meterupdate =

@@ -84,13 +84,13 @@ 			, optionalStringParser partsizeField 				(FieldDesc "part size for multipart upload (eg 1GiB)") 			, optionalStringParser storageclassField-				(FieldDesc "storage class, eg STANDARD or REDUCED_REDUNDANCY")+				(FieldDesc "storage class, eg STANDARD or STANDARD_IA or ONEZONE_IA") 			, optionalStringParser fileprefixField 				(FieldDesc "prefix to add to filenames in the bucket")-			, yesNoParser versioningField False+			, yesNoParser versioningField (Just False) 				(FieldDesc "enable versioning of bucket content")-			, yesNoParser publicField False-				(FieldDesc "allow public read access to the buckey")+			, yesNoParser publicField (Just False)+				(FieldDesc "allow public read access to the bucket") 			, optionalStringParser publicurlField 				(FieldDesc "url that can be used by public to download files") 			, optionalStringParser protocolField@@ -157,7 +157,7 @@  signatureVersionParser :: RemoteConfigField -> FieldDesc -> RemoteConfigFieldParser signatureVersionParser f fd =-	genParser go f defver fd+	genParser go f (Just defver) fd 		(Just (ValueDesc "v2 or v4"))   where 	go "v2" = Just (SignatureVersion 2)@@ -939,7 +939,6 @@  getStorageClass :: ParsedRemoteConfig -> S3.StorageClass getStorageClass c = case getRemoteConfigValue storageclassField c of-	Just "REDUCED_REDUNDANCY" -> S3.ReducedRedundancy 	Just s -> S3.OtherStorageClass (T.pack s) 	_ -> S3.Standard 

@@ -37,14 +37,15 @@  transportUsingCmd' :: FilePath -> [CommandParam] -> Transport transportUsingCmd' cmd params (RemoteRepo r gc) url transporthandle ichan ochan =-	robustConnection 1 $ do-		(Just toh, Just fromh, Just errh, pid) <--			createProcess (proc cmd (toCommand params))-			{ std_in = CreatePipe-			, std_out = CreatePipe-			, std_err = CreatePipe-			}-		+	robustConnection 1 $ withCreateProcess p go+  where+	p = (proc cmd (toCommand params))+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = CreatePipe+		}++	go (Just toh) (Just fromh) (Just errh) pid = do 		-- Run all threads until one finishes and get the status 		-- of the first to finish. Cancel the rest. 		status <- catchDefaultIO (Right ConnectionClosed) $@@ -58,7 +59,8 @@ 		void $ waitForProcess pid  		return $ either (either id id) id status-  where+	go _ _ _ _ = error "internal"+ 	send msg = atomically $ writeTChan ochan msg  	fetch = do

@@ -135,8 +135,8 @@ 		pp <- Annex.Path.programPath 		Utility.Env.Set.setEnv subenv "1" True 		ps <- getArgs-		(Nothing, Nothing, Nothing, pid) <- createProcess (proc pp ps)-		exitcode <- waitForProcess pid+		exitcode <- withCreateProcess (proc pp ps) $+			\_ _ _ pid -> waitForProcess pid 		unless (keepFailuresOption opts) finalCleanup 		exitWith exitcode 	runsubprocesstests (Just _) = isolateGitConfig $ do

@@ -458,9 +458,9 @@ 		] runFakeSsh :: [String] -> IO () runFakeSsh ("-n":ps) = runFakeSsh ps-runFakeSsh (_host:cmd:[]) = do-	(_, _, _, pid) <- createProcess (shell cmd)-	exitWith =<< waitForProcess pid+runFakeSsh (_host:cmd:[]) =+	withCreateProcess (shell cmd) $+		\_ _ _ pid -> exitWith =<< waitForProcess pid runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps  getTestMode :: IO TestMode

@@ -36,6 +36,7 @@  -- XXX ideally, this would be a locked memory region data Cipher = Cipher String | MacOnlyCipher String+	deriving (Show) -- XXXDO NOT COMMIT  data StorableCipher 	= EncryptedCipher String EncryptedCipherVariant KeyIds

@@ -123,6 +123,7 @@ 	, annexCacheCreds :: Bool 	, annexAutoUpgradeRepository :: Bool 	, annexCommitMode :: CommitMode+	, annexSkipUnknown :: Bool 	, coreSymlinks :: Bool 	, coreSharedRepository :: SharedRepository 	, receiveDenyCurrentBranch :: DenyCurrentBranch@@ -214,6 +215,7 @@ 	, annexCommitMode = if getbool (annexConfig "allowsign") False 		then ManualCommit 		else AutomaticCommit+	, annexSkipUnknown = getbool (annexConfig "skipunknown") True 	, coreSymlinks = getbool "core.symlinks" True 	, coreSharedRepository = getSharedRepository r 	, receiveDenyCurrentBranch = getDenyCurrentBranch r

@@ -82,12 +82,13 @@ 	, stageSet = S.fromList [PerformStage, CleanupStage] 	} --- | When a command is transferring content, it can use this instead.--- Transfers are often bottlenecked on the network another disk than the one--- containing the repository, while verification bottlenecks on--- the disk containing the repository or on the CPU.-transferStages :: UsedStages-transferStages = UsedStages+-- | When a command is downloading content, it can use this instead.+-- Downloads are often bottlenecked on the network or another disk+-- than the one containing the repository, while verification bottlenecks+-- on the disk containing the repository or on the CPU. So, run the+-- transfer and verify stage separately.+downloadStages :: UsedStages+downloadStages = UsedStages 	{ initialStage = TransferStage 	, stageSet = S.fromList [TransferStage, VerifyStage] 	}

@@ -15,6 +15,7 @@ import Config import Annex.Path import Annex.Version+import Annex.GitOverlay import Types.RepoVersion #ifndef mingw32_HOST_OS import qualified Upgrade.V0@@ -104,7 +105,7 @@ 	upgraderemote = do 		rp <- fromRawFilePath <$> fromRepo Git.repoPath 		cmd <- liftIO programPath-		liftIO $ boolSystem' cmd+		runsGitAnnexChildProcess $ liftIO $ boolSystem' cmd 			[ Param "upgrade" 			, Param "--quiet" 			, Param "--autoonly"

@@ -85,7 +85,7 @@ updateSymlinks = do 	showAction "updating symlinks" 	top <- fromRepo Git.repoPath-	(files, cleanup) <- inRepo $ LsFiles.inRepo [top]+	(files, cleanup) <- inRepo $ LsFiles.inRepo [] [top] 	forM_ files (fixlink . fromRawFilePath) 	void $ liftIO cleanup   where

@@ -1,6 +1,6 @@ {- Running a long or expensive batch operation niced.  -- - Copyright 2013 Joey Hess <id@joeyh.name>+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -22,7 +22,6 @@ import Control.Concurrent.Async import System.Posix.Process #endif-import qualified Control.Exception as E  {- Runs an operation, at batch priority.  -@@ -75,11 +74,7 @@ 	return $ batchmaker v  {- Runs a command in a way that's suitable for batch jobs that can be- - interrupted.- -- - If the calling thread receives an async exception, it sends the- - command a SIGTERM, and after the command finishes shuttting down,- - it re-raises the async exception. -}+ - interrupted. -} batchCommand :: String -> [CommandParam] -> IO Bool batchCommand command params = batchCommandEnv command params Nothing @@ -87,13 +82,4 @@ batchCommandEnv command params environ = do 	batchmaker <- getBatchCommandMaker 	let (command', params') = batchmaker (command, params)-	let p = proc command' $ toCommand params'-	(_, _, _, pid) <- createProcess $ p { env = environ }-	r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode)-	case r of-		Right ExitSuccess -> return True-		Right _ -> return False-		Left asyncexception -> do-			terminateProcess pid-			void $ waitForProcess pid-			E.throwIO asyncexception+	boolSystemEnv command' params' environ

@@ -1,7 +1,7 @@ {- Interface for running a shell command as a coprocess,  - sending it queries and getting back results.  -- - Copyright 2012-2013 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -62,28 +62,46 @@ 	let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s) 	forceSuccessProcess p (coProcessPid s) -{- To handle a restartable process, any IO exception thrown by the send and+{- Note that concurrent queries are not safe to perform; caller should+ - serialize calls to query.+ -+ - To handle a restartable process, any IO exception thrown by the send and  - receive actions are assumed to mean communication with the process- - failed, and the failed action is re-run with a new process. -}+ - failed, and the query is re-run with a new process.+ -+ - If an async exception is received during a query, the state of+ - communication with the process is unknown, so it is killed, and a new+ - one started so the CoProcessHandle can continue to be used by other+ - threads.+ -} query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b-query ch send receive = do-	s <- readMVar ch-	restartable s (send $ coProcessTo s) $ const $-		restartable s (hFlush $ coProcessTo s) $ const $-			restartable s (receive $ coProcessFrom s)-				return+query ch send receive = uninterruptibleMask $ \unmask ->+	unmask (readMVar ch >>= restartable)+		`catchAsync` forcerestart   where-	restartable s a cont+	go s = do+		void $ send $ coProcessTo s+		hFlush $ coProcessTo s+		receive $ coProcessFrom s+	+	restartable s 		| coProcessNumRestarts (coProcessSpec s) > 0 =-			maybe restart cont =<< catchMaybeIO a-		| otherwise = cont =<< a-	restart = do-		s <- takeMVar ch-		void $ catchMaybeIO $ do+			catchMaybeIO (go s)+				>>= maybe (restart s increstarts restartable) return+		| otherwise = go s+	+	increstarts s = s { coProcessNumRestarts = coProcessNumRestarts s - 1 }++	restart s f cont = do+		void $ tryNonAsync $ do 			hClose $ coProcessTo s 			hClose $ coProcessFrom s 		void $ waitForProcess $ coProcessPid s-		s' <- start' $ (coProcessSpec s)-			{ coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 }-		putMVar ch s'-		query ch send receive+		s' <- withMVarMasked ch $ \_ -> start' (f (coProcessSpec s))+		cont s'++	forcerestart ex = do+		s <- readMVar ch+		terminateProcess (coProcessPid s)+		restart s id $ \s' -> void $ swapMVar ch s'+		either throwM throwM ex

@@ -57,11 +57,12 @@ 		void $ tryIO $ removeFile dest 		-- When CoW is not supported, cp will complain to stderr, 		-- so have to discard its stderr.-		ok <- catchBoolIO $ do-			withQuietOutput createProcessSuccess $-				proc "cp" $ toCommand $-					params ++ [File src, File dest]-			return True+		ok <- catchBoolIO $ withNullHandle $ \nullh ->+			let p = (proc "cp" $ toCommand $ params ++ [File src, File dest])+				{ std_out = UseHandle nullh+				, std_err = UseHandle nullh+				}+			in withCreateProcess p $ \_ _ _ -> checkSuccessProcess 		-- When CoW is not supported, cp creates the destination 		-- file but leaves it empty. 		unless ok $

@@ -10,6 +10,7 @@ module Utility.Env.Set ( 	setEnv, 	unsetEnv,+	legalInEnvVar, ) where  #ifdef mingw32_HOST_OS@@ -18,6 +19,7 @@ #else import qualified System.Posix.Env as PE #endif+import Data.Char  {- Sets an environment variable. To overwrite an existing variable,  - overwrite must be True.@@ -41,3 +43,7 @@ #else unsetEnv = System.SetEnv.unsetEnv #endif++legalInEnvVar :: Char -> Bool+legalInEnvVar '_' = True+legalInEnvVar c = isAsciiLower c || isAsciiUpper c || (isNumber c && isAscii c)

@@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more)  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -20,6 +20,7 @@ 	bracketIO, 	catchNonAsync, 	tryNonAsync,+	catchAsync, 	tryWhenExists, 	catchIOErrorType, 	IOErrorType(..),@@ -85,6 +86,14 @@ 	[ M.Handler (\ (e :: AsyncException) -> throwM e) 	, M.Handler (\ (e :: SomeAsyncException) -> throwM e) 	, M.Handler (\ (e :: SomeException) -> onerr e)+	]++{- Catches only async exceptions. -}+catchAsync :: MonadCatch m => m a -> (Either AsyncException SomeAsyncException -> m a) -> m a+catchAsync a onerr = a `catches`+	[ M.Handler (\ (e :: AsyncException) -> onerr (Left e))+	, M.Handler (\ (e :: SomeAsyncException) -> onerr (Right e))+	, M.Handler (\ (e :: SomeException) -> throwM e) 	]  tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a)

@@ -17,7 +17,7 @@ 	stdEncryptionParams, 	pipeStrict, 	feedRead,-	pipeLazy,+	feedRead', 	findPubKeys, 	UserId, 	secretKeys,@@ -47,7 +47,7 @@ #endif import Utility.Format (decode_c) -import Control.Concurrent+import Control.Concurrent.Async import Control.Monad.IO.Class import qualified Data.Map as M import Data.Char@@ -112,21 +112,33 @@ readStrict :: GpgCmd -> [CommandParam] -> IO String readStrict (GpgCmd cmd) params = do 	params' <- stdParams params-	withHandle StdoutHandle createProcessSuccess (proc cmd params') $ \h -> do-		hSetBinaryMode h True-		hGetContentsStrict h+	let p = (proc cmd params')+		{ std_out = CreatePipe }+	withCreateProcess p (go p)+  where+	go p _ (Just hout) _ pid = do+		hSetBinaryMode hout True+		forceSuccessProcess p pid `after` hGetContentsStrict hout+	go _ _ _ _ _ = error "internal"  {- Runs gpg, piping an input value to it, and returning its stdout,  - strictly. -} pipeStrict :: GpgCmd -> [CommandParam] -> String -> IO String pipeStrict (GpgCmd cmd) params input = do 	params' <- stdParams params-	withIOHandles createProcessSuccess (proc cmd params') $ \(to, from) -> do+	let p = (proc cmd params')+		{ std_in = CreatePipe+		, std_out = CreatePipe+		}+	withCreateProcess p (go p)+  where+	go p (Just to) (Just from) _ pid = do 		hSetBinaryMode to True 		hSetBinaryMode from True 		hPutStr to input 		hClose to-		hGetContentsStrict from+		forceSuccessProcess p pid `after` hGetContentsStrict from+	go _ _ _ _ _ = error "internal"  {- Runs gpg with some parameters. First sends it a passphrase (unless it  - is empty) via '--passphrase-fd'. Then runs a feeder action that is@@ -137,20 +149,26 @@  - Runs gpg in batch mode; this is necessary to avoid gpg 2.x prompting for  - the passphrase.  -- - Note that to avoid deadlock with the cleanup stage,- - the reader must fully consume gpg's input before returning. -}+ - Note that the reader must fully consume gpg's input before returning. -} feedRead :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> m a) -> m a feedRead cmd params passphrase feeder reader = do #ifndef mingw32_HOST_OS-	-- pipe the passphrase into gpg on a fd-	(frompipe, topipe) <- liftIO System.Posix.IO.createPipe-	liftIO $ void $ forkIO $ do+	let setup = liftIO $ do+		-- pipe the passphrase into gpg on a fd+		(frompipe, topipe) <- System.Posix.IO.createPipe 		toh <- fdToHandle topipe-		hPutStrLn toh passphrase+		t <- async $ do+			hPutStrLn toh passphrase+			hClose toh+		let Fd pfd = frompipe+		let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]+		return (passphrasefd, frompipe, toh, t)+	let cleanup (_, frompipe, toh, t) = liftIO $ do+		closeFd frompipe 		hClose toh-	let Fd pfd = frompipe-	let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]-	liftIO (closeFd frompipe) `after` go (passphrasefd ++ params)+		cancel t+	bracket setup cleanup $ \(passphrasefd, _, _, _) -> +		go (passphrasefd ++ params) #else 	-- store the passphrase in a temp file for gpg 	withTmpFile "gpg" $ \tmpfile h -> do@@ -160,27 +178,31 @@ 		go $ passphrasefile ++ params #endif   where-	go params' = pipeLazy cmd params' feeder reader+	go params' = feedRead' cmd params' feeder reader  {- Like feedRead, but without passphrase. -}-pipeLazy :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> (Handle -> IO ()) -> (Handle -> m a) -> m a-pipeLazy (GpgCmd cmd) params feeder reader = do+feedRead' :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> (Handle -> IO ()) -> (Handle -> m a) -> m a+feedRead' (GpgCmd cmd) params feeder reader = do 	params' <- liftIO $ stdParams $ Param "--batch" : params 	let p = (proc cmd params') 		{ std_in = CreatePipe 		, std_out = CreatePipe 		, std_err = Inherit 		}-	bracket (setup p) (cleanup p) go+	bracket (setup p) cleanup (go p)   where 	setup = liftIO . createProcess-	cleanup p (_, _, _, pid) = liftIO $ forceSuccessProcess p pid-	go p = do-		let (to, from) = ioHandles p-		liftIO $ void $ forkIO $ do+	cleanup = liftIO . cleanupProcess++	go p (Just to, Just from, _, pid) =+		let runfeeder = do 			feeder to 			hClose to-		reader from+		in bracketIO (async runfeeder) cancel $ const $ do+			r <- reader from+			liftIO $ forceSuccessProcess p pid+			return r+	go _ _ = error "internal"  {- Finds gpg public keys matching some string. (Could be an email address,  - a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of@@ -241,10 +263,13 @@  -} genSecretKey :: GpgCmd -> KeyType -> Passphrase -> UserId -> Size -> IO () genSecretKey (GpgCmd cmd) keytype passphrase userid keysize =-	withHandle StdinHandle createProcessSuccess (proc cmd params) feeder+	let p = (proc cmd params)+		{ std_in = CreatePipe }+	in withCreateProcess p (go p)   where 	params = ["--batch", "--gen-key"]-	feeder h = do++	go p (Just h) _ _ pid = do 		hPutStr h $ unlines $ catMaybes 			[ Just $  "Key-Type: " ++  				case keytype of@@ -259,6 +284,8 @@ 				else Just $ "Passphrase: " ++ passphrase 			] 		hClose h+		forceSuccessProcess p pid+	go _ _ _ _ _ = error "internal"  {- Creates a block of high-quality random data suitable to use as a cipher.  - It is armored, to avoid newlines, since gpg only reads ciphers up to the

@@ -1,6 +1,6 @@ {- pid-based lock files  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -14,6 +14,7 @@ 	getLockStatus, 	checkLocked, 	checkSaneLock,+	pidLockEnv, ) where  import Utility.PartialPrelude@@ -27,10 +28,15 @@ import Utility.ThreadScheduler import Utility.Hash import Utility.FileSystemEncoding+import Utility.Env+import Utility.Env.Set import qualified Utility.LockFile.Posix as Posix  import System.IO-import System.Posix+import System.Posix.IO+import System.Posix.Types+import System.Posix.Files+import System.Posix.Process import Data.Maybe import Data.List import Network.BSD@@ -40,7 +46,9 @@  type LockFile = FilePath -data LockHandle = LockHandle LockFile FileStatus SideLockHandle+data LockHandle+	= LockHandle LockFile FileStatus SideLockHandle+	| ParentLocked  type SideLockHandle = Maybe (LockFile, Posix.LockHandle) @@ -115,40 +123,49 @@ -- However, if the lock file is on a networked file system, and was -- created on a different host than the current host (determined by hostname), -- this can't be done and stale locks may persist.+--+-- If a parent process is holding the lock, determined by a+-- "PIDLOCK_lockfile" environment variable, does not block either. tryLock :: LockFile -> IO (Maybe LockHandle)-tryLock lockfile = trySideLock lockfile $ \sidelock -> do-	lockfile' <- absPath lockfile-	(tmp, h) <- openTempFile (takeDirectory lockfile') "locktmp"-	setFileMode tmp (combineModes readModes)-	hPutStr h . show =<< mkPidLock-	hClose h-	let failedlock st = do-		dropLock $ LockHandle tmp st sidelock-		nukeFile tmp-		return Nothing-	let tooklock st = return $ Just $ LockHandle lockfile' st sidelock-	ifM (linkToLock sidelock tmp lockfile')-		( do+tryLock lockfile = do+	abslockfile <- absPath lockfile+	lockenv <- pidLockEnv abslockfile+	getEnv lockenv >>= \case+		Nothing -> trySideLock lockfile (go abslockfile)+		_ -> return (Just ParentLocked)+  where+	go abslockfile sidelock = do+		(tmp, h) <- openTempFile (takeDirectory abslockfile) "locktmp"+		setFileMode tmp (combineModes readModes)+		hPutStr h . show =<< mkPidLock+		hClose h+		let failedlock st = do+			dropLock $ LockHandle tmp st sidelock 			nukeFile tmp-			-- May not have made a hard link, so stat-			-- the lockfile-			lckst <- getFileStatus lockfile'-			tooklock lckst-		, do-			v <- readPidLock lockfile'-			hn <- getHostName-			tmpst <- getFileStatus tmp-			case v of-				Just pl | isJust sidelock && hn == lockingHost pl -> do-					-- Since we have the sidelock,-					-- and are on the same host that-					-- the pidlock was taken on,-					-- we know that the pidlock is-					-- stale, and can take it over.-					rename tmp lockfile'-					tooklock tmpst-				_ -> failedlock tmpst-		)+			return Nothing+		let tooklock st = return $ Just $ LockHandle abslockfile st sidelock+		ifM (linkToLock sidelock tmp abslockfile)+			( do+				nukeFile tmp+				-- May not have made a hard link, so stat+				-- the lockfile+				lckst <- getFileStatus abslockfile+				tooklock lckst+			, do+				v <- readPidLock abslockfile+				hn <- getHostName+				tmpst <- getFileStatus tmp+				case v of+					Just pl | isJust sidelock && hn == lockingHost pl -> do+						-- Since we have the sidelock,+						-- and are on the same host that+						-- the pidlock was taken on,+						-- we know that the pidlock is+						-- stale, and can take it over.+						rename tmp abslockfile+						tooklock tmpst+					_ -> failedlock tmpst+			)  -- Linux's open(2) man page recommends linking a pid lock into place, -- as the most portable atomic operation that will fail if@@ -174,12 +191,13 @@ 				, return False 				) 		Left _ -> catchBoolIO $ do-			fd <- openFd dest WriteOnly-				(Just $ combineModes readModes)-				(defaultFileFlags {exclusive = True})-			h <- fdToHandle fd-			readFile src >>= hPutStr h-			hClose h+			let setup = do+				fd <- openFd dest WriteOnly+					(Just $ combineModes readModes)+					(defaultFileFlags {exclusive = True})+				fdToHandle fd+			let cleanup = hClose+			bracket setup cleanup (\h -> readFile src >>= hPutStr h) 			return True   where 	checklinked = do@@ -241,6 +259,7 @@ 	-- considered stale. 	dropSideLock sidelock 	nukeFile lockfile+dropLock ParentLocked = return ()  getLockStatus :: LockFile -> IO LockStatus getLockStatus = maybe StatusUnLocked (StatusLockedBy . lockingPid) <$$> readPidLock@@ -260,3 +279,17 @@ 	go Nothing = return False 	go (Just st') = return $ 		deviceID st == deviceID st' && fileID st == fileID st'+checkSaneLock _ ParentLocked = return True++-- | A parent process that is using pid locking can set this to 1 before+-- starting a child, to communicate to the child that it's holding the pid+-- lock and that the child can skip trying to take it, and not block+-- on the pid lock its parent is holding.+--+-- The parent process should keep running as long as the child+-- process is running, since the child inherits the environment and will+-- not see unsetLockEnv.+pidLockEnv :: FilePath -> IO String+pidLockEnv lockfile = do+	abslockfile <- absPath lockfile+	return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile

@@ -58,7 +58,7 @@  -- Tries to take an lock, but does not block. tryLock :: LockRequest -> Maybe FileMode -> LockFile -> IO (Maybe LockHandle)-tryLock lockreq mode lockfile = do+tryLock lockreq mode lockfile = uninterruptibleMask_ $ do 	l <- openLockFile lockreq mode lockfile 	v <- tryIO $ setLock l (lockreq, AbsoluteSeek, 0, 0) 	case v of@@ -92,14 +92,17 @@ 		Just (Just pid) -> StatusLockedBy pid  getLockStatus' :: LockFile -> IO (Maybe (Maybe ProcessID))-getLockStatus' lockfile = go =<< catchMaybeIO open+getLockStatus' lockfile = bracket open close go   where-	open = openLockFile ReadLock Nothing lockfile-	go Nothing = return Nothing+	open = catchMaybeIO $ openLockFile ReadLock Nothing lockfile++	close (Just h) = closeFd h+	close Nothing = return ()+ 	go (Just h) = do 		v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)-		closeFd h 		return (Just (fmap fst v))+	go Nothing = return Nothing  dropLock :: LockHandle -> IO () dropLock (LockHandle fd) = closeFd fd

@@ -49,11 +49,16 @@  - Note: If lsof is not available, this always returns [] !  -} query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)]-query opts =-	withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $-		parse <$$> hGetContentsStrict+query opts = withCreateProcess p go   where-	p = proc "lsof" ("-F0can" : opts)+	p = (proc "lsof" ("-F0can" : opts))+		{ std_out = CreatePipe }+	+	go _ (Just outh) _ pid = do+		r <- parse <$> hGetContentsStrict outh+		void $ waitForProcess pid+		return r+	go _ _ _ _ = error "internal"  type LsofParser = String -> [(FilePath, LsofOpenMode, ProcessInfo)] 

@@ -30,12 +30,12 @@ import Utility.Misc import Utility.Env import Utility.Path+import Utility.Exception  import System.IO import System.Exit import Control.Concurrent import Control.Concurrent.Async-import Control.Exception import Data.Char import Data.List import Control.Applicative@@ -146,26 +146,22 @@ wormHoleProcess = proc "wormhole" . toCommand  runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> Handle -> IO Bool) ->  IO Bool-runWormHoleProcess p consumer = -	bracketOnError setup (\v -> cleanup v <&&> return False) go+runWormHoleProcess p consumer =+	withCreateProcess p' go `catchNonAsync` const (return False)   where-	setup = do-		(Just hin, Just hout, Just herr, pid)-			<- createProcess p-				{ std_in = CreatePipe-				, std_out = CreatePipe-				, std_err = CreatePipe-				}-		return (hin, hout, herr, pid)-	cleanup (hin, hout, herr, pid) = do+	p' = p +		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = CreatePipe+		}+	go (Just hin) (Just hout) (Just herr) pid =+		consumer hin hout herr <&&> waitbool pid+	go _ _ _ _ = error "internal"+	waitbool pid = do 		r <- waitForProcess pid-		hClose hin-		hClose hout-		hClose herr 		return $ case r of 			ExitSuccess -> True 			ExitFailure _ -> False-	go h@(hin, hout, herr, _) = consumer hin hout herr <&&> cleanup h  isInstalled :: IO Bool isInstalled = inPath "wormhole"

@@ -310,17 +310,21 @@ 	-> (Handle -> IO ()) 	-> (Handle -> IO ()) 	-> IO (Maybe ExitCode)-outputFilter cmd params environ outfilter errfilter = catchMaybeIO $ do-	(_, Just outh, Just errh, pid) <- createProcess p-		{ std_out = CreatePipe-		, std_err = CreatePipe-		}-	void $ async $ tryIO (outfilter outh) >> hClose outh-	void $ async $ tryIO (errfilter errh) >> hClose errh-	waitForProcess pid+outputFilter cmd params environ outfilter errfilter = +	catchMaybeIO $ withCreateProcess p go   where+	go _ (Just outh) (Just errh) pid = do+		void $ concurrently +			(tryIO (outfilter outh) >> hClose outh)+			(tryIO (errfilter errh) >> hClose errh)+		waitForProcess pid+	go _ _ _ _ = error "internal"+	 	p = (proc cmd (toCommand params))-		{ env = environ }+		{ env = environ+		, std_out = CreatePipe+		, std_err = CreatePipe+		}  -- | Limit a meter to only update once per unit of time. --

@@ -1,34 +0,0 @@-{- parallel processing via threads- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - License: BSD-2-clause- -}--module Utility.Parallel (inParallel) where--import Common--import Control.Concurrent--{- Runs an action in parallel with a set of values, in a set of threads.- - In order for the actions to truely run in parallel, requires GHC's- - threaded runtime, - -- - Returns the values partitioned into ones with which the action succeeded,- - and ones with which it failed. -}-inParallel :: (v -> IO Bool) -> [v] -> IO ([v], [v])-inParallel a l = do-	mvars <- mapM thread l-	statuses <- mapM takeMVar mvars-	return $ reduce $ partition snd $ zip l statuses-  where-	reduce (x,y) = (map fst x, map fst y)-	thread v = do-		mvar <- newEmptyMVar-		_ <- forkIO $ do-			r <- try (a v) :: IO (Either SomeException Bool)-			case r of-				Left _ -> putMVar mvar False-				Right b -> putMVar mvar b-		return mvar

@@ -20,64 +20,55 @@ 	forceSuccessProcess, 	forceSuccessProcess', 	checkSuccessProcess,-	ignoreFailureProcess,-	createProcessSuccess,-	createProcessChecked,-	createBackgroundProcess,-	withHandle,-	withIOHandles,-	withOEHandles, 	withNullHandle,-	withQuietOutput,-	feedWithQuietOutput, 	createProcess,+	withCreateProcess, 	waitForProcess,+	cleanupProcess, 	startInteractiveProcess, 	stdinHandle, 	stdoutHandle, 	stderrHandle,-	ioHandles, 	processHandle, 	devNull, ) where  import qualified Utility.Process.Shim-import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)-import Utility.Process.Shim hiding (createProcess, readProcess, waitForProcess)+import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProcess, withCreateProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess, cleanupProcess)+import Utility.Process.Shim hiding (createProcess, withCreateProcess, readProcess, waitForProcess, cleanupProcess) import Utility.Misc import Utility.Exception+import Utility.Monad  import System.Exit import System.IO import System.Log.Logger-import Control.Concurrent-import qualified Control.Exception as E-import Control.Monad+import Control.Monad.IO.Class+import Control.Concurrent.Async import qualified Data.ByteString as S -type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a- data StdHandle = StdinHandle | StdoutHandle | StderrHandle 	deriving (Eq)  -- | Normally, when reading from a process, it does not need to be fed any -- standard input. readProcess :: FilePath	-> [String] -> IO String-readProcess cmd args = readProcessEnv cmd args Nothing+readProcess cmd args = readProcess' (proc cmd args)  readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String-readProcessEnv cmd args environ = readProcess' p-  where-	p = (proc cmd args)-		{ std_out = CreatePipe-		, env = environ-		}+readProcessEnv cmd args environ = +	readProcess' $ (proc cmd args) { env = environ }  readProcess' :: CreateProcess -> IO String-readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do-	output  <- hGetContentsStrict h-	hClose h-	return output+readProcess' p = withCreateProcess p' go+  where+	p' = p { std_out = CreatePipe }+	go _ (Just h) _ pid = do+		output  <- hGetContentsStrict h+		hClose h+		forceSuccessProcess p' pid+		return output+	go _ _ _ _ = error "internal"  -- | Runs an action to write to a process on its stdin,  -- returns its output, and also allows specifying the environment.@@ -87,26 +78,7 @@ 	-> Maybe [(String, String)] 	-> (Maybe (Handle -> IO ())) 	-> IO S.ByteString-writeReadProcessEnv cmd args environ writestdin = do-	(Just inh, Just outh, _, pid) <- createProcess p--	-- fork off a thread to start consuming the output-	outMVar <- newEmptyMVar-	_ <- forkIO $ putMVar outMVar =<< S.hGetContents outh--	-- now write and flush any input-	maybe (return ()) (\a -> a inh >> hFlush inh) writestdin-	hClose inh -- done with stdin--	-- wait on the output-	output <- takeMVar outMVar-	hClose outh--	-- wait on the process-	forceSuccessProcess p pid--	return output-+writeReadProcessEnv cmd args environ writestdin = withCreateProcess p go   where 	p = (proc cmd args) 		{ std_in = CreatePipe@@ -114,7 +86,19 @@ 		, std_err = Inherit 		, env = environ 		}+	+	go (Just inh) (Just outh) _ pid = do+		let reader = hClose outh `after` S.hGetContents outh+		let writer = do+			maybe (return ()) (\a -> a inh >> hFlush inh) writestdin+			hClose inh+		(output, ()) <- concurrently reader writer +		forceSuccessProcess p pid++		return output+	go _ _ _ _ = error "internal"+ -- | Waits for a ProcessHandle, and throws an IOError if the process -- did not exit successfully. forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()@@ -126,117 +110,15 @@ 	showCmd p ++ " exited " ++ show n  -- | Waits for a ProcessHandle and returns True if it exited successfully.--- Note that using this with createProcessChecked will throw away--- the Bool, and is only useful to ignore the exit code of a process,--- while still waiting for it. -} checkSuccessProcess :: ProcessHandle -> IO Bool checkSuccessProcess pid = do 	code <- waitForProcess pid 	return $ code == ExitSuccess -ignoreFailureProcess :: ProcessHandle -> IO Bool-ignoreFailureProcess pid = do-	void $ waitForProcess pid-	return True---- | Runs createProcess, then an action on its handles, and then--- forceSuccessProcess.-createProcessSuccess :: CreateProcessRunner-createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a---- | Runs createProcess, then an action on its handles, and then--- a checker action on its exit code, which must wait for the process.-createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner-createProcessChecked checker p a = do-	t@(_, _, _, pid) <- createProcess p-	r <- tryNonAsync $ a t-	_ <- checker pid-	either E.throw return r---- | Leaves the process running, suitable for lazy streaming.--- Note: Zombies will result, and must be waited on.-createBackgroundProcess :: CreateProcessRunner-createBackgroundProcess p a = a =<< createProcess p---- | Runs a CreateProcessRunner, on a CreateProcess structure, that--- is adjusted to pipe only from/to a single StdHandle, and passes--- the resulting Handle to an action.-withHandle-	:: StdHandle-	-> CreateProcessRunner-	-> CreateProcess-	-> (Handle -> IO a)-	-> IO a-withHandle h creator p a = creator p' $ a . select-  where-	base = p-		{ std_in = Inherit-		, std_out = Inherit-		, std_err = Inherit-		}-	(select, p') = case h of-		StdinHandle -> (stdinHandle, base { std_in = CreatePipe })-		StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe })-		StderrHandle -> (stderrHandle, base { std_err = CreatePipe })---- | Like withHandle, but passes (stdin, stdout) handles to the action.-withIOHandles-	:: CreateProcessRunner-	-> CreateProcess-	-> ((Handle, Handle) -> IO a)-	-> IO a-withIOHandles creator p a = creator p' $ a . ioHandles-  where-	p' = p-		{ std_in = CreatePipe-		, std_out = CreatePipe-		, std_err = Inherit-		}---- | Like withHandle, but passes (stdout, stderr) handles to the action.-withOEHandles-	:: CreateProcessRunner-	-> CreateProcess-	-> ((Handle, Handle) -> IO a)-	-> IO a-withOEHandles creator p a = creator p' $ a . oeHandles-  where-	p' = p-		{ std_in = Inherit-		, std_out = CreatePipe-		, std_err = CreatePipe-		}--withNullHandle :: (Handle -> IO a) -> IO a-withNullHandle = withFile devNull WriteMode---- | Forces the CreateProcessRunner to run quietly;--- both stdout and stderr are discarded.-withQuietOutput-	:: CreateProcessRunner-	-> CreateProcess-	-> IO ()-withQuietOutput creator p = withNullHandle $ \nullh -> do-	let p' = p-		{ std_out = UseHandle nullh-		, std_err = UseHandle nullh-		}-	creator p' $ const $ return ()---- | Stdout and stderr are discarded, while the process is fed stdin--- from the handle.-feedWithQuietOutput-	:: CreateProcessRunner-	-> CreateProcess-	-> (Handle -> IO a)-	-> IO a-feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do-	let p' = p-		{ std_in = CreatePipe-		, std_out = UseHandle nullh-		, std_err = UseHandle nullh-		}-	creator p' $ a . stdinHandle+withNullHandle :: (MonadIO m, MonadMask m) => (Handle -> m a) -> m a+withNullHandle = bracket+	(liftIO $ openFile devNull WriteMode)+	(liftIO . hClose)  devNull :: FilePath #ifndef mingw32_HOST_OS@@ -252,6 +134,7 @@ -- Get it wrong and the runtime crash will always happen, so should be -- easily noticed. type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle+ stdinHandle :: HandleExtractor stdinHandle (Just h, _, _, _) = h stdinHandle _ = error "expected stdinHandle"@@ -261,12 +144,6 @@ stderrHandle :: HandleExtractor stderrHandle (_, _, Just h, _) = h stderrHandle _ = error "expected stderrHandle"-ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)-ioHandles (Just hin, Just hout, _, _) = (hin, hout)-ioHandles _ = error "expected ioHandles"-oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)-oeHandles (_, Just hout, Just herr, _) = (hout, herr)-oeHandles _ = error "expected oeHandles"  processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle processHandle (_, _, _, pid) = pid@@ -301,6 +178,11 @@ 	debugProcess p 	Utility.Process.Shim.createProcess p +-- | Wrapper around 'System.Process.withCreateProcess' that does debug logging.+withCreateProcess :: CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a+withCreateProcess p action = bracket (createProcess p) cleanupProcess+	(\(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@@ -322,3 +204,21 @@ 	r <- Utility.Process.Shim.waitForProcess h 	debugM "Utility.Process" ("process done " ++ show r) 	return r++cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () +#if MIN_VERSION_process(1,6,4)+cleanupProcess = Utility.Process.Shim.cleanupProcess+#else+#warning building with process-1.6.3; some timeout features may not work well+cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do+	-- Unlike the real cleanupProcess, this does not wait+	-- for the process to finish in the background, so if+	-- the process ignores SIGTERM, this can block until the process+	-- gets around the exiting.+	terminateProcess pid+	let void _ = return ()+	maybe (return ()) (void . tryNonAsync . hClose) mb_stdin+	maybe (return ()) hClose mb_stdout+	maybe (return ()) hClose mb_stderr+	void $ waitForProcess pid+#endif

@@ -1,6 +1,6 @@ {- Process transcript  -- - Copyright 2012-2018 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -21,6 +21,7 @@ import System.Exit import Control.Concurrent.Async import Control.Monad+import Control.Exception #ifndef mingw32_HOST_OS import qualified System.Posix.IO #else@@ -45,36 +46,44 @@ #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order  - the process writes them. -}-	(readf, writef) <- System.Posix.IO.createPipe-	System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True-	System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True-	readh <- System.Posix.IO.fdToHandle readf-	writeh <- System.Posix.IO.fdToHandle writef-	p@(_, _, _, pid) <- createProcess $ cp-		{ std_in = if isJust input then CreatePipe else Inherit-		, std_out = UseHandle writeh-		, std_err = UseHandle writeh-		}-	hClose writeh--	get <- asyncreader readh-	writeinput input p-	transcript <- wait get+ 	let setup = do+		(readf, writef) <- System.Posix.IO.createPipe+		System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True+		System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True+		readh <- System.Posix.IO.fdToHandle readf+		writeh <- System.Posix.IO.fdToHandle writef+		return (readh, writeh)+	let cleanup (readh, writeh) = do+		hClose readh+		hClose writeh+	bracket setup cleanup $ \(readh, writeh) -> do+		let cp' = cp+			{ std_in = if isJust input then CreatePipe else Inherit+			, std_out = UseHandle writeh+			, std_err = UseHandle writeh+			}+		withCreateProcess cp' $ \hin hout herr pid -> do+			get <- asyncreader readh+			writeinput input (hin, hout, herr, pid)+			transcript <- wait get+			code <- waitForProcess pid+			return (transcript, code) #else {- This implementation for Windows puts stderr after stdout. -}-	p@(_, _, _, pid) <- createProcess $ cp+	let cp' = cp  		{ std_in = if isJust input then CreatePipe else Inherit 		, std_out = CreatePipe 		, std_err = CreatePipe 		}--	getout <- asyncreader (stdoutHandle p)-	geterr <- asyncreader (stderrHandle p)-	writeinput input p-	transcript <- (++) <$> wait getout <*> wait geterr+	withCreateProcess cp' \hin hout herr pid -> do+		let p = (hin, hout, herr, pid)+		getout <- asyncreader (stdoutHandle p)+		geterr <- asyncreader (stderrHandle p)+		writeinput input p+		transcript <- (++) <$> wait getout <*> wait geterr+		code <- waitForProcess pid+		return (transcript, code) #endif-	code <- waitForProcess pid-	return (transcript, code)   where 	asyncreader = async . hGetContentsStrict 

@@ -81,9 +81,9 @@ safeSystem command params = safeSystem' command params id  safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode-safeSystem' command params mkprocess = do-	(_, _, _, pid) <- createProcess p-	waitForProcess pid+safeSystem' command params mkprocess = +	withCreateProcess p $ \_ _ _ pid ->+		waitForProcess pid   where 	p = mkprocess $ proc command (toCommand params) 

@@ -12,11 +12,11 @@ is present in the specified remote.  When no remote is specified, it verifies if the key's content is present-somewhere, checking accessible remotes until it finds the content.+in any accessible remotes. -Exits 0 if the content is verified present, or 1 if it is verified to not-be present. If there is a problem, the special exit code 100 is used,-and an error message is output to stderr.+Exits 0 if the content is verified present in the remote, or 1 if it is+verified to not be present in the remote. If there is a problem, +the special exit code 100 is used, and an error message is output to stderr.  # OPTIONS 

@@ -86,6 +86,27 @@   the remote. You can later run `git annex sync --content` to upload   the files to the export. +* `--jobs=N` `-JN`++  Exports multiple files in parallel. This may be faster.+  For example: `-J4`  ++  Setting this to "cpus" will run one job per CPU core.++* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-progress`++  Include progress objects in JSON output.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # EXAMPLE  	git annex initremote myremote type=directory directory=/mnt/myremote \

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

@@ -18,7 +18,7 @@  If any special remotes were configured with autoenable=true, this will also attempt to enable them. See [[git-annex-initremote]](1).-To disable this, re-enable a remote with "autoenable=false", or+To prevent that, re-enable a remote with "autoenable=false", or mark it as dead (see [[git-annex-dead]](1)).  This command is entirely safe, although usually pointless, to run inside an@@ -47,6 +47,11 @@    When the version given is one that automatically upgrades to a newer   version, it will automatically use the newer version instead.++* --autoenable++  Only enable any special remotes that were configured with+  autoenable=true, do not otherwise initialize anything.  # SEE ALSO 

@@ -93,10 +93,10 @@ * `autoenable`    To avoid `git annex enableremote` needing to be run,-  you can pass "autoenable=true". Then when [[git-annex-init]](1)-  is run in a new clone, it will attempt to enable the special remote. Of-  course, this works best when the special remote does not need anything-  special to be done to get it enabled.+  you can pass "autoenable=true". Then when git-annex is run in a new clone,+  it will attempt to enable the special remote. Of course, this works best+  when the special remote does not need anything special to be done to get+  it enabled.  * `uuid` 

@@ -880,6 +880,28 @@    The default reserve is 1 megabyte. +* `annex.skipunknown`++  Set to true to make commands like "git-annex get" silently skip over+  items that are listed in the command line, but are not checked into git.++  Set to false to make it an error for commands like "git-annex get"+  to be asked to operate on files that are not checked into git.++  The default is currently true, but is planned to change to false in a+  release in 2022.++  Note that, when annex.skipunknown is false, a command like "git-annex get ."+  will fail if no files in the current directory are checked into git,+  but a command like "git-annex get" will not fail, because the current+  directory is not listed, but is implicit. Commands like "git-annex get foo/"+  will fail if no files in the directory are checked into git, but if+  at least one file is, it will ignore other files that are not. This is+  all the same as the behavior of "git-ls files --error-unmatch".+  +  Also note that git-annex skips files that are checked into git, but are+  not annexed files, this setting does not affect that.+ * `annex.largefiles`    Used to configure which files are large enough to be added to the annex.

@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20200522+Version: 8.20200617 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -294,10 +294,11 @@   location: git://git-annex.branchable.com/  custom-setup-  Setup-Depends: base (>= 4.11.1.0), hslogger, split, unix-compat, process,+  Setup-Depends: base (>= 4.11.1.0), hslogger, split, unix-compat,      filepath, exceptions, bytestring, directory, IfElse, data-default,     filepath-bytestring (>= 1.4.2.1.1),-    utf8-string, transformers, Cabal+    process (>= 1.6.3),+    async, utf8-string, transformers, Cabal  Executable git-annex   Main-Is: git-annex.hs@@ -310,7 +311,7 @@    stm (>= 2.3),    mtl (>= 2),    uuid (>= 1.2.6),-   process (>= 1.4.2),+   process (>= 1.6.3),    data-default,    case-insensitive,    random,@@ -956,6 +957,7 @@     Remote.Helper.Ssh     Remote.Hook     Remote.List+    Remote.List.Util     Remote.P2P     Remote.Rsync     Remote.Rsync.RsyncUrl@@ -1083,7 +1085,6 @@     Utility.NotificationBroadcaster     Utility.OptParse     Utility.PID-    Utility.Parallel     Utility.PartialPrelude     Utility.Path     Utility.Path.Max