packages feed

git-annex 8.20200720.1 → 8.20200810

raw patch · 61 files changed

+1118/−495 lines, 61 files

Files

Annex/Content.hs view
@@ -194,13 +194,15 @@  - rather than running the action.  -} lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a-lockContentShared key a = lockContentUsing lock key $ ifM (inAnnex key)-	( do-		u <- getUUID-		withVerifiedCopy LockedCopy u (return True) a-	, giveup $ "failed to lock content: not present"-	)+lockContentShared key a = lockContentUsing lock key notpresent $+	ifM (inAnnex key)+		( do+			u <- getUUID+			withVerifiedCopy LockedCopy u (return True) a+		, notpresent+		)   where+	notpresent = giveup $ "failed to lock content: not present" #ifndef mingw32_HOST_OS 	lock contentfile Nothing = tryLockShared Nothing contentfile 	lock _ (Just lockfile) = posixLocker tryLockShared lockfile@@ -212,9 +214,12 @@  - might remove it.  -  - If locking fails, throws an exception rather than running the action.+ -+ - But, if locking fails because the the content is not present, runs the+ - fallback action instead.  -}-lockContentForRemoval :: Key -> (ContentRemovalLock -> Annex a) -> Annex a-lockContentForRemoval key a = lockContentUsing lock key $ +lockContentForRemoval :: Key -> Annex a -> (ContentRemovalLock -> Annex a) -> Annex a+lockContentForRemoval key fallback a = lockContentUsing lock key fallback $  	a (ContentRemovalLock key)   where #ifndef mingw32_HOST_OS@@ -251,22 +256,31 @@ winLocker _ _ Nothing = return Nothing #endif -lockContentUsing :: ContentLocker -> Key -> Annex a -> Annex a-lockContentUsing locker key a = do+{- The fallback action is run if the ContentLocker throws an IO exception+ - and the content is not present. It's not guaranteed to always run when+ - the content is not present, because the content file is not always+ - the file that is locked eg on Windows a different file is locked. -}+lockContentUsing :: ContentLocker -> Key -> Annex a -> Annex a -> Annex a+lockContentUsing locker key fallback a = do 	contentfile <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) 	lockfile <- contentLockFile key 	bracket 		(lock contentfile lockfile)-		(unlock lockfile)-		(const a)+		(either (const noop) (unlock lockfile))+		go   where 	alreadylocked = giveup "content is locked" 	failedtolock e = giveup $ "failed to lock content: " ++ show e -	lock contentfile lockfile =-		(maybe alreadylocked return -			=<< locker contentfile lockfile)-		`catchIO` failedtolock+	lock contentfile lockfile = tryIO $+		maybe alreadylocked return +			=<< locker contentfile lockfile+	+	go (Right _) = a+	go (Left e) = ifM (inAnnex key)+		( failedtolock e+		, fallback +		)  #ifndef mingw32_HOST_OS 	unlock mlockfile lck = do@@ -335,12 +349,13 @@ 	-- RetrievalSecurityPolicy would cause verification to always fail. 	checkallowed a = case rsp of 		RetrievalAllKeysSecure -> a-		RetrievalVerifiableKeysSecure-			| Backend.isVerifiable key -> a-			| otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)+		RetrievalVerifiableKeysSecure -> ifM (Backend.isVerifiable key)+			( a+			, ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) 				( a 				, warnUnverifiableInsecure key >> return False 				)+			)  {- Verifies that a file is the expected content of a key.  -@@ -359,12 +374,13 @@ verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> FilePath -> Annex Bool verifyKeyContent rsp v verification k f = case (rsp, verification) of 	(_, Verified) -> return True-	(RetrievalVerifiableKeysSecure, _)-		| Backend.isVerifiable k -> verify-		| otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)+	(RetrievalVerifiableKeysSecure, _) -> ifM (Backend.isVerifiable k)+		( verify+		, ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) 			( verify 			, warnUnverifiableInsecure k >> return False 			)+		) 	(_, UnVerified) -> ifM (shouldVerify v) 		( verify 		, return True@@ -377,9 +393,11 @@ 		Just size -> do 			size' <- liftIO $ catchDefaultIO 0 $ getFileSize f 			return (size' == size)-	verifycontent = case Types.Backend.verifyKeyContent =<< Backend.maybeLookupBackendVariety (fromKey keyVariety k) of+	verifycontent = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case 		Nothing -> return True-		Just verifier -> verifier k f+		Just b -> case Types.Backend.verifyKeyContent b of+			Nothing -> return True+			Just verifier -> verifier k f  warnUnverifiableInsecure :: Key -> Annex () warnUnverifiableInsecure k = warning $ unwords@@ -498,12 +516,13 @@ 	alreadyhave = liftIO $ removeFile src  checkSecureHashes :: Key -> Annex (Maybe String)-checkSecureHashes key-	| Backend.isCryptographicallySecure key = return Nothing-	| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig)+checkSecureHashes key = ifM (Backend.isCryptographicallySecure key)+	( return Nothing+	, ifM (annexSecureHashesOnly <$> Annex.getGitConfig) 		( return $ Just $ "annex.securehashesonly blocked adding " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key" 		, return Nothing 		)+	)  checkSecureHashes' :: Key -> Annex Bool checkSecureHashes' key = checkSecureHashes key >>= \case
Annex/Drop.hs view
@@ -16,6 +16,7 @@ import qualified Command.Drop import Command import Annex.Wanted+import Annex.Content import Annex.SpecialRemote.Config import qualified Database.Keys import Git.FilePath@@ -118,7 +119,8 @@ 			)  	dropl fs n = checkdrop fs n Nothing $ \numcopies ->-		Command.Drop.startLocal afile ai numcopies key preverified+		stopUnless (inAnnex key) $+			Command.Drop.startLocal afile ai numcopies key preverified  	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies -> 		Command.Drop.startRemote afile ai numcopies key r
+ Annex/ExternalAddonProcess.hs view
@@ -0,0 +1,93 @@+{- External addon processes for special remotes and backends.+ -+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.ExternalAddonProcess where++import qualified Annex+import Annex.Common+import Git.Env+import Utility.Shell+import Messages.Progress++import Control.Concurrent.Async+import System.Log.Logger (debugM)++data ExternalAddonProcess = ExternalAddonProcess+	{ externalSend :: Handle+	, externalReceive :: Handle+	-- Shut down the process. With True, it's forced to stop+	-- immediately.+	, externalShutdown :: Bool -> IO ()+	, externalPid :: ExternalAddonPID+	, externalProgram :: String+	}++type ExternalAddonPID = Int++data ExternalAddonStartError+	= ProgramNotInstalled String+	| ProgramFailure String++startExternalAddonProcess :: String -> ExternalAddonPID -> Annex (Either ExternalAddonStartError ExternalAddonProcess)+startExternalAddonProcess basecmd pid = do+	errrelayer <- mkStderrRelayer+	g <- Annex.gitRepo+	cmdpath <- liftIO $ searchPath basecmd+	liftIO $ start errrelayer g cmdpath+  where+	start errrelayer g cmdpath = do+		(cmd, ps) <- maybe (pure (basecmd, [])) findShellCommand cmdpath+		let basep = (proc cmd (toCommand ps))+			{ std_in = CreatePipe+			, std_out = CreatePipe+			, std_err = CreatePipe+			}+		p <- propgit g basep+		tryNonAsync (createProcess p) >>= \case+			Right v -> (Right <$> started cmd errrelayer v)+				`catchNonAsync` const (runerr cmdpath)+			Left _ -> runerr cmdpath+	+	started cmd errrelayer pall@(Just hin, Just hout, Just herr, ph) = do+		stderrelay <- async $ errrelayer herr+		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 $ ExternalAddonProcess+			{ externalSend = hin+			, externalReceive = hout+			, externalPid = pid+			, externalShutdown = shutdown+			, externalProgram = cmd+			}+	started _ _ _ = giveup "internal"++	propgit g p = do+		environ <- propGitEnv g+		return $ p { env = Just environ }++	runerr (Just cmd) =+		return $ Left $ ProgramFailure $+			"Cannot run " ++ cmd ++ " -- Make sure it's executable and that its dependencies are installed."+	runerr Nothing = do+		path <- intercalate ":" <$> getSearchPath+		return $ Left $ ProgramNotInstalled $+			"Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")"++protocolDebug :: ExternalAddonProcess -> Bool -> String -> IO ()+protocolDebug external sendto line = debugM "external" $ unwords+	[ externalProgram external ++ +		"[" ++ show (externalPid external) ++ "]"+	, if sendto then "<--" else "-->"+	, line+	]
Annex/Transfer.hs view
@@ -177,14 +177,15 @@  - tend to be configured to reject it, so Upload is also prevented.  -} checkSecureHashes :: Observable v => Transfer -> Annex v -> Annex v-checkSecureHashes t a-	| isCryptographicallySecure (transferKey t) = a-	| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig)+checkSecureHashes t a = ifM (isCryptographicallySecure (transferKey t))+	( a+	, ifM (annexSecureHashesOnly <$> Annex.getGitConfig) 		( do 			warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key" 			return observeFailure 		, a 		)+	)   where 	variety = fromKey keyVariety (transferKey t)
Annex/UntrustedFilePath.hs view
@@ -31,17 +31,26 @@  - that case.  -} sanitizeFilePath :: String -> FilePath-sanitizeFilePath [] = "file"-sanitizeFilePath f = leading (map sanitize f)+sanitizeFilePath = sanitizeLeadingFilePathCharacter . sanitizeFilePathComponent++{- For when the filepath is being built up out of components that should be+ - individually sanitized, this can be used for each component, followed by+ - sanitizeLeadingFilePathCharacter for the whole thing.+ -}+sanitizeFilePathComponent :: String -> String+sanitizeFilePathComponent = map sanitize   where 	sanitize c 		| c == '.' || c == '-' = c 		| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' 		| otherwise = c -	leading ('.':s) = '_':s-	leading ('-':s) = '_':s-	leading s = s+sanitizeLeadingFilePathCharacter :: String -> FilePath+sanitizeLeadingFilePathCharacter [] = "file"+sanitizeLeadingFilePathCharacter ('.':s) = '_':s+sanitizeLeadingFilePathCharacter ('-':s) = '_':s+sanitizeLeadingFilePathCharacter ('/':s) = '_':s+sanitizeLeadingFilePathCharacter s = s  escapeSequenceInFilePath :: FilePath -> Bool escapeSequenceInFilePath f = '\ESC' `elem` f
Assistant/Unused.hs view
@@ -76,7 +76,7 @@ 	forM_ oldkeys $ \k -> do 		debug ["removing old unused key", serializeKey k] 		liftAnnex $ tryNonAsync $ do-			lockContentForRemoval k removeAnnex+			lockContentForRemoval k noop removeAnnex 			logStatus k InfoMissing   where 	boundry = durationToPOSIXTime <$> duration
Assistant/Upgrade.hs view
@@ -99,7 +99,7 @@ 		, transferKeyData = fromKey id k 		} 	cleanup = liftAnnex $ do-		lockContentForRemoval k removeAnnex+		lockContentForRemoval k noop removeAnnex 		setUrlMissing k u 		logStatus k InfoMissing @@ -117,7 +117,7 @@ 	| otherwise = cleanup   where 	k = mkKey $ const $ distributionKey d-	fsckit f = case Backend.maybeLookupBackendVariety (fromKey keyVariety k) of+	fsckit f = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case 		Nothing -> return $ Just f 		Just b -> case Types.Backend.verifyKeyContent b of 			Nothing -> return $ Just f
Backend.hs view
@@ -6,12 +6,13 @@  -}  module Backend (-	list,+	builtinList, 	defaultBackend, 	genKey, 	getBackend, 	chooseBackend, 	lookupBackendVariety,+	lookupBuiltinBackendVariety, 	maybeLookupBackendVariety, 	isStableKey, 	isCryptographicallySecure,@@ -26,16 +27,18 @@ import qualified Types.Backend as B import Utility.Metered --- When adding a new backend, import it here and add it to the list.+-- When adding a new backend, import it here and add it to the builtinList. import qualified Backend.Hash import qualified Backend.WORM import qualified Backend.URL+import qualified Backend.External  import qualified Data.Map as M import qualified Data.ByteString.Char8 as S8 -list :: [Backend]-list = Backend.Hash.backends ++ Backend.WORM.backends ++ Backend.URL.backends+{- Build-in backends. Does not include externals. -}+builtinList :: [Backend]+builtinList = Backend.Hash.backends ++ Backend.WORM.backends ++ Backend.URL.backends  {- Backend to use by default when generating a new key. -} defaultBackend :: Annex Backend@@ -44,9 +47,9 @@ 	cache = do 		n <- maybe (annexBackend <$> Annex.getGitConfig) (return . Just) 			=<< Annex.getState Annex.forcebackend-		let b = case n of+		b <- case n of 			Just name | valid name -> lookupname name-			_ -> Prelude.head list+			_ -> pure (Prelude.head builtinList) 		Annex.changeState $ \s -> s { Annex.backend = Just b } 		return b 	valid name = not (null name)@@ -72,12 +75,16 @@ 		| otherwise = c  getBackend :: FilePath -> Key -> Annex (Maybe Backend)-getBackend file k = case maybeLookupBackendVariety (fromKey keyVariety k) of+getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case 	Just backend -> return $ Just backend 	Nothing -> do-		warning $ "skipping " ++ file ++ " (unknown backend " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ ")"+		warning $ "skipping " ++ file ++ " (" ++ unknownBackendVarietyMessage (fromKey keyVariety k) ++ ")" 		return Nothing +unknownBackendVarietyMessage :: KeyVariety -> String+unknownBackendVarietyMessage v =+	"unknown backend " ++ decodeBS (formatKeyVariety v)+ {- Looks up the backend that should be used for a file.  - That can be configured on a per-file basis in the gitattributes file,  - or forced with --backend. -}@@ -85,29 +92,38 @@ chooseBackend f = Annex.getState Annex.forcebackend >>= go   where 	go Nothing = maybeLookupBackendVariety . parseKeyVariety . encodeBS-		<$> checkAttr "annex.backend" f+		=<< checkAttr "annex.backend" f 	go (Just _) = Just <$> defaultBackend  {- Looks up a backend by variety. May fail if unsupported or disabled. -}-lookupBackendVariety :: KeyVariety -> Backend-lookupBackendVariety v = fromMaybe unknown $ maybeLookupBackendVariety v-  where-	unknown = giveup $ "unknown backend " ++ decodeBS (formatKeyVariety v)+lookupBackendVariety :: KeyVariety -> Annex Backend+lookupBackendVariety v = fromMaybe (giveup (unknownBackendVarietyMessage v))+	<$> maybeLookupBackendVariety v -maybeLookupBackendVariety :: KeyVariety -> Maybe Backend-maybeLookupBackendVariety v = M.lookup v varietyMap+lookupBuiltinBackendVariety :: KeyVariety -> Backend+lookupBuiltinBackendVariety v = fromMaybe (giveup (unknownBackendVarietyMessage v)) $+	maybeLookupBuiltinBackendVariety v +maybeLookupBackendVariety :: KeyVariety -> Annex (Maybe Backend)+maybeLookupBackendVariety (ExternalKey s hasext) =+	Just <$> Backend.External.makeBackend s hasext+maybeLookupBackendVariety v = +	pure $ M.lookup v varietyMap++maybeLookupBuiltinBackendVariety :: KeyVariety -> Maybe Backend+maybeLookupBuiltinBackendVariety v = M.lookup v varietyMap+ varietyMap :: M.Map KeyVariety Backend-varietyMap = M.fromList $ zip (map B.backendVariety list) list+varietyMap = M.fromList $ zip (map B.backendVariety builtinList) builtinList -isStableKey :: Key -> Bool+isStableKey :: Key -> Annex Bool isStableKey k = maybe False (`B.isStableKey` k) -	(maybeLookupBackendVariety (fromKey keyVariety k))+	<$> maybeLookupBackendVariety (fromKey keyVariety k) -isCryptographicallySecure :: Key -> Bool+isCryptographicallySecure :: Key -> Annex Bool isCryptographicallySecure k = maybe False (`B.isCryptographicallySecure` k)-	(maybeLookupBackendVariety (fromKey keyVariety k))+	<$> maybeLookupBackendVariety (fromKey keyVariety k) -isVerifiable :: Key -> Bool-isVerifiable k = maybe False (isJust . B.verifyKeyContent)-	(maybeLookupBackendVariety (fromKey keyVariety k))+isVerifiable :: Key -> Annex Bool+isVerifiable k = maybe False (isJust . B.verifyKeyContent) +	<$> maybeLookupBackendVariety (fromKey keyVariety k)
+ Backend/External.hs view
@@ -0,0 +1,372 @@+{- git-annex external backend+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE TypeSynonymInstances #-}++module Backend.External (makeBackend) where++import Annex.Common+import Annex.ExternalAddonProcess+import Backend.Utilities+import Types.Key+import Types.Backend+import Types.KeySource+import Utility.Metered+import qualified Utility.SimpleProtocol as Proto++import qualified Data.ByteString as S+import qualified Data.Map.Strict as M+import Data.Char+import Control.Concurrent+import System.IO.Unsafe (unsafePerformIO)+import System.Log.Logger (debugM)++newtype ExternalBackendName = ExternalBackendName S.ByteString+	deriving (Show, Eq, Ord)++-- Makes Backend representing an external backend of any type.+-- If the program is not available or doesn't work, makes a Backend+-- that cannot generate or verify keys, but that still lets the keys be+-- basically used.+makeBackend :: S.ByteString -> HasExt -> Annex Backend+makeBackend bname hasext =+	withExternalState ebname hasext (return . externalBackend)+  where+	ebname = ExternalBackendName bname++makeBackend' :: ExternalBackendName -> HasExt -> Either ExternalAddonStartError ExternalAddonProcess -> Annex Backend+makeBackend' ebname@(ExternalBackendName bname) hasext (Right p) = do+	let st = ExternalState+		{ externalAddonProcess = Right p+		, externalBackend = unavailBackend ebname hasext+		}+	canverify <- handleRequest st CANVERIFY (pure False) $ \case+		CANVERIFY_YES -> result True+		CANVERIFY_NO -> result False+		_ -> Nothing+	isstable <- handleRequest st ISSTABLE (pure False) $ \case+		ISSTABLE_YES -> result True+		ISSTABLE_NO -> result False+		_ -> Nothing+	iscryptographicallysecure <- handleRequest st ISCRYPTOGRAPHICALLYSECURE (pure False) $ \case+		ISCRYPTOGRAPHICALLYSECURE_YES -> result True+		ISCRYPTOGRAPHICALLYSECURE_NO -> result False+		_ -> Nothing+	return $ Backend+		{ backendVariety = ExternalKey bname hasext+		, genKey = Just $ genKeyExternal ebname hasext+		, verifyKeyContent = if canverify+			then Just $ verifyKeyContentExternal ebname hasext+				-- The protocol supports PROGRESS here,+				-- but it's not actually used. It was put+				-- in to avoid needing a protocol version+				-- bump if progress handling is later added.+				nullMeterUpdate+			else Nothing+		, canUpgradeKey = Nothing+		, fastMigrate = Nothing+		, isStableKey = const isstable+		, isCryptographicallySecure = const iscryptographicallysecure+		}+makeBackend' ebname hasext (Left _) = return $ unavailBackend ebname hasext++unavailBackend :: ExternalBackendName -> HasExt -> Backend+unavailBackend (ExternalBackendName bname) hasext = +	Backend+		{ backendVariety = ExternalKey bname hasext+		, genKey = Nothing+		, verifyKeyContent = Nothing+		, canUpgradeKey = Nothing+		, fastMigrate = Nothing+		, isStableKey = const False+		, isCryptographicallySecure = const False+		}++genKeyExternal :: ExternalBackendName -> HasExt -> KeySource -> MeterUpdate -> Annex Key+genKeyExternal ebname hasext ks meterupdate = +	withExternalState ebname hasext $ \st ->+		handleRequest st req notavail go+  where+	req = GENKEY (fromRawFilePath (contentLocation ks))+	notavail = giveup $ "Cannot generate a key, since " ++ externalBackendProgram ebname ++ " is not available."+	+	go (GENKEY_SUCCESS pk) = Just $ Result <$> fromProtoKey pk hasext ks+	go (GENKEY_FAILURE msg) = Just $ giveup $+		"External backend program failed to generate a key: " ++ msg+	go (PROGRESS bytesprocessed) = Just $ do+		liftIO $ meterupdate bytesprocessed+		return $ GetNextMessage go+	go _ = Nothing++verifyKeyContentExternal :: ExternalBackendName -> HasExt -> MeterUpdate -> Key -> FilePath -> Annex Bool+verifyKeyContentExternal ebname hasext meterupdate k f = +	withExternalState ebname hasext $ \st ->+		handleRequest st req notavail go+  where+	req = VERIFYKEYCONTENT (toProtoKey k) f++	-- This should not be able to happen, because CANVERIFY is checked+	-- before this function is enable, and so the external program +	-- is available. But if it does, fail the verification.+	notavail = return False++	go VERIFYKEYCONTENT_SUCCESS = result True+	go VERIFYKEYCONTENT_FAILURE = result False+	go (PROGRESS bytesprocessed) = Just $ do+		liftIO $ meterupdate bytesprocessed+		return $ GetNextMessage go+	go _ = Nothing++-- State about a running external backend program.+data ExternalState = ExternalState+	{ externalAddonProcess :: Either ExternalAddonStartError ExternalAddonProcess+	, externalBackend :: Backend+	}++handleRequest :: ExternalState -> Request -> Annex a -> ResponseHandler a -> Annex a+handleRequest st req whenunavail responsehandler =+	withExternalAddon st whenunavail $ \p -> do+		sendMessage p req+		let loop = receiveResponse p responsehandler+			(Just . handleAsyncMessage loop)+		loop+  where+	handleAsyncMessage _ (ERROR err) = do+		warning ("external special remote error: " ++ err)+		whenunavail+	handleAsyncMessage loop (DEBUG msg) = do+		liftIO $ debugM "external" msg+		loop++withExternalAddon :: ExternalState -> a -> (ExternalAddonProcess -> a) -> a+withExternalAddon st whenunavail a = case externalAddonProcess st of+	Right addon -> a addon+	Left _ -> whenunavail++sendMessage :: Proto.Sendable m => ExternalAddonProcess -> m -> Annex ()+sendMessage p m = liftIO $ do+	protocolDebug p True line+	hPutStrLn (externalSend p) line+	hFlush (externalSend p)+  where+	line = unwords $ Proto.formatMessage m++{- A response handler can yeild a result, or it can request that another+ - message be consumed from the external. -}+data ResponseHandlerResult a+	= Result a+	| GetNextMessage (ResponseHandler a)++type ResponseHandler a = Response -> Maybe (Annex (ResponseHandlerResult a))++result :: a -> Maybe (Annex (ResponseHandlerResult a))+result = Just . return . Result++{- Waits for a message from the external backend, and passes it to the+ - apppropriate handler. + -+ - If the handler returns Nothing, this is a protocol error.+ -}+receiveResponse+	:: ExternalAddonProcess+	-> ResponseHandler a+	-> (AsyncMessage -> Maybe (Annex a))+	-> Annex a+receiveResponse p handleresponse handleasync =+	go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive p)+  where+	go Nothing = protocolError False ""+	go (Just s) = do+		liftIO $ protocolDebug p False s+		case Proto.parseMessage s :: Maybe Response of+			Just resp -> case handleresponse resp of+				Nothing -> protocolError True s+				Just callback -> callback >>= \case+					Result a -> return a+					GetNextMessage handleresponse' ->+						receiveResponse p handleresponse' handleasync+			Nothing -> case Proto.parseMessage s :: Maybe AsyncMessage of+				Just msg -> maybe (protocolError True s) id (handleasync msg)+				Nothing -> protocolError False s++	protocolError parsed s = giveup $ "external backend protocol error, unexpectedly received \"" ++ s ++ "\" " +++		if parsed+			then "(message not allowed at this time)"+			else "(unable to parse message)"++-- Information about pools of of running external backends that are+-- available to use is stored in this global.+{-# NOINLINE poolVar #-}+poolVar :: MVar (M.Map ExternalBackendName (ExternalAddonPID, [ExternalState]))+poolVar = unsafePerformIO $ newMVar M.empty++-- Starts a new instance of an external backend.+-- Does not add it to the poolVar; caller should add it once it's done+-- using it.+newExternalState :: ExternalBackendName -> HasExt -> ExternalAddonPID -> Annex ExternalState+newExternalState ebname hasext pid = do+	st <- startExternalAddonProcess basecmd pid+	st' <- case st of+		Left (ProgramNotInstalled msg) -> warnonce msg >> return st+		Left (ProgramFailure msg) -> warnonce msg >> return st+		Right p -> do+			sendMessage p GETVERSION+			v <- receiveResponse p+				(\resp -> case resp of+					VERSION v -> result v+					_ -> Nothing+				)+				(const Nothing)+			if v `notElem` supportedProtocolVersions+				then do+					warnonce (basecmd ++ " uses an unsupported version of the external backend protocol")+					return $ Left (ProgramFailure "bad protocol version")+				else return (Right p)+	backend <- makeBackend' ebname hasext st'+	return $ ExternalState+		{ externalAddonProcess = st'+		, externalBackend = backend+		}+  where+	basecmd = externalBackendProgram ebname+	warnonce msg = when (pid == 1) $+		warning msg++externalBackendProgram :: ExternalBackendName -> String+externalBackendProgram (ExternalBackendName bname) = "git-annex-backend-X" ++ decodeBS' bname++-- Runs an action with an ExternalState, starting a new external backend+-- process if necessary. It is returned to the pool once the action+-- finishes successfully. On exception, it's shut down.+withExternalState :: ExternalBackendName -> HasExt -> (ExternalState -> Annex a) -> Annex a+withExternalState bname hasext a = do+	st <- get+	r <- a st `onException` shutdown st+	put st -- only when no exception is thrown+	return r+  where+	get = do+		m <- liftIO $ takeMVar poolVar+		case fromMaybe (1, []) (M.lookup bname m) of+			(pid, []) -> do+				let m' = M.insert bname (succ pid, []) m+				liftIO $ putMVar poolVar m'+				newExternalState bname hasext pid+			(pid, (st:rest)) -> do+				let m' = M.insert bname (pid, rest) m+				liftIO $ putMVar poolVar m'+				return st+	put st = liftIO $ modifyMVar_ poolVar $+		pure . M.adjust (\(pid, l) -> (pid, st:l)) bname+	shutdown st = liftIO $+		withExternalAddon st noop (flip externalShutdown False)++-- This is a key as seen by the protocol consumer. When the "E" variant+-- of the external backend is in use, it does not include an extension.+-- And it's assumed not to contain spaces or newlines, or anything besides+-- ascii alphanumerics, because the protocol does not allow keys containing+-- such things.+newtype ProtoKey = ProtoKey Key+	deriving (Show)++fromProtoKey :: ProtoKey -> HasExt -> KeySource -> Annex Key+fromProtoKey (ProtoKey k) (HasExt False) _ = pure k+fromProtoKey (ProtoKey k) hasext@(HasExt True) source =+	addE source (setHasExt hasext) k++toProtoKey :: Key -> ProtoKey+toProtoKey k = ProtoKey $ alterKey k $ \d -> d+	-- The extension can be easily removed, because the protocol+	-- documentation does not allow '.' to be used in the keyName,+	-- so the first one is the extension.+	{ keyName = S.takeWhile (/= dot) (keyName d)+	, keyVariety = setHasExt (HasExt False) (keyVariety d)+	}+  where+	dot = fromIntegral (ord '.')++setHasExt :: HasExt -> KeyVariety -> KeyVariety+setHasExt hasext (ExternalKey name _) = ExternalKey name hasext+setHasExt _ v = v++instance Proto.Serializable ProtoKey where+	serialize (ProtoKey k) = Proto.serialize k+	deserialize = fmap ProtoKey . Proto.deserialize++data Request+	= GETVERSION+	| CANVERIFY+	| ISSTABLE+	| ISCRYPTOGRAPHICALLYSECURE+	| GENKEY FilePath+	| VERIFYKEYCONTENT ProtoKey FilePath+	deriving (Show)++data Response+	= VERSION ProtocolVersion+	| CANVERIFY_YES+	| CANVERIFY_NO+	| ISSTABLE_YES+	| ISSTABLE_NO+	| ISCRYPTOGRAPHICALLYSECURE_YES+	| ISCRYPTOGRAPHICALLYSECURE_NO+	| GENKEY_SUCCESS ProtoKey+	| GENKEY_FAILURE ErrorMsg+	| VERIFYKEYCONTENT_SUCCESS+	| VERIFYKEYCONTENT_FAILURE+	| PROGRESS BytesProcessed+	deriving (Show)++data AsyncMessage+	= ERROR ErrorMsg+	| DEBUG String+	deriving (Show)++type ErrorMsg = String++newtype ProtocolVersion = ProtocolVersion Int+	deriving (Show, Eq)++supportedProtocolVersions :: [ProtocolVersion]+supportedProtocolVersions = [ProtocolVersion 1]++instance Proto.Serializable ProtocolVersion where+	serialize (ProtocolVersion n) = show n+	deserialize = ProtocolVersion <$$> readish++instance Proto.Sendable AsyncMessage where+	formatMessage (ERROR err) = ["ERROR", Proto.serialize err]+	formatMessage (DEBUG msg) = ["DEBUG", Proto.serialize msg]++instance Proto.Receivable AsyncMessage where+	parseCommand "ERROR" = Proto.parse1 ERROR+	parseCommand "DEBUG" = Proto.parse1 DEBUG+	parseCommand _ = Proto.parseFail++instance Proto.Sendable Request where+	formatMessage GETVERSION = ["GETVERSION"]+	formatMessage CANVERIFY = ["CANVERIFY"]+	formatMessage ISSTABLE = ["ISSTABLE"]+	formatMessage ISCRYPTOGRAPHICALLYSECURE = ["ISCRYPTOGRAPHICALLYSECURE"]+	formatMessage (GENKEY file) = ["GENKEY", Proto.serialize file]+	formatMessage (VERIFYKEYCONTENT key file) =+		["VERIFYKEYCONTENT", Proto.serialize key, Proto.serialize file]++instance Proto.Receivable Response where+	parseCommand "VERSION" = Proto.parse1 VERSION+	parseCommand "CANVERIFY-YES" = Proto.parse0 CANVERIFY_YES+	parseCommand "CANVERIFY-NO" = Proto.parse0 CANVERIFY_NO+	parseCommand "ISSTABLE-YES" = Proto.parse0 ISSTABLE_YES+	parseCommand "ISSTABLE-NO" = Proto.parse0 ISSTABLE_NO+	parseCommand "ISCRYPTOGRAPHICALLYSECURE-YES" = Proto.parse0 ISCRYPTOGRAPHICALLYSECURE_YES+	parseCommand "ISCRYPTOGRAPHICALLYSECURE-NO" = Proto.parse0 ISCRYPTOGRAPHICALLYSECURE_NO+	parseCommand "GENKEY-SUCCESS" = Proto.parse1 GENKEY_SUCCESS+	parseCommand "GENKEY-FAILURE" = Proto.parse1 GENKEY_FAILURE+	parseCommand "VERIFYKEYCONTENT-SUCCESS" = Proto.parse0 VERIFYKEYCONTENT_SUCCESS+	parseCommand "VERIFYKEYCONTENT-FAILURE" = Proto.parse0 VERIFYKEYCONTENT_FAILURE+	parseCommand "PROGRESS" = Proto.parse1 PROGRESS+	parseCommand _ = Proto.parseFail
Backend/Hash.hs view
@@ -20,13 +20,11 @@ import Types.KeySource import Utility.Hash import Utility.Metered+import Backend.Utilities  import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L-import qualified System.FilePath.ByteString as P-import Data.Char-import Data.Word import Control.DeepSeq import Control.Exception (evaluate) @@ -114,29 +112,8 @@ {- Extension preserving keys. -} keyValueE :: Hash -> KeySource -> MeterUpdate -> Annex Key keyValueE hash source meterupdate =-	keyValue hash source meterupdate >>= addE-  where-	addE k = do-		maxlen <- annexMaxExtensionLength <$> Annex.getGitConfig-		let ext = selectExtension maxlen (keyFilename source)-		return $ alterKey k $ \d -> d-			{ keyName = keyName d <> ext-			, keyVariety = hashKeyVariety hash (HasExt True)-			}--selectExtension :: Maybe Int -> RawFilePath -> S.ByteString-selectExtension maxlen f-	| null es = ""-	| otherwise = S.intercalate "." ("":es)-  where-	es = filter (not . S.null) $ reverse $-		take 2 $ filter (S.all validInExtension) $-		takeWhile shortenough $-		reverse $ S.split (fromIntegral (ord '.')) (P.takeExtensions f)-	shortenough e = S.length e <= fromMaybe maxExtensionLen maxlen--maxExtensionLen :: Int-maxExtensionLen = 4 -- long enough for "jpeg"+	keyValue hash source meterupdate+		>>= addE source (const $ hashKeyVariety hash (HasExt True))  {- A key's checksum is checked during fsck when it's content is present  - except for in fast mode. -}@@ -166,13 +143,6 @@ keyHash :: Key -> S.ByteString keyHash = fst . splitKeyNameExtension -validInExtension :: Word8 -> Bool-validInExtension c-	| isAlphaNum (chr (fromIntegral c)) = True-	| fromIntegral c == ord '.' = True-	| c <= 127 = False -- other ascii: spaces, punctuation, control chars-	| otherwise = True -- utf8 is allowed, also other encodings- {- Upgrade keys that have the \ prefix on their hash due to a bug, or  - that contain non-alphanumeric characters in their extension.  -@@ -310,10 +280,10 @@ 	let b = genBackendE (SHA2Hash (HashSize 256)) 	    gk = case genKey b of 		Nothing -> Nothing-		Just f -> Just (\ks p -> addE <$> f ks p)+		Just f -> Just (\ks p -> addTestE <$> f ks p) 	in b { genKey = gk }   where-	addE k = alterKey k $ \d -> d+	addTestE k = alterKey k $ \d -> d 		{ keyName = keyName d <> longext 		} 	longext = ".this-is-a-test-key"
Backend/Utilities.hs view
@@ -1,17 +1,25 @@ {- git-annex backend utilities  -- - 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.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Backend.Utilities where  import Annex.Common+import qualified Annex import Utility.Hash+import Types.Key+import Types.KeySource  import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+import qualified System.FilePath.ByteString as P+import Data.Char+import Data.Word  {- Generates a keyName from an input string. Takes care of sanitizing it.  - If it's not too long, the full string is used as the keyName.@@ -32,3 +40,34 @@ 	sha256len = 64 	md5len = 32 +{- Converts a key to a version that includes an extension from the+ - file that the key was generated from.  -}+addE :: KeySource -> (KeyVariety -> KeyVariety) -> Key -> Annex Key+addE source sethasext k = do+	maxlen <- annexMaxExtensionLength <$> Annex.getGitConfig+	let ext = selectExtension maxlen (keyFilename source)+	return $ alterKey k $ \d -> d+		{ keyName = keyName d <> ext+		, keyVariety = sethasext (keyVariety d)+		}++selectExtension :: Maybe Int -> RawFilePath -> S.ByteString+selectExtension maxlen f+	| null es = ""+	| otherwise = S.intercalate "." ("":es)+  where+	es = filter (not . S.null) $ reverse $+		take 2 $ filter (S.all validInExtension) $+		takeWhile shortenough $+		reverse $ S.split (fromIntegral (ord '.')) (P.takeExtensions f)+	shortenough e = S.length e <= fromMaybe maxExtensionLen maxlen++validInExtension :: Word8 -> Bool+validInExtension c+	| isAlphaNum (chr (fromIntegral c)) = True+	| fromIntegral c == ord '.' = True+	| c <= 127 = False -- other ascii: spaces, punctuation, control chars+	| otherwise = True -- utf8 is allowed, also other encodings++maxExtensionLen :: Int+maxExtensionLen = 4 -- long enough for "jpeg"
CHANGELOG view
@@ -1,3 +1,31 @@+git-annex (8.20200810) upstream; urgency=medium++  * Added support for external backend programs. So if you want a hash+    that git-annex doesn't support, or something stranger, you can write a+    small program to implement it.+  * Fix a bug in find --branch in the previous version.+  * importfeed: Fix reversion that caused some '.' in filenames to be+    replaced with '_'+  * Fix a lock file descriptor leak that could occur when running commands+    like git-annex add with -J. Bug was introduced as part of a different FD+    leak fix in version 6.20160318.+  * Fix a hang when using git-annex with an old openssh 7.2p2, which had+    some weird inheriting of ssh FDs by sshd. Bug was introduced in+    git-annex version 7.20200202.7.+  * move, copy --to: Sped up seeking files by 2x.+  * drop: Sped up seeking files to drop by 2x, and also some performance+    improvements to checking numcopies.+  * Deal with unusual IFS settings in the shell scripts for linux+    standalone and OSX app.+    Thanks, Yaroslav Halchenko+  * Avoid complaining that a file with "is beyond a symbolic link"+    when the filepath is absolute and the symlink in question is not+    actually inside the git repository.+  * Slightly sped up the linux standalone bundle.+  * Support building with dlist-1.0++ -- Joey Hess <id@joeyh.name>  Mon, 10 Aug 2020 13:04:04 -0400+ git-annex (8.20200720.1) upstream; urgency=medium    * Fix a bug in find --batch in the previous version.
CmdLine/Action.hs view
@@ -43,9 +43,6 @@ commandActions :: [CommandStart] -> Annex () commandActions = mapM_ commandAction -commandAction' :: (a -> b -> CommandStart) -> a -> b -> Annex ()-commandAction' start a b = commandAction $ start a b- {- Runs one of the actions needed to perform a command.  - Individual actions can fail without stopping the whole command,  - including by throwing non-async exceptions.
CmdLine/Batch.hs view
@@ -1,6 +1,6 @@ {- git-annex batch commands  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -11,10 +11,13 @@ import Types.Command import CmdLine.Action import CmdLine.GitAnnex.Options+import CmdLine.Seek import Options.Applicative import Limit import Types.FileMatcher import Annex.BranchState+import Annex.WorkTree+import Annex.Content  data BatchMode = Batch BatchFormat | NoBatch @@ -110,12 +113,22 @@  -- Like batchStart, but checks the file matching options -- and skips non-matching files.-batchFilesMatching :: BatchFormat -> (FilePath -> CommandStart) -> Annex ()+batchFilesMatching :: BatchFormat -> (RawFilePath -> CommandStart) -> Annex () batchFilesMatching fmt a = do 	matcher <- getMatcher 	batchStart fmt $ \f -> 		let f' = toRawFilePath f 		in ifM (matcher $ MatchingFile $ FileInfo f' f')-			( a f+			( a f' 			, return Nothing 			)++batchAnnexedFilesMatching :: BatchFormat -> AnnexedFileSeeker -> Annex ()+batchAnnexedFilesMatching fmt seeker = batchFilesMatching fmt $+	whenAnnexed $ \f k -> case checkContentPresent seeker of+		Just v -> do+			present <- inAnnex k+			if present == v+				then startAction seeker f k+				else return Nothing+		Nothing -> startAction seeker f k
CmdLine/GitAnnex/Options.hs view
@@ -440,4 +440,4 @@ 		 completeBackends :: HasCompleter f => Mod f a completeBackends = completeWith $-	map (decodeBS . formatKeyVariety . Backend.backendVariety) Backend.list+	map (decodeBS . formatKeyVariety . Backend.backendVariety) Backend.builtinList
CmdLine/Seek.hs view
@@ -44,30 +44,31 @@ import qualified Database.Keys import qualified Utility.RawFilePath as R import Utility.Tuple+import CmdLine.Action  import Control.Concurrent.Async import System.Posix.Types  data AnnexedFileSeeker = AnnexedFileSeeker-	{ seekAction :: RawFilePath -> Key -> CommandSeek+	{ startAction :: RawFilePath -> Key -> CommandStart 	, checkContentPresent :: Maybe Bool 	, usesLocationLog :: Bool 	} -withFilesInGitAnnex :: WarnUnmatchWhen -> AnnexedFileSeeker -> [WorkTreeItem] -> CommandSeek+withFilesInGitAnnex :: WarnUnmatchWhen -> AnnexedFileSeeker -> WorkTreeItems -> CommandSeek withFilesInGitAnnex ww a l = seekFilteredKeys a $ 	seekHelper fst3 ww LsFiles.inRepoDetails l -withFilesInGitAnnexNonRecursive :: WarnUnmatchWhen -> String -> AnnexedFileSeeker -> [WorkTreeItem] -> CommandSeek-withFilesInGitAnnexNonRecursive ww needforce a l = ifM (Annex.getState Annex.force)-	( withFilesInGitAnnex ww a l+withFilesInGitAnnexNonRecursive :: WarnUnmatchWhen -> String -> AnnexedFileSeeker -> WorkTreeItems -> CommandSeek+withFilesInGitAnnexNonRecursive ww needforce a (WorkTreeItems l) = ifM (Annex.getState Annex.force)+	( withFilesInGitAnnex ww a (WorkTreeItems l) 	, if null l 		then giveup needforce 		else seekFilteredKeys a (getfiles [] l) 	)   where 	getfiles c [] = return (reverse c)-	getfiles c ((WorkTreeItem p):ps) = do+	getfiles c (p:ps) = do 		os <- seekOptions ww 		(fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p] 		case fs of@@ -78,17 +79,20 @@ 				void $ liftIO $ cleanup 				getfiles c ps 			_ -> giveup needforce+withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop -withFilesNotInGit :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek-withFilesNotInGit  a l = go =<< seek+withFilesNotInGit :: (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek+withFilesNotInGit a (WorkTreeItems l) = go =<< seek   where 	seek = do 		force <- Annex.getState Annex.force 		g <- gitRepo 		liftIO $ Git.Command.leaveZombie-			<$> LsFiles.notInRepo [] force (map (\(WorkTreeItem f) -> toRawFilePath f) l) g+			<$> LsFiles.notInRepo [] force l' g 	go fs = seekFiltered a $-		return $ concat $ segmentPaths id (map (\(WorkTreeItem f) -> toRawFilePath f) l) fs+		return $ concat $ segmentPaths id l' fs+	l' = map toRawFilePath l+withFilesNotInGit _ NoWorkTreeItems = noop   withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents a params = do@@ -122,13 +126,13 @@ 	pairs c (x:y:xs) = pairs ((x,y):c) xs 	pairs _ _ = giveup "expected pairs" -withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek+withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek withFilesToBeCommitted a l = seekFiltered a $ 	seekHelper id WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l  {- unlocked pointer files that are staged, and whose content has not been  - modified-}-withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek+withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek withUnmodifiedUnlockedPointers ww a l = seekFiltered a unlockedfiles   where 	unlockedfiles = filterM isUnmodifiedUnlocked @@ -140,7 +144,7 @@ 	Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k  {- Finds files that may be modified. -}-withFilesMaybeModified :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek+withFilesMaybeModified :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek withFilesMaybeModified ww a params = seekFiltered a $ 	seekHelper id ww LsFiles.modified params @@ -165,38 +169,44 @@ withKeyOptions  	:: Maybe KeyOptions 	-> Bool+	-> AnnexedFileSeeker 	-> ((Key, ActionItem) -> CommandSeek)-	-> ([WorkTreeItem] -> CommandSeek)-	-> [WorkTreeItem]+	-> (WorkTreeItems -> CommandSeek)+	-> WorkTreeItems 	-> CommandSeek-withKeyOptions ko auto keyaction = withKeyOptions' ko auto mkkeyaction+withKeyOptions ko auto seeker keyaction = withKeyOptions' ko auto mkkeyaction   where 	mkkeyaction = do 		matcher <- Limit.getMatcher-		return $ \v@(k, ai) ->+		return $ \v@(k, ai) -> checkseeker k $ 			let i = case ai of 				ActionItemBranchFilePath (BranchFilePath _ topf) _ -> 					MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf) 				_ -> MatchingKey k (AssociatedFile Nothing) 			in whenM (matcher i) $ 				keyaction v+	checkseeker k a = case checkContentPresent seeker of+		Nothing -> a+		Just v -> do+			present <- inAnnex k+			when (present == v) a  withKeyOptions'  	:: Maybe KeyOptions 	-> Bool 	-> Annex ((Key, ActionItem) -> Annex ())-	-> ([WorkTreeItem] -> CommandSeek)-	-> [WorkTreeItem]+	-> (WorkTreeItems -> CommandSeek)+	-> WorkTreeItems 	-> CommandSeek-withKeyOptions' ko auto mkkeyaction fallbackaction params = do+withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do 	bare <- fromRepo Git.repoIsLocalBare 	when (auto && bare) $ 		giveup "Cannot use --auto in a bare repository"-	case (null params, ko) of+	case (noworktreeitems, ko) of 		(True, Nothing) 			| bare -> noauto runallkeys-			| otherwise -> fallbackaction params-		(False, Nothing) -> fallbackaction params+			| otherwise -> fallbackaction worktreeitems+		(False, Nothing) -> fallbackaction worktreeitems 		(True, Just WantAllKeys) -> noauto runallkeys 		(True, Just WantUnusedKeys) -> noauto $ runkeyaction unusedKeys' 		(True, Just WantFailedTransfers) -> noauto runfailedtransfers@@ -209,6 +219,11 @@ 		| auto = giveup "Cannot use --auto with --all or --branch or --unused or --key or --incomplete" 		| otherwise = a 	+	noworktreeitems = case worktreeitems of+		WorkTreeItems [] -> True+		WorkTreeItems _ -> False+		NoWorkTreeItems -> False+ 	incompletekeys = staleKeysPrune gitAnnexTmpObjectDir True  	-- List all location log files on the git-annex branch,@@ -305,7 +320,8 @@ 		Just (f, content) -> do 			case parseLinkTargetOrPointerLazy =<< content of 				Just k -> checkpresence k $-					seekAction seeker f k+					commandAction $+						startAction seeker f k 				Nothing -> noop 			finisher oreader 		Nothing -> return ()@@ -313,7 +329,7 @@ 	precachefinisher lreader = liftIO lreader >>= \case 		Just ((logf, f, k), logcontent) -> do 			maybe noop (Annex.BranchState.setCache logf) logcontent-			seekAction seeker f k+			commandAction $ startAction seeker f k 			precachefinisher lreader 		Nothing -> return () 	@@ -370,14 +386,13 @@ 		Just _ -> mdprocess matcher mdreader ofeeder ocloser 		Nothing -> liftIO $ void ocloser -seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> [WorkTreeItem] -> Annex [a]-seekHelper c ww a l = do+seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex [a]+seekHelper c ww a (WorkTreeItems l) = do 	os <- seekOptions ww 	inRepo $ \g ->-		concat . concat <$> forM (segmentXargsOrdered l')+		concat . concat <$> forM (segmentXargsOrdered l) 			(runSegmentPaths c (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath)-  where-	l' = map (\(WorkTreeItem f) -> f) l+seekHelper _ _ _ NoWorkTreeItems = return []  data WarnUnmatchWhen = WarnUnmatchLsFiles | WarnUnmatchWorkTreeItems @@ -389,8 +404,13 @@ 		) seekOptions WarnUnmatchWorkTreeItems = return [] --- An item in the work tree, which may be a file or a directory.-newtype WorkTreeItem = WorkTreeItem FilePath+-- Items in the work tree, which may be files or directories.+data WorkTreeItems+	= WorkTreeItems [FilePath]+	-- ^ An empty list often means all files.+	| NoWorkTreeItems+	-- ^ Used when no work tree items should be operated on.+	deriving (Show)  -- When in an adjusted branch that hides some files, it may not exist -- in the current work tree, but in the original branch. This allows@@ -411,37 +431,56 @@ -- -- 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 :: WarnUnmatchWhen -> CmdParams -> Annex WorkTreeItems workTreeItems = workTreeItems' (AllowHidden False) -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)+workTreeItems' :: AllowHidden -> WarnUnmatchWhen -> CmdParams -> Annex WorkTreeItems+workTreeItems' (AllowHidden allowhidden) ww ps = case ww of+	WarnUnmatchWorkTreeItems -> runcheck+	WarnUnmatchLsFiles -> +		ifM (annexSkipUnknown <$> Annex.getGitConfig)+			( runcheck+			, return $ WorkTreeItems ps+			)   where 	runcheck = do 		currbranch <- getCurrentBranch-		forM_ ps $ \p -> do+		stopattop <- prepviasymlink+		ps' <- flip filterM 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")+				, ifM (viasymlink stopattop (upFrom relf))+					( prob (p ++ " is beyond a symbolic link")+					, return True+					) 				)+		if null ps' && not (null ps)+			then return NoWorkTreeItems+			else return (WorkTreeItems ps') 	 	exists p = isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p) -	viasymlink Nothing = return False-	viasymlink (Just p) =-		ifM (liftIO $ isSymbolicLink <$> getSymbolicLinkStatus p)-			( return True-			, viasymlink (upFrom p)-			)+	prepviasymlink = do+		repotopst <- inRepo $ +			maybe+				(pure Nothing)+				(catchMaybeIO . R.getSymbolicLinkStatus) +			. Git.repoWorkTree+		return $ \st -> case repotopst of+			Nothing -> False+			Just tst -> fileID st == fileID tst+				&& deviceID st == deviceID tst +	viasymlink _ Nothing = return False+	viasymlink stopattop (Just p) = do+		st <- liftIO $ getSymbolicLinkStatus p+		if stopattop st+			then return False+			else if isSymbolicLink st+				then return True+				else viasymlink stopattop (upFrom p)+ 	hidden currbranch f 		| allowhidden = isJust 			<$> catObjectMetaDataHidden (toRawFilePath f) currbranch@@ -450,6 +489,7 @@ 	prob msg = do 		toplevelWarning False msg 		Annex.incError+		return False 	 notSymlink :: RawFilePath -> IO Bool notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus f
Command/Add.hs view
@@ -80,7 +80,7 @@ 		Batch fmt 			| updateOnly o -> 				giveup "--update --batch is not supported"-			| otherwise -> batchFilesMatching fmt (gofile . toRawFilePath)+			| otherwise -> batchFilesMatching fmt gofile 		NoBatch -> do 			-- Avoid git ls-files complaining about files that 			-- are not known to git yet, since this will add
Command/Copy.hs view
@@ -45,22 +45,24 @@  seek :: CopyOptions -> CommandSeek seek o = startConcurrency commandStages $ do-	let go = start o-	let seeker = AnnexedFileSeeker-		{ seekAction = commandAction' go-		, checkContentPresent = Nothing-		, usesLocationLog = False-		} 	case batchOption o of-		Batch fmt -> batchFilesMatching fmt-			(whenAnnexed go . toRawFilePath) 		NoBatch -> withKeyOptions-			(keyOptions o) (autoMode o)+			(keyOptions o) (autoMode o) seeker 			(commandAction . Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever) 			(withFilesInGitAnnex ww seeker) 			=<< workTreeItems ww (copyFiles o)+		Batch fmt -> batchAnnexedFilesMatching fmt seeker   where 	ww = WarnUnmatchLsFiles+	+	seeker = AnnexedFileSeeker+		{ startAction = start o+		, checkContentPresent = case fromToOptions o of+			Right (FromRemote _) -> Just False+			Right (ToRemote _) -> Just True+			Left ToHere -> Just False+		, usesLocationLog = True+		}  {- A copy is just a move that does not delete the source file.  - However, auto mode avoids unnecessary copies, and avoids getting or
Command/Drop.hs view
@@ -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.  -}@@ -52,55 +52,55 @@ 	)  seek :: DropOptions -> CommandSeek-seek o = startConcurrency commandStages $+seek o = startConcurrency commandStages $ do+	from <- case dropFrom o of+		Nothing -> pure Nothing+		Just f -> getParsed f >>= \remote -> do+			u <- getUUID+			if Remote.uuid remote == u+				then pure Nothing+				else pure (Just remote)				+	let seeker = AnnexedFileSeeker+		{ startAction = start o from+		, checkContentPresent = case from of+			Nothing -> Just True+			Just _ -> Nothing+		, usesLocationLog = True+		} 	case batchOption o of-		Batch fmt -> batchFilesMatching fmt-			(whenAnnexed go . toRawFilePath)-		NoBatch -> withKeyOptions (keyOptions o) (autoMode o)-			(commandAction . startKeys o)+		Batch fmt -> batchAnnexedFilesMatching fmt seeker+		NoBatch -> withKeyOptions (keyOptions o) (autoMode o) seeker+			(commandAction . startKeys o from) 			(withFilesInGitAnnex ww seeker) 			=<< workTreeItems ww (dropFiles o)   where-	go = start o 	ww = WarnUnmatchLsFiles -	seeker = AnnexedFileSeeker-		{ seekAction = commandAction' go-		, checkContentPresent = Nothing-		, usesLocationLog = False-		}--start :: DropOptions -> RawFilePath -> Key -> CommandStart-start o file key = start' o key afile ai+start :: DropOptions -> Maybe Remote -> RawFilePath -> Key -> CommandStart+start o from file key = start' o from key afile ai   where 	afile = AssociatedFile (Just file) 	ai = mkActionItem (key, afile) -start' :: DropOptions -> Key -> AssociatedFile -> ActionItem -> CommandStart-start' o key afile ai = do-	from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o)+start' :: DropOptions -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart+start' o from key afile ai =  	checkDropAuto (autoMode o) from afile key $ \numcopies ->-		stopUnless (want from) $+		stopUnless want $ 			case from of 				Nothing -> startLocal afile ai numcopies key []-				Just remote -> do-					u <- getUUID-					if Remote.uuid remote == u-						then startLocal afile ai numcopies key []-						else startRemote afile ai numcopies key remote-	  where-		want from-			| autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile-			| otherwise = return True+				Just remote -> startRemote afile ai numcopies key remote+  where+	want+		| autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile+		| otherwise = return True -startKeys :: DropOptions -> (Key, ActionItem) -> CommandStart-startKeys o (key, ai) = start' o key (AssociatedFile Nothing) ai+startKeys :: DropOptions -> Maybe Remote -> (Key, ActionItem) -> CommandStart+startKeys o from (key, ai) = start' o from key (AssociatedFile Nothing) ai  startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart startLocal afile ai numcopies key preverified =-	stopUnless (inAnnex key) $-		starting "drop" (OnlyActionOn key ai) $-			performLocal key afile numcopies preverified+	starting "drop" (OnlyActionOn key ai) $+		performLocal key afile numcopies preverified  startRemote :: AssociatedFile -> ActionItem -> NumCopies -> Key -> Remote -> CommandStart startRemote afile ai numcopies key remote = @@ -108,7 +108,7 @@ 		performRemote key afile numcopies remote  performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform-performLocal key afile numcopies preverified = lockContentForRemoval key $ \contentlock -> do+performLocal key afile numcopies preverified = lockContentForRemoval key fallback $ \contentlock -> do 	u <- getUUID 	(tocheck, verified) <- verifiableCopies key [u] 	doDrop u (Just contentlock) key afile numcopies [] (preverified ++ verified) tocheck@@ -125,6 +125,13 @@ 			notifyDrop afile False 			stop 		)+  where+	-- This occurs when, for example, two files are being dropped+	-- and have the same content. The seek stage checks if the content+	-- is present, but due to buffering, may find it present for the+	-- second file before the first is dropped. If so, nothing remains+	-- to be done except for cleaning up.+	fallback = next $ cleanupLocal key  performRemote :: Key -> AssociatedFile -> NumCopies -> Remote -> CommandPerform performRemote key afile numcopies remote = do
Command/DropKey.hs view
@@ -47,7 +47,7 @@  perform :: Key -> CommandPerform perform key = ifM (inAnnex key)-	( lockContentForRemoval key $ \contentlock -> do+	( lockContentForRemoval key (next $ cleanup key) $ \contentlock -> do 		removeAnnex contentlock 		next $ cleanup key 	, next $ return True
Command/Find.hs view
@@ -18,7 +18,6 @@ import Git.FilePath import qualified Utility.Format import Utility.DataUnits-import Annex.Content  cmd :: Command cmd = notBareRepo $ withGlobalOptions [annexedMatchingOptions] $ mkCommand $@@ -54,27 +53,24 @@ 		)  seek :: FindOptions -> CommandSeek-seek o = case batchOption o of-	NoBatch -> do-		islimited <- limited-		let seeker = AnnexedFileSeeker-			{ seekAction = commandAction' go-			-- only files with content present are shown, unless-			-- the user has requested others via a limit-			, checkContentPresent = if islimited-				then Nothing-				else Just True-			, usesLocationLog = False-			}-		withKeyOptions (keyOptions o) False+seek o = do+	islimited <- limited+	let seeker = AnnexedFileSeeker+		{ startAction = start o+		-- only files with content present are shown, unless+		-- the user has requested others via a limit+		, checkContentPresent = if islimited+			then Nothing+			else Just True+		, usesLocationLog = False+		}+	case batchOption o of+		NoBatch -> withKeyOptions (keyOptions o) False seeker 			(commandAction . startKeys o) 			(withFilesInGitAnnex ww seeker) 			=<< workTreeItems ww (findThese o)-	Batch fmt -> batchFilesMatching fmt-		(whenAnnexed gobatch . toRawFilePath)+		Batch fmt -> batchAnnexedFilesMatching fmt seeker   where-	go = start o-	gobatch f k = stopUnless (limited <||> inAnnex k) (go f k) 	ww = WarnUnmatchLsFiles  start :: FindOptions -> RawFilePath -> Key -> CommandStart
Command/Fix.hs view
@@ -36,7 +36,7 @@   where 	ww = WarnUnmatchLsFiles 	seeker = AnnexedFileSeeker-		{ seekAction = commandAction' (start FixAll)+		{ startAction = start FixAll 		, checkContentPresent = Nothing 		, usesLocationLog = False 		}
Command/Fsck.hs view
@@ -93,11 +93,11 @@ 	checkDeadRepo u 	i <- prepIncremental u (incrementalOpt o) 	let seeker = AnnexedFileSeeker-		{ seekAction = commandAction' (start from i)+		{ startAction = start from i 		, checkContentPresent = Nothing 		, usesLocationLog = True 		}-	withKeyOptions (keyOptions o) False+	withKeyOptions (keyOptions o) False seeker 		(\kai -> commandAction . startKey from i kai =<< getNumCopies) 		(withFilesInGitAnnex ww seeker) 		=<< workTreeItems ww (fsckFiles o)@@ -199,7 +199,7 @@  startKey :: Maybe Remote -> Incremental -> (Key, ActionItem) -> NumCopies -> CommandStart startKey from inc (key, ai) numcopies =-	case Backend.maybeLookupBackendVariety (fromKey keyVariety key) of+	Backend.maybeLookupBackendVariety (fromKey keyVariety key) >>= \case 		Nothing -> stop 		Just backend -> runFsck inc ai key $ 			case from of@@ -261,7 +261,7 @@ 	 - insecure hash is present. This should only be able to happen 	 - if the repository already contained the content before the 	 - config was set. -}-	when (present && not (Backend.isCryptographicallySecure key)) $+	whenM (pure present <&&> (not <$> Backend.isCryptographicallySecure key)) $ 		whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $ 			warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key"
Command/Get.hs view
@@ -40,19 +40,17 @@ seek :: GetOptions -> CommandSeek seek o = startConcurrency downloadStages $ do 	from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o)-	let go = start o from 	let seeker = AnnexedFileSeeker-		{ seekAction = commandAction' go+		{ startAction = start o from 		, checkContentPresent = Just False 		, usesLocationLog = True 		} 	case batchOption o of-		Batch fmt -> batchFilesMatching fmt-			(whenAnnexed go . toRawFilePath)-		NoBatch -> withKeyOptions (keyOptions o) (autoMode o)+		NoBatch -> withKeyOptions (keyOptions o) (autoMode o) seeker 			(commandAction . startKeys from) 			(withFilesInGitAnnex ww seeker) 			=<< workTreeItems ww (getFiles o)+		Batch fmt -> batchAnnexedFilesMatching fmt seeker   where 	ww = WarnUnmatchLsFiles @@ -72,7 +70,7 @@  start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart start' expensivecheck from key afile ai =-	stopUnless (not <$> inAnnex key) $ stopUnless expensivecheck $+	stopUnless expensivecheck $ 		case from of 			Nothing -> go $ perform key afile 			Just src ->
Command/ImportFeed.hs view
@@ -338,17 +338,18 @@ {- Generates a filename to use for a feed item by filling out the template.  - The filename may not be unique. -} feedFile :: Utility.Format.Format -> ToDownload -> String -> FilePath-feedFile tmpl i extension = Utility.Format.format tmpl $-	M.map sanitizeFilePath $ M.fromList $ extractFields i ++-		[ ("extension", extension)-		, extractField "itempubdate" [itempubdate]-		, extractField "itempubyear" [itempubyear]-		, extractField "itempubmonth" [itempubmonth]-		, extractField "itempubday" [itempubday]-		, extractField "itempubhour" [itempubhour]-		, extractField "itempubminute" [itempubminute]-		, extractField "itempubsecond" [itempubsecond]-		]+feedFile tmpl i extension = sanitizeLeadingFilePathCharacter $ +	Utility.Format.format tmpl $+		M.map sanitizeFilePathComponent $ M.fromList $ extractFields i +++			[ ("extension", extension)+			, extractField "itempubdate" [itempubdate]+			, extractField "itempubyear" [itempubyear]+			, extractField "itempubmonth" [itempubmonth]+			, extractField "itempubday" [itempubday]+			, extractField "itempubhour" [itempubhour]+			, extractField "itempubminute" [itempubminute]+			, extractField "itempubsecond" [itempubsecond]+			]   where 	itm = item i
Command/Inprogress.hs view
@@ -39,7 +39,7 @@ 		_ -> do 			let s = S.fromList ts 			let seeker = AnnexedFileSeeker-				{ seekAction = commandAction' (start s)+				{ startAction = start s 				, checkContentPresent = Nothing 				, usesLocationLog = False 				}
Command/List.hs view
@@ -45,7 +45,7 @@ 	list <- getList o 	printHeader list 	let seeker = AnnexedFileSeeker-		{ seekAction = commandAction' (start list)+		{ startAction = start list 		, checkContentPresent = Nothing 		, usesLocationLog = True 		}
Command/Lock.hs view
@@ -32,7 +32,7 @@   where 	ww = WarnUnmatchLsFiles 	seeker = AnnexedFileSeeker-		{ seekAction = commandAction' start+		{ startAction = start 		, checkContentPresent = Nothing 		, usesLocationLog = False 		}
Command/Log.hs view
@@ -86,7 +86,7 @@ 	zone <- liftIO getCurrentTimeZone 	let outputter = mkOutputter m zone o 	let seeker = AnnexedFileSeeker-		{ seekAction = commandAction' (start o outputter)+		{ startAction = start o outputter 		, checkContentPresent = Nothing 		-- the way this uses the location log would not be helped 		-- by precaching the current value
Command/MetaData.hs view
@@ -77,7 +77,7 @@ 		c <- liftIO currentVectorClock 		let ww = WarnUnmatchLsFiles 		let seeker = AnnexedFileSeeker-			{ seekAction = commandAction' (start c o)+			{ startAction = start c o 			, checkContentPresent = Nothing 			, usesLocationLog = False 			}@@ -86,7 +86,7 @@ 			GetAll -> withFilesInGitAnnex ww 			Set _ -> withFilesInGitAnnexNonRecursive ww 				"Not recursively setting metadata. Use --force to do that."-		withKeyOptions (keyOptions o) False+		withKeyOptions (keyOptions o) False seeker 			(commandAction . startKeys c o) 			(seekaction seeker) 			=<< workTreeItems ww (forFiles o)
Command/Migrate.hs view
@@ -30,7 +30,7 @@   where 	ww = WarnUnmatchLsFiles 	seeker = AnnexedFileSeeker-		{ seekAction = commandAction' start+		{ startAction = start 		, checkContentPresent = Nothing 		, usesLocationLog = False 		}
Command/Mirror.hs view
@@ -42,7 +42,7 @@  seek :: MirrorOptions -> CommandSeek seek o = startConcurrency stages $ -	withKeyOptions (keyOptions o) False+	withKeyOptions (keyOptions o) False seeker 		(commandAction . startKey o (AssociatedFile Nothing)) 		(withFilesInGitAnnex ww seeker) 		=<< workTreeItems ww (mirrorFiles o)@@ -52,9 +52,9 @@ 		ToRemote _ -> commandStages 	ww = WarnUnmatchLsFiles 	seeker = AnnexedFileSeeker-		{ seekAction = commandAction' (start o)+		{ startAction = start o 		, checkContentPresent = Nothing-		, usesLocationLog = False+		, usesLocationLog = True 		}  start :: MirrorOptions -> RawFilePath -> Key -> CommandStart@@ -75,7 +75,10 @@ 		haskey <- flip Remote.hasKey key =<< getParsed r 		case haskey of 			Left _ -> stop-			Right True -> Command.Get.start' (return True) Nothing key afile ai+			Right True -> ifM (inAnnex key)+				( stop+				, Command.Get.start' (return True) Nothing key afile ai+				) 			Right False -> ifM (inAnnex key) 				( do 					numcopies <- getnumcopies
Command/Move.hs view
@@ -55,20 +55,21 @@  seek :: MoveOptions -> CommandSeek seek o = startConcurrency stages $ do-	let go = start (fromToOptions o) (removeWhen o)-	let seeker = AnnexedFileSeeker-		{ seekAction = commandAction' go-		, checkContentPresent = Nothing-		, usesLocationLog = False-		} 	case batchOption o of-		Batch fmt -> batchFilesMatching fmt-			(whenAnnexed go . toRawFilePath)-		NoBatch -> withKeyOptions (keyOptions o) False+		NoBatch -> withKeyOptions (keyOptions o) False seeker 			(commandAction . startKey (fromToOptions o) (removeWhen o)) 			(withFilesInGitAnnex ww seeker) 			=<< workTreeItems ww (moveFiles o)+		Batch fmt -> batchAnnexedFilesMatching fmt seeker   where+	seeker = AnnexedFileSeeker+		{ startAction = start (fromToOptions o) (removeWhen o)+		, checkContentPresent = case fromToOptions o of+			Right (FromRemote _) -> Nothing+			Right (ToRemote _) -> Just True+			Left ToHere -> Nothing+		, usesLocationLog = True+		} 	stages = case fromToOptions o of 		Right (FromRemote _) -> downloadStages 		Right (ToRemote _) -> commandStages@@ -105,9 +106,8 @@ toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart toStart removewhen afile key ai dest = do 	u <- getUUID-	ishere <- inAnnex key-	if not ishere || u == Remote.uuid dest-		then stop -- not here, so nothing to do+	if u == Remote.uuid dest+		then stop 		else toStart' dest removewhen afile key ai  toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart@@ -155,7 +155,7 @@ 		RemoveNever -> do 			setpresentremote 			next $ return True-		RemoveSafe -> lockContentForRemoval key $ \contentlock -> do+		RemoveSafe -> lockContentForRemoval key lockfailed $ \contentlock -> do 			srcuuid <- getUUID 			let destuuid = Remote.uuid dest 			willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case@@ -188,13 +188,17 @@ 		next $ do 			() <- setpresentremote 			return False+	+	-- This occurs when, for example, two files are being dropped+	-- and have the same content. The seek stage checks if the content+	-- is present, but due to buffering, may find it present for the+	-- second file before the first is dropped. If so, nothing remains+	-- to be done except for cleaning up.+	lockfailed = next $ Command.Drop.cleanupLocal key  fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart-fromStart removewhen afile key ai src = case removewhen of-	RemoveNever -> stopUnless (not <$> inAnnex key) go-	RemoveSafe -> go-  where-	go = stopUnless (fromOk src key) $+fromStart removewhen afile key ai src = +	stopUnless (fromOk src key) $ 		starting (describeMoveAction removewhen) (OnlyActionOn key ai) $ 			fromPerform src removewhen key afile @@ -249,11 +253,8 @@  - When moving, the content is removed from all the reachable remotes that  - it can safely be removed from. -} toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart-toHereStart removewhen afile key ai = case removewhen of-	RemoveNever -> stopUnless (not <$> inAnnex key) go-	RemoveSafe -> go-  where-	go = startingNoMessage (OnlyActionOn key ai) $ do+toHereStart removewhen afile key ai = +	startingNoMessage (OnlyActionOn key ai) $ do 		rs <- Remote.keyPossibilities key 		forM_ rs $ \r -> 			includeCommandAction $
Command/Smudge.hs view
@@ -131,7 +131,10 @@ 		-- Look up the backend that was used for this file 		-- before, so that when git re-cleans a file its 		-- backend does not change.-		let oldbackend = maybe Nothing (maybeLookupBackendVariety . fromKey keyVariety) oldkey+		oldbackend <- maybe+			(pure Nothing)+			(maybeLookupBackendVariety . fromKey keyVariety)+			oldkey 		-- Can't restage associated files because git add 		-- runs this and has the index locked. 		let norestage = Restage False
Command/Sync.hs view
@@ -635,7 +635,7 @@ seekSyncContent o rs currbranch = do 	mvar <- liftIO newEmptyMVar 	bloom <- case keyOptions o of-		Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar [])+		Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar (WorkTreeItems [])) 		_ -> case currbranch of                 	(Just origbranch, Just adj) | adjustmentHidesFiles adj -> do 				l <- workTreeItems' (AllowHidden True) ww (contentOfOption o)@@ -646,15 +646,15 @@ 				seekworktree mvar l (const noop) 				pure Nothing 	withKeyOptions' (keyOptions o) False-		(return (gokey mvar bloom))+		(return (commandAction . gokey mvar bloom)) 		(const noop)-		[]+		(WorkTreeItems []) 	waitForAllRunningCommandActions 	liftIO $ not <$> isEmptyMVar mvar   where 	seekworktree mvar l bloomfeeder = do 		let seeker = AnnexedFileSeeker-			{ seekAction = gofile bloomfeeder mvar+			{ startAction = gofile bloomfeeder mvar 			, checkContentPresent = Nothing 			, usesLocationLog = True 			}@@ -662,7 +662,7 @@ 			seekHelper fst3 ww LsFiles.inRepoDetails l  	seekincludinghidden origbranch mvar l bloomfeeder =-		seekFiltered (\f -> ifAnnexed f (gofile bloomfeeder mvar f) noop) $+		seekFiltered (\f -> ifAnnexed f (commandAction . gofile bloomfeeder mvar f) noop) $ 			seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l   	ww = WarnUnmatchLsFiles@@ -677,7 +677,7 @@ 		-- Run syncFile as a command action so file transfers run 		-- concurrently. 		let ai = OnlyActionOn k (ActionItemKey k)-		commandAction $ startingNoMessage ai $ do+		startingNoMessage ai $ do 			whenM (syncFile ebloom rs af k) $ 				void $ liftIO $ tryPutMVar mvar () 			next $ return True
Command/TestRemote.hs view
@@ -245,7 +245,7 @@ 		whenwritable r $ isRight <$> tryNonAsync (store r k) 	, check ("present " ++ show True) $ \r k -> present r k True 	, check "retrieveKeyFile" $ \r k -> do-		lockContentForRemoval k removeAnnex+		lockContentForRemoval k noop removeAnnex 		get r k 	, check "fsck downloaded object" fsck 	, check "retrieveKeyFile resume from 33%" $ \r k -> do@@ -255,20 +255,20 @@ 			sz <- hFileSize h 			L.hGet h $ fromInteger $ sz `div` 3 		liftIO $ L.writeFile tmp partial-		lockContentForRemoval k removeAnnex+		lockContentForRemoval k noop removeAnnex 		get r k 	, check "fsck downloaded object" fsck 	, check "retrieveKeyFile resume from 0" $ \r k -> do 		tmp <- prepTmp k 		liftIO $ writeFile tmp ""-		lockContentForRemoval k removeAnnex+		lockContentForRemoval k noop removeAnnex 		get r k 	, check "fsck downloaded object" fsck 	, check "retrieveKeyFile resume from end" $ \r k -> do 		loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) 		tmp <- prepTmp k 		void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp-		lockContentForRemoval k removeAnnex+		lockContentForRemoval k noop removeAnnex 		get r k 	, check "fsck downloaded object" fsck 	, check "removeKey when present" $ \r k -> @@ -288,7 +288,7 @@ 			Nothing -> return True 		runannex a' @? "failed" 	present r k b = (== Right b) <$> Remote.hasKey r k-	fsck _ k = case maybeLookupBackendVariety (fromKey keyVariety k) of+	fsck _ k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case 		Nothing -> return True 		Just b -> case Types.Backend.verifyKeyContent b of 			Nothing -> return True@@ -393,7 +393,7 @@ 	| all Remote.readonly rs = return ok 	| otherwise = do 		forM_ rs $ \r -> forM_ ks (Remote.removeKey r)-		forM_ ks $ \k -> lockContentForRemoval k removeAnnex+		forM_ ks $ \k -> lockContentForRemoval k noop removeAnnex 		return ok  chunkSizes :: Int -> Bool -> [Int]
Command/Unannex.hs view
@@ -28,7 +28,7 @@  seeker :: AnnexedFileSeeker seeker = AnnexedFileSeeker-	{ seekAction = commandAction' start+	{ startAction = start 	, checkContentPresent = Just True 	, usesLocationLog = False 	}
Command/Uninit.hs view
@@ -115,7 +115,7 @@ 	go c [] = return c 	go c (k:ks) = ifM (inAnnexCheck k $ liftIO . enoughlinks) 		( do-			lockContentForRemoval k removeAnnex+			lockContentForRemoval k noop removeAnnex 			go c ks 		, go (k:c) ks 		)
Command/Unlock.hs view
@@ -31,7 +31,7 @@   where 	ww = WarnUnmatchLsFiles 	seeker = AnnexedFileSeeker-		{ seekAction = commandAction' start+		{ startAction = start 		, checkContentPresent = Nothing 		, usesLocationLog = False 		}
Command/Version.hs view
@@ -59,7 +59,8 @@ 	vinfo "build flags" $ unwords buildFlags 	vinfo "dependency versions" $ unwords dependencyVersions 	vinfo "key/value backends" $ unwords $-		map (decodeBS . formatKeyVariety . B.backendVariety) Backend.list+		map (decodeBS . formatKeyVariety . B.backendVariety) Backend.builtinList+		++ ["X*"] 	vinfo "remote types" $ unwords $ map R.typename Remote.remoteTypes 	vinfo "operating system" $ unwords [os, arch] 	vinfo "supported repository versions" $
Command/Whereis.hs view
@@ -51,20 +51,18 @@ seek :: WhereisOptions -> CommandSeek seek o = do 	m <- remoteMap id-	let go = start o m+	let seeker = AnnexedFileSeeker+		{ startAction = start o m+		, checkContentPresent = Nothing+		, usesLocationLog = True+		} 	case batchOption o of-		Batch fmt -> batchFilesMatching fmt-			(whenAnnexed go . toRawFilePath) 		NoBatch -> do-			let seeker = AnnexedFileSeeker-				{ seekAction = commandAction' go-				, checkContentPresent = Nothing-				, usesLocationLog = True-				}-			withKeyOptions (keyOptions o) False+			withKeyOptions (keyOptions o) False seeker 				(commandAction . startKeys o m) 				(withFilesInGitAnnex ww seeker) 				=<< workTreeItems ww (whereisFiles o)+		Batch fmt -> batchAnnexedFilesMatching fmt seeker   where 	ww = WarnUnmatchLsFiles
Git/Config.hs view
@@ -22,6 +22,7 @@ import qualified Git.Command import qualified Git.Construct import Utility.UserInfo+import Utility.ThreadScheduler  {- Returns a single git config setting, or a fallback value if not set. -} get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue@@ -214,13 +215,20 @@ 		{ 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)+	go _ (Just hout) (Just herr) pid =+		withAsync (S.hGetContents herr) $ \errreader -> do+			val <- S.hGetContents hout+			-- In case the process exits while something else,+			-- like a background process, keeps the stderr handle+			-- open, don't block forever waiting for stderr.+			-- A few seconds after finishing reading stdout+			-- should get any error message.+			err <- either id id <$> +				wait errreader+					`race` (threadDelaySeconds (Seconds 2) >> return mempty)+			forceSuccessProcess p pid+			r' <- store val st r+			return (r', val, err) 	go _ _ _ _ = error "internal"  {- Reads git config from a specified file and returns the repo populated
Limit.hs view
@@ -306,7 +306,7 @@ addSecureHash = addLimit $ Right limitSecureHash  limitSecureHash :: MatchFiles Annex-limitSecureHash _ = checkKey $ pure . isCryptographicallySecure+limitSecureHash _ = checkKey isCryptographicallySecure  {- Adds a limit to skip files that are too large or too small -} addLargerThan :: String -> Annex ()
P2P/Annex.hs view
@@ -107,12 +107,14 @@ 			Left e -> return $ Left $ ProtoFailureException e 			Right result -> runner (next result) 	RemoveContent k next -> do+		let cleanup = do+			logStatus k InfoMissing+			return True 		v <- tryNonAsync $ 			ifM (Annex.Content.inAnnex k)-				( lockContentForRemoval k $ \contentlock -> do+				( lockContentForRemoval k cleanup $ \contentlock -> do 					removeAnnex contentlock-					logStatus k InfoMissing-					return True+					cleanup 				, return True 				) 		case v of
Remote/External.hs view
@@ -12,6 +12,7 @@ import Remote.External.Types import qualified Annex import Annex.Common+import Annex.ExternalAddonProcess import Types.Remote import Types.Export import Types.CleanupActions@@ -20,15 +21,12 @@ import qualified Git import Config import Git.Config (boolConfig)-import Git.Env import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.ExportImport import Remote.Helper.ReadOnly import Remote.Helper.Messages import Utility.Metered-import Utility.Shell-import Messages.Progress import Types.Transfer import Logs.PreferredContent.Raw import Logs.RemoteState@@ -40,7 +38,6 @@ import Creds  import Control.Concurrent.STM-import Control.Concurrent.Async import System.Log.Logger (debugM) import qualified Data.Map as M import qualified Data.Set as S@@ -188,7 +185,7 @@ 			-- error out if the user provided an unexpected config. 			_ <- either giveup return . parseRemoteConfig c'  				=<< strictRemoteConfigParser external-			handleRequest external INITREMOTE Nothing $ \resp -> case resp of+			handleRequest external INITREMOTE Nothing $ \case 				INITREMOTE_SUCCESS -> result () 				INITREMOTE_FAILURE errmsg -> Just $ giveup $ 					respErrorMessage "INITREMOTE" errmsg@@ -384,7 +381,7 @@ handleRequestExport external loc mkreq k mp responsehandler = do 	withExternalState external $ \st -> do 		checkPrepared st external-		sendMessage st external (EXPORT loc)+		sendMessage st (EXPORT loc) 	handleRequestKey external mkreq k mp responsehandler  handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> ResponseHandler a -> Annex a@@ -395,7 +392,7 @@ 	| otherwise = go   where 	go = do-		sendMessage st external req+		sendMessage st req 		loop 	loop = receiveMessage st external responsehandler 		(\rreq -> Just $ handleRemoteRequest rreq >> loop)@@ -492,8 +489,8 @@  	handleAsyncMessage (ERROR err) = giveup $ "external special remote error: " ++ err -	send = sendMessage st external-	senderror = sendMessage st external . ERROR +	send = sendMessage st+	senderror = sendMessage st . ERROR   	credstorage setting u = CredPairStorage 		{ credPairFile = base@@ -506,17 +503,17 @@ 	withurl mk uri = handleRemoteRequest $ mk $ 		setDownloader (show uri) OtherDownloader -sendMessage :: Sendable m => ExternalState -> External -> m -> Annex ()-sendMessage st external m = liftIO $ do-	protocolDebug external st True line+sendMessage :: Sendable m => ExternalState -> m -> Annex ()+sendMessage st m = liftIO $ do+	protocolDebug (externalAddonProcess st) True line 	hPutStrLn h line 	hFlush h   where 	line = unwords $ formatMessage m-	h = externalSend st+	h = externalSend (externalAddonProcess st)  {- A response handler can yeild a result, or it can request that another- - message be consumed from the external result. -}+ - message be consumed from the external. -} data ResponseHandlerResult a 	= Result a 	| GetNextMessage (ResponseHandler a)@@ -538,11 +535,11 @@ 	-> (AsyncMessage -> Maybe (Annex a)) 	-> Annex a receiveMessage st external handleresponse handlerequest handleasync =-	go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive st)+	go =<< liftIO (catchMaybeIO $ hGetLine $ externalReceive $ externalAddonProcess st)   where 	go Nothing = protocolError False "" 	go (Just s) = do-		liftIO $ protocolDebug external st False s+		liftIO $ protocolDebug (externalAddonProcess st) False s 		case parseMessage s :: Maybe Response of 			Just resp -> case handleresponse resp of 				Nothing -> protocolError True s@@ -560,14 +557,6 @@ 			then "(command not allowed at this time)" 			else "(unable to parse command)" -protocolDebug :: External -> ExternalState -> Bool -> String -> IO ()-protocolDebug external st sendto line = debugM "external" $ unwords-	[ externalRemoteProgram (externalType external) ++ -		"[" ++ show (externalPid st) ++ "]"-	, if sendto then "<--" else "-->"-	, line-	]- {- While the action is running, the ExternalState provided to it will not  - be available to any other calls.  -@@ -582,7 +571,7 @@ withExternalState :: External -> (ExternalState -> Annex a) -> Annex a withExternalState external a = do 	st <- get-	r <- a st `onException` liftIO (externalShutdown st True)+	r <- a st `onException` liftIO (externalShutdown (externalAddonProcess st) True) 	put st -- only when no exception is thrown 	return r   where@@ -604,99 +593,65 @@  - exchanges EXTENSIONS. -} startExternal :: External -> Annex ExternalState startExternal external = do-	errrelayer <- mkStderrRelayer-	st <- start errrelayer =<< Annex.gitRepo-	receiveMessage st external-		(const Nothing)-		(checkVersion st external)-		(const Nothing)-	sendMessage st external (EXTENSIONS supportedExtensionList)-	-- It responds with a EXTENSIONS_RESPONSE; that extensions list-	-- is reserved for future expansion. UNSUPPORTED_REQUEST is also-	-- accepted.-	receiveMessage st external-		(\resp -> case resp of-			EXTENSIONS_RESPONSE _ -> result ()-			UNSUPPORTED_REQUEST -> result ()-			_ -> Nothing-		)-		(const Nothing)-		(const Nothing)-	return st+	pid <- liftIO $ atomically $ do+		n <- succ <$> readTVar (externalLastPid external)+		writeTVar (externalLastPid external) n+		return n+	startExternalAddonProcess basecmd pid >>= \case+		Left (ProgramFailure err) -> giveup err+		Left (ProgramNotInstalled err) ->+			case (lookupName (unparsedRemoteConfig (externalDefaultConfig external)), remoteAnnexReadOnly <$> externalGitConfig external) of+				(Just rname, Just True) -> giveup $ unlines+					[ err+					, "This remote has annex-readonly=true, and previous versions of"+					, "git-annex would tried to download from it without"+					, "installing " ++ basecmd ++ ". If you want that, you need to set:"+					, "git config remote." ++ rname ++ ".annex-externaltype readonly"+					]+				_ -> giveup err+		Right p -> do+			cv <- liftIO $ newTVarIO $ externalDefaultConfig external+			ccv <- liftIO $ newTVarIO id+			pv <- liftIO $ newTVarIO Unprepared+			let st = ExternalState+				{ externalAddonProcess = p+				, externalPrepared = pv+				, externalConfig = cv+				, externalConfigChanges = ccv+				}+			startproto st+			return st   where-	start errrelayer g = liftIO $ do-		cmdpath <- searchPath basecmd-		(cmd, ps) <- maybe (pure (basecmd, [])) findShellCommand cmdpath-		let basep = (proc cmd (toCommand ps))-			{ std_in = CreatePipe-			, std_out = CreatePipe-			, std_err = CreatePipe-			}-		p <- propgit g basep-		pall@(Just hin, Just hout, Just herr, ph) <- -			createProcess p `catchNonAsync` runerr cmdpath-		stderrelay <- async $ errrelayer herr-		cv <- newTVarIO $ externalDefaultConfig external-		ccv <- newTVarIO id-		pv <- newTVarIO Unprepared-		pid <- atomically $ do-			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 = shutdown-			, externalPrepared = pv-			, externalConfig = cv-			, externalConfigChanges = ccv-			}-	-	basecmd = externalRemoteProgram $ externalType external--	propgit g p = do-		environ <- propGitEnv g-		return $ p { env = Just environ }--	runerr (Just cmd) _ =-		giveup $ "Cannot run " ++ cmd ++ " -- Make sure it's executable and that its dependencies are installed."-	runerr Nothing _ = do-		path <- intercalate ":" <$> getSearchPath-		let err = "Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")"-		case (lookupName (unparsedRemoteConfig (externalDefaultConfig external)), remoteAnnexReadOnly <$> externalGitConfig external) of-			(Just rname, Just True) -> giveup $ unlines-				[ err-				, "This remote has annex-readonly=true, and previous versions of"-				, "git-annex would tried to download from it without"-				, "installing " ++ basecmd ++ ". If you want that, you need to set:"-				, "git config remote." ++ rname ++ ".annex-externaltype readonly"-				]-			_ -> giveup err+	basecmd = "git-annex-remote-" ++ externalType external+	startproto st = do+		receiveMessage st external+			(const Nothing)+			(checkVersion st)+			(const Nothing)+		sendMessage st (EXTENSIONS supportedExtensionList)+		-- It responds with a EXTENSIONS_RESPONSE; that extensions+		-- list is reserved for future expansion. UNSUPPORTED_REQUEST+		-- is also accepted.+		receiveMessage st external+			(\resp -> case resp of+				EXTENSIONS_RESPONSE _ -> result ()+				UNSUPPORTED_REQUEST -> result ()+				_ -> Nothing+			)+			(const Nothing)+			(const Nothing)  stopExternal :: External -> Annex () stopExternal external = liftIO $ do 	l <- atomically $ swapTVar (externalState external) []-	mapM_ (flip externalShutdown False) l--externalRemoteProgram :: ExternalType -> String-externalRemoteProgram externaltype = "git-annex-remote-" ++ externaltype+	mapM_ (flip (externalShutdown . externalAddonProcess) False) l -checkVersion :: ExternalState -> External -> RemoteRequest -> Maybe (Annex ())-checkVersion st external (VERSION v) = Just $+checkVersion :: ExternalState -> RemoteRequest -> Maybe (Annex ())+checkVersion st (VERSION v) = Just $ 	if v `elem` supportedProtocolVersions 		then noop-		else sendMessage st external (ERROR "unsupported VERSION")-checkVersion _ _ _ = Nothing+		else sendMessage st (ERROR "unsupported VERSION")+checkVersion _ _ = Nothing  {- If repo has not been prepared, sends PREPARE.  -
Remote/External/Types.hs view
@@ -34,6 +34,7 @@ ) where  import Annex.Common+import Annex.ExternalAddonProcess import Types.StandardGroups (PreferredContentExpression) import Utility.Metered (BytesProcessed(..)) import Types.Transfer (Direction(..))@@ -75,10 +76,7 @@ type ExternalType = String  data ExternalState = ExternalState-	{ externalSend :: Handle-	, externalReceive :: Handle-	, externalShutdown :: Bool -> IO ()-	, externalPid :: PID+	{ externalAddonProcess :: ExternalAddonProcess 	, externalPrepared :: TVar PrepareStatus 	, externalConfig :: TVar ParsedRemoteConfig 	, externalConfigChanges :: TVar (RemoteConfig -> RemoteConfig)@@ -376,10 +374,6 @@ 	deserialize "GLOBAL" = Just GloballyAvailable 	deserialize "LOCAL" = Just LocallyAvailable 	deserialize _ = Nothing--instance Proto.Serializable BytesProcessed where-	serialize (BytesProcessed n) = show n-	deserialize = BytesProcessed <$$> readish  instance Proto.Serializable [(URLString, Size, FilePath)] where 	serialize = unwords . map go
Remote/Git.hs view
@@ -436,9 +436,10 @@ 		( guardUsable repo (giveup "cannot access remote") $ 			commitOnCleanup repo r st $ onLocalFast st $ do 				whenM (Annex.Content.inAnnex key) $ do-					Annex.Content.lockContentForRemoval key $ \lock -> do+					let cleanup = logStatus key InfoMissing+					Annex.Content.lockContentForRemoval key cleanup $ \lock -> do 						Annex.Content.removeAnnex lock-						logStatus key InfoMissing+						cleanup 					Annex.Content.saveState True 		, giveup "remote does not have expected annex.uuid value" 		)
Remote/Helper/Chunked.hs view
@@ -120,10 +120,13 @@ 	-> Annex () storeChunks u chunkconfig encryptor k f p storer checker =  	case chunkconfig of-		(UnpaddedChunks chunksize) | isStableKey k -> do-			h <- liftIO $ openBinaryFile f ReadMode-			go chunksize h-			liftIO $ hClose h+		(UnpaddedChunks chunksize) -> ifM (isStableKey k)+			( do+				h <- liftIO $ openBinaryFile f ReadMode+				go chunksize h+				liftIO $ hClose h+			, storer k (FileContent f) p+			) 		_ -> storer k (FileContent f) p   where 	go chunksize h = do
Remote/Helper/ExportImport.hs view
@@ -11,7 +11,6 @@  import Annex.Common import Types.Remote-import Types.Backend import Types.Key import Types.ProposedAccepted import Backend@@ -311,8 +310,8 @@ 		db <- getexportdb dbv 		liftIO $ Export.getExportTree db k -	retrieveKeyFileFromExport dbv k _af dest p-		| maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (fromKey keyVariety k)) = do+	retrieveKeyFileFromExport dbv k _af dest p = ifM (isVerifiable k)+		( do 			locs <- getexportlocs dbv k 			case locs of 				[] -> ifM (liftIO $ atomically $ readTVar $ getexportinconflict dbv)@@ -322,4 +321,5 @@ 				(l:_) -> do 					retrieveExport (exportActions r) k l dest p 					return UnVerified-		| otherwise = giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend"+		, giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend"+		)
Test/Framework.hs view
@@ -581,7 +581,7 @@ backendWORM = backend_ "WORM"  backend_ :: String -> Types.Backend-backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety . encodeBS+backend_ = Backend.lookupBuiltinBackendVariety . Types.Key.parseKeyVariety . encodeBS  getKey :: Types.Backend -> FilePath -> IO Types.Key getKey b f = case Types.Backend.genKey b of
Types/Key.hs view
@@ -1,6 +1,6 @@ {- git-annex Key data type  -- - 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.  -}@@ -36,6 +36,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A8 import Utility.FileSystemEncoding import Data.List+import Data.Char import System.Posix.Types import Foreign.C.Types import Data.Monoid@@ -215,6 +216,8 @@ 	| MD5Key HasExt 	| WORMKey 	| URLKey+	-- A key that is handled by some external backend.+	| ExternalKey S.ByteString HasExt  	-- Some repositories may contain keys of other varieties, 	-- which can still be processed to some extent. 	| OtherKey S.ByteString@@ -246,6 +249,7 @@ hasExt (MD5Key (HasExt b)) = b hasExt WORMKey = False hasExt URLKey = False+hasExt (ExternalKey _ (HasExt b)) = b hasExt (OtherKey s) = (snd <$> S8.unsnoc s) == Just 'E'  sameExceptExt :: KeyVariety -> KeyVariety -> Bool@@ -273,6 +277,7 @@ 	MD5Key e -> adde e "MD5" 	WORMKey -> "WORM" 	URLKey -> "URL"+	ExternalKey s e -> adde e ("X" <> s) 	OtherKey s -> s   where 	adde (HasExt False) s = s@@ -330,10 +335,16 @@ parseKeyVariety "BLAKE2SP224E" = Blake2spKey (HashSize 224) (HasExt True) parseKeyVariety "BLAKE2SP256"  = Blake2spKey (HashSize 256) (HasExt False) parseKeyVariety "BLAKE2SP256E" = Blake2spKey (HashSize 256) (HasExt True)-parseKeyVariety "SHA1"        = SHA1Key (HasExt False)-parseKeyVariety "SHA1E"       = SHA1Key (HasExt True)-parseKeyVariety "MD5"         = MD5Key (HasExt False)-parseKeyVariety "MD5E"        = MD5Key (HasExt True)-parseKeyVariety "WORM"        = WORMKey-parseKeyVariety "URL"         = URLKey-parseKeyVariety b             = OtherKey b+parseKeyVariety "SHA1"         = SHA1Key (HasExt False)+parseKeyVariety "SHA1E"        = SHA1Key (HasExt True)+parseKeyVariety "MD5"          = MD5Key (HasExt False)+parseKeyVariety "MD5E"         = MD5Key (HasExt True)+parseKeyVariety "WORM"         = WORMKey+parseKeyVariety "URL"          = URLKey+parseKeyVariety b+	| "X" `S.isPrefixOf` b = +		let b' = S.tail b+		in if not (S.null b') && S.last b' == fromIntegral (ord 'E')+			then ExternalKey (S.init b') (HasExt True)+			else ExternalKey b' (HasExt False)+	| otherwise = OtherKey b
Upgrade/V1.hs view
@@ -199,7 +199,7 @@ 		Right l -> makekey l   where 	getsymlink = takeFileName <$> readSymbolicLink file-	makekey l = case maybeLookupBackendVariety (fromKey keyVariety k) of+	makekey l = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case 		Nothing -> do 			unless (null kname || null bname || 			        not (isLinkToAnnex (toRawFilePath l))) $
Utility/LinuxMkLibs.hs view
@@ -1,6 +1,6 @@ {- Linux library copier and binary shimmer  -- - Copyright 2013 Joey Hess <id@joeyh.name>+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -9,6 +9,7 @@ 	installLib, 	parseLdd, 	glibcLibs,+	gconvLibs, 	inTop, ) where @@ -59,9 +60,15 @@   where 	getlib l = headMaybe . words =<< lastMaybe (split " => " l) -{- Get all glibc libs and other support files, including gconv files+{- Get all glibc libs.  -  - XXX Debian specific. -} glibcLibs :: IO [FilePath] glibcLibs = lines <$> readProcess "sh"-	["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so|gconv'"]+	["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so' | grep -v /gconv/ | grep -v ld.so.conf | grep -v sotruss-lib"]++{- Get gblibc's gconv libs, which are handled specially.. -}+gconvLibs :: IO [FilePath]+gconvLibs = lines <$> readProcess "sh"+	["-c", "dpkg -L libc6:$(dpkg --print-architecture) | grep /gconv/"]+
Utility/LockPool/LockHandle.hs view
@@ -52,7 +52,7 @@   where 	setup = debugLocks $ atomically (pa pool file) 	cleanup ph = debugLocks $ P.releaseLock ph-	go ph = mkLockHandle pool file ph =<< fa file+	go ph = mkLockHandle ph =<< fa file  tryMakeLockHandle :: P.LockPool -> LockFile -> (P.LockPool -> LockFile -> STM (Maybe P.LockHandle)) -> (LockFile -> IO (Maybe FileLockOps)) -> IO (Maybe LockHandle) tryMakeLockHandle pool file pa fa = bracketOnError setup cleanup go@@ -67,10 +67,10 @@ 			Nothing -> do 				cleanup (Just ph) 				return Nothing-			Just fo -> Just <$> mkLockHandle pool file ph fo+			Just fo -> Just <$> mkLockHandle ph fo -mkLockHandle :: P.LockPool -> LockFile -> P.LockHandle -> FileLockOps -> IO LockHandle-mkLockHandle pool file ph fo = do-	atomically $ P.registerCloseLockFile pool file (fDropLock fo)+mkLockHandle :: P.LockHandle -> FileLockOps -> IO LockHandle+mkLockHandle ph fo = do+	atomically $ P.registerCloseLockFile ph (fDropLock fo) 	return $ LockHandle ph fo
Utility/LockPool/STM.hs view
@@ -1,6 +1,6 @@ {- STM implementation of lock pools.  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -36,11 +36,11 @@  -- This TMVar is full when the handle is open, and is emptied when it's -- closed.-type LockHandle = TMVar (LockPool, LockFile)+type LockHandle = TMVar (LockPool, LockFile, CloseLockFile)  type LockCount = Integer -data LockStatus = LockStatus LockMode LockCount CloseLockFile+data LockStatus = LockStatus LockMode LockCount  type CloseLockFile = IO () @@ -70,25 +70,22 @@ 	m <- takeTMVar pool 	let success v = do 		putTMVar pool (M.insert file v m)-		Just <$> newTMVar (pool, file)+		Just <$> newTMVar (pool, file, noop) 	case M.lookup file m of-		Just (LockStatus mode' n closelockfile)+		Just (LockStatus mode' n) 			| mode == LockShared && mode' == LockShared ->-				success $ LockStatus mode (succ n) closelockfile+				success $ LockStatus mode (succ n) 			| n > 0 -> do 				putTMVar pool m 				return Nothing-		_ -> success $ LockStatus mode 1 noop+		_ -> success $ LockStatus mode 1  -- Call after waitTakeLock or tryTakeLock, to register a CloseLockFile -- action to run when releasing the lock.-registerCloseLockFile :: LockPool -> LockFile -> CloseLockFile -> STM ()-registerCloseLockFile pool file closelockfile = do-	m <- takeTMVar pool-	putTMVar pool (M.update go file m)-  where-	go (LockStatus mode n closelockfile') = Just $-		LockStatus mode n (closelockfile' >> closelockfile)+registerCloseLockFile :: LockHandle -> CloseLockFile -> STM ()+registerCloseLockFile h closelockfile = do+	(p, f, c) <- takeTMVar h+	putTMVar h (p, f, c >> closelockfile)  -- Checks if a lock is being held. If it's held by the current process, -- runs the getdefault action; otherwise runs the checker action.@@ -103,7 +100,7 @@ 	v <- atomically $ do 		m <- takeTMVar pool 		let threadlocked = case M.lookup file m of-			Just (LockStatus _ n _) | n > 0 -> True+			Just (LockStatus _ n) | n > 0 -> True 			_ -> False 		if threadlocked 			then do@@ -123,16 +120,16 @@ releaseLock :: LockHandle -> IO () releaseLock h = go =<< atomically (tryTakeTMVar h)   where-	go (Just (pool, file)) = do-		(m, closelockfile) <- atomically $ do+	go (Just (pool, file, closelockfile)) = do+		m <- atomically $ do 			m <- takeTMVar pool 			return $ case M.lookup file m of-				Just (LockStatus mode n closelockfile)-					| n == 1 -> (M.delete file m, closelockfile)+				Just (LockStatus mode n)+					| n == 1 -> (M.delete file m) 					| otherwise ->-						(M.insert file (LockStatus mode (pred n) closelockfile) m, noop)-				Nothing -> (m, noop)-		closelockfile+						(M.insert file (LockStatus mode (pred n)) m)+				Nothing -> m+		() <- closelockfile 		atomically $ putTMVar pool m 	-- The LockHandle was already closed. 	go Nothing = return ()
Utility/Metered.hs view
@@ -1,6 +1,6 @@ {- Metered IO and actions  -- - Copyright 2012-2018 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -46,6 +46,8 @@ import Utility.Percentage import Utility.DataUnits import Utility.HumanTime+import Utility.ThreadScheduler+import Utility.SimpleProtocol as Proto  import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S@@ -314,10 +316,26 @@ 	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+		outt <- async $ tryIO (outfilter outh) >> hClose outh+		errt <- async $ tryIO (errfilter errh) >> hClose errh+		ret <- waitForProcess pid++		-- Normally, now that the process has exited, the threads+		-- will finish processing its output and terminate.+		-- But, just in case the process did something evil like+		-- forking to the background while inheriting stderr,+		-- it's possible that the threads will not finish, which+		-- would result in a deadlock. So, wait a few seconds+		-- maximum for them to finish and then cancel them.+		-- (One program that has behaved this way in the past is+		-- openssh.)+		void $ tryNonAsync $ race_+			(wait outt >> wait errt)+			(threadDelaySeconds (Seconds 2))+		cancel outt+		cancel errt++		return ret 	go _ _ _ _ = error "internal" 	 	p = (proc cmd (toCommand params))@@ -426,3 +444,7 @@ 				Just $ fromDuration $ Duration $ 					(totalsize - new) `div` bytespersecond 		_ -> Nothing++instance Proto.Serializable BytesProcessed where+	serialize (BytesProcessed n) = show n+	deserialize = BytesProcessed <$$> readish
Utility/Process.hs view
@@ -11,7 +11,6 @@  module Utility.Process ( 	module X,-	CreateProcess(..), 	StdHandle(..), 	readProcess, 	readProcess',@@ -34,8 +33,7 @@ ) where  import qualified Utility.Process.Shim-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.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(..), CmdSpec(..), proc, getPid, getProcessExitCode, shell, terminateProcess) import Utility.Misc import Utility.Exception import Utility.Monad
Utility/TList.hs view
@@ -12,6 +12,7 @@  -}  {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}  module Utility.TList ( 	TList,@@ -44,7 +45,11 @@ headTList :: TList a -> STM a headTList tlist = do 	dl <- takeTMVar tlist+#if MIN_VERSION_dlist(1,0,0)+	let !dl' = D.fromList $ D.tail dl+#else 	let !dl' = D.tail dl+#endif 	unless (emptyDList dl') $ 		putTMVar tlist dl' 	return (D.head dl)@@ -86,7 +91,7 @@ 		putTMVar tlist dl'  emptyDList :: D.DList a -> Bool-emptyDList = D.list True (\_ _ -> False)+emptyDList = null . D.toList  consTList :: TList a -> a -> STM () consTList tlist v = modifyTList tlist $ \dl -> D.cons v dl
doc/git-annex-export.mdwn view
@@ -23,8 +23,14 @@ other treeish accepted by git, including eg master:subdir to only export a subdirectory from a branch. -When the remote has a preferred content setting, the treeish is filtered-through it, excluding files it does not want from being exported to it.+When the remote has a preferred content expression set by+[[git-annex-wanted]](1), the treeish is+filtered through it, excluding annexed files it does not want from+being exported to it. (Note that things in the expression like+"include=" match relative to the top of the treeish being exported.)++Any files in the treeish that are stored on git will also be exported to+the special remote.  Repeated exports are done efficiently, by diffing the old and new tree, and transferring only the changed files, and renaming files as necessary.
doc/git-annex-import.mdwn view
@@ -72,10 +72,10 @@ 	git config remote.myremote.annex-tracking-branch master 	git annex sync --content -If a preferred content expression is configured for the special remote,-it will be honored when importing from it. Files that are not preferred-content of the remote will not be imported from it, but will be left on the-remote. +When the special remote has a preferred content expression set by+[[git-annex-wanted]](1), it will be honored when importing from it.+Files that are not preferred content of the remote will not be+imported from it, but will be left on the remote.  However, preferred content expressions that relate to the key can't be matched when importing, because the content of the file is not@@ -83,6 +83,9 @@ set. This includes expressions containing "copies=", "metadata=", and other things that depend on the key. Preferred content expressions containing "include=", "exclude=" "smallerthan=", "largerthan=" will work.++Things in the expression like "include=" match relative to the top of+the tree of files on the remote, even when importing into a subdirectory.  # OPTIONS FOR IMPORTING FROM A SPECIAL REMOTE
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20200720.1+Version: 8.20200810 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -652,6 +652,7 @@     Annex.Drop     Annex.Environment     Annex.Export+    Annex.ExternalAddonProcess     Annex.FileMatcher     Annex.Fixup     Annex.GitOverlay@@ -697,6 +698,7 @@     Annex.WorkTree     Annex.YoutubeDl     Backend+    Backend.External     Backend.Hash     Backend.URL     Backend.Utilities