packages feed

git-annex 8.20201127 → 8.20201129

raw patch · 136 files changed

+2835/−865 lines, 136 files

Files

Annex.hs view
@@ -22,7 +22,7 @@ 	setOutput, 	getFlag, 	getField,-	addCleanup,+	addCleanupAction, 	gitRepo, 	inRepo, 	fromRepo,@@ -32,6 +32,7 @@ 	changeGitRepo, 	adjustGitRepo, 	addGitConfigOverride,+	getGitConfigOverrides, 	getRemoteGitConfig, 	withCurrentState, 	changeDirectory,@@ -70,6 +71,9 @@ import Types.IndexFiles import Types.CatFileHandles import Types.RemoteConfig+import Types.TransferrerPool+import Types.VectorClock+import Annex.VectorClock.Utility import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url@@ -109,6 +113,7 @@ 	, repoadjustment :: (Git.Repo -> IO Git.Repo) 	, gitconfig :: GitConfig 	, gitconfigadjustment :: (GitConfig -> GitConfig)+	, gitconfigoverride :: [String] 	, gitremotes :: Maybe [Git.Repo] 	, backend :: Maybe (BackendA Annex) 	, remotes :: [Types.Remote.RemoteA Annex]@@ -118,6 +123,7 @@ 	, fast :: Bool 	, daemon :: Bool 	, branchstate :: BranchState+	, getvectorclock :: IO VectorClock 	, repoqueue :: Maybe (Git.Queue.Queue Annex) 	, catfilehandles :: CatFileHandles 	, hashobjecthandle :: Maybe HashObjectHandle@@ -139,7 +145,8 @@ 	, sshstalecleaned :: TMVar Bool 	, flags :: M.Map String Bool 	, fields :: M.Map String String-	, cleanup :: M.Map CleanupAction (Annex ())+	, cleanupactions :: M.Map CleanupAction (Annex ())+	, signalactions :: TVar (M.Map SignalAction (Int -> IO ())) 	, sentinalstatus :: Maybe SentinalStatus 	, useragent :: Maybe String 	, errcounter :: Integer@@ -156,20 +163,25 @@ 	, cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)]) 	, urloptions :: Maybe UrlOptions 	, insmudgecleanfilter :: Bool+	, transferrerpool :: TransferrerPool 	}  newState :: GitConfig -> Git.Repo -> IO AnnexState newState c r = do 	emptyactiveremotes <- newMVar M.empty 	emptyactivekeys <- newTVarIO M.empty+	si <- newTVarIO M.empty 	o <- newMessageState 	sc <- newTMVarIO False 	kh <- Keys.newDbHandle+	tp <- newTransferrerPool+	vc <- startVectorClock 	return $ AnnexState 		{ repo = r 		, repoadjustment = return 		, gitconfig = c 		, gitconfigadjustment = id+		, gitconfigoverride = [] 		, gitremotes = Nothing 		, backend = Nothing 		, remotes = []@@ -179,6 +191,7 @@ 		, fast = False 		, daemon = False 		, branchstate = startBranchState+		, getvectorclock = vc 		, repoqueue = Nothing 		, catfilehandles = catFileHandlesNonConcurrent 		, hashobjecthandle = Nothing@@ -200,7 +213,8 @@ 		, sshstalecleaned = sc 		, flags = M.empty 		, fields = M.empty-		, cleanup = M.empty+		, cleanupactions = M.empty+		, signalactions = si 		, sentinalstatus = Nothing 		, useragent = Nothing 		, errcounter = 0@@ -217,6 +231,7 @@ 		, cachedgitenv = Nothing 		, urloptions = Nothing 		, insmudgecleanfilter = False+		, transferrerpool = tp 		}  {- Makes an Annex state object for the specified git repo.@@ -285,9 +300,9 @@ 	s { fields = M.insert field value $ fields s }  {- Adds a cleanup action to perform. -}-addCleanup :: CleanupAction -> Annex () -> Annex ()-addCleanup k a = changeState $ \s ->-	s { cleanup = M.insert k a $ cleanup s }+addCleanupAction :: CleanupAction -> Annex () -> Annex ()+addCleanupAction k a = changeState $ \s ->+	s { cleanupactions = M.insert k a $ cleanupactions s }  {- Sets the type of output to emit. -} setOutput :: OutputType -> Annex ()@@ -345,12 +360,14 @@ 	changeGitRepo =<< gitRepo  {- Adds git config setting, like "foo=bar". It will be passed with -c- - to git processes. The config setting is also recorded in the repo,+ - to git processes. The config setting is also recorded in the Repo,  - and the GitConfig is updated. -} addGitConfigOverride :: String -> Annex ()-addGitConfigOverride v = adjustGitRepo $ \r ->-	Git.Config.store (encodeBS' v) Git.Config.ConfigList $-		r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) }+addGitConfigOverride v = do+	adjustGitRepo $ \r ->+		Git.Config.store (encodeBS' v) Git.Config.ConfigList $+			r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) }+	changeState $ \s -> s { gitconfigoverride = v : gitconfigoverride s }   where 	-- Remove any prior occurrance of the setting to avoid 	-- building up many of them when the adjustment is run repeatedly,@@ -358,6 +375,10 @@ 	go [] = [Param "-c", Param v] 	go (Param "-c": Param v':rest) | v' == v = go rest 	go (c:rest) = c : go rest++{- Values that were passed to addGitConfigOverride. -}+getGitConfigOverrides :: Annex [String]+getGitConfigOverrides = reverse <$> getState gitconfigoverride  {- Changing the git Repo data also involves re-extracting its GitConfig. -} changeGitRepo :: Git.Repo -> Annex ()
Annex/Action.hs view
@@ -1,14 +1,19 @@ {- git-annex actions  -- - Copyright 2010-2015 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE CPP #-}+ module Annex.Action (+	action,+	verifiedAction, 	startup, 	shutdown, 	stopCoProcesses,+	stopNonConcurrentSafeCoProcesses, ) where  import qualified Data.Map as M@@ -20,21 +25,73 @@ import Annex.CheckAttr import Annex.HashObject import Annex.CheckIgnore+import Annex.TransferrerPool +import Control.Concurrent.STM+#ifndef mingw32_HOST_OS+import System.Posix.Signals+#endif++{- Runs an action that may throw exceptions, catching and displaying them. -}+action :: Annex () -> Annex Bool+action a = tryNonAsync a >>= \case+	Right () -> return True+	Left e -> do+		warning (show e)+		return False++verifiedAction :: Annex Verification -> Annex (Bool, Verification)+verifiedAction a = tryNonAsync a >>= \case+	Right v -> return (True, v)+	Left e -> do+		warning (show e)+		return (False, UnVerified)++ {- Actions to perform each time ran. -} startup :: Annex ()-startup = return ()+startup = do+#ifndef mingw32_HOST_OS+	av <- Annex.getState Annex.signalactions+	let propagate sig = liftIO $ installhandleronce sig av+	propagate sigINT+	propagate sigQUIT+	propagate sigTERM+	propagate sigTSTP+	propagate sigCONT+	propagate sigHUP+	-- sigWINCH is not propagated; it should not be needed,+	-- and the concurrent-output library installs its own signal+	-- handler for it.+	-- sigSTOP and sigKILL cannot be caught, so will not be propagated.+  where+	installhandleronce sig av = void $+		installHandler sig (CatchOnce (gotsignal sig av)) Nothing+	gotsignal sig av = do+		mapM_ (\a -> a (fromIntegral sig)) =<< atomically (readTVar av)+		raiseSignal sig+		installhandleronce sig av+#else+       return ()+#endif  {- Cleanup actions. -} shutdown :: Bool -> Annex () shutdown nocommit = do 	saveState nocommit-	sequence_ =<< M.elems <$> Annex.getState Annex.cleanup+	sequence_ =<< M.elems <$> Annex.getState Annex.cleanupactions 	stopCoProcesses -{- Stops all long-running git query processes. -}+{- Stops all long-running child processes, including git query processes. -} stopCoProcesses :: Annex () stopCoProcesses = do+	stopNonConcurrentSafeCoProcesses+	emptyTransferrerPool++{- Stops long-running child processes that use handles that are not safe+ - for multiple threads to access at the same time. -}+stopNonConcurrentSafeCoProcesses :: Annex ()+stopNonConcurrentSafeCoProcesses = do 	catFileStop 	checkAttrStop 	hashObjectStop
Annex/AdjustedBranch.hs view
@@ -296,7 +296,7 @@ 			unless (adjustmentIsStable adj) $ 				ifM (checkcounter n) 					( update adj origbranch-					, Annex.addCleanup AdjustedBranchUpdate $+					, Annex.addCleanupAction AdjustedBranchUpdate $ 						adjustedBranchRefreshFull adj origbranch 					) 		_ -> return ()
Annex/Concurrent.hs view
@@ -99,9 +99,9 @@  - Also closes various handles in it. -} mergeState :: AnnexState -> Annex () mergeState st = do-	st' <- liftIO $ snd <$> run st stopCoProcesses-	forM_ (M.toList $ Annex.cleanup st') $-		uncurry addCleanup+	st' <- liftIO $ snd <$> run st stopNonConcurrentSafeCoProcesses+	forM_ (M.toList $ Annex.cleanupactions st') $+		uncurry addCleanupAction 	Annex.Queue.mergeFrom st' 	changeState $ \s -> s { errcounter = errcounter s + errcounter st' }
Annex/Content.hs view
@@ -227,12 +227,7 @@ 		else verification 	if ok 		then ifM (verifyKeyContent rsp v verification' key tmpfile)-			( ifM (pruneTmpWorkDirBefore tmpfile (moveAnnex key af))-				( do-					logStatus key InfoPresent-					return True-				, return False-				)+			( pruneTmpWorkDirBefore tmpfile (moveAnnex key af) 			, do 				warning "verification of content failed" 				-- The bad content is not retained, because
Annex/Drop.hs view
@@ -11,7 +11,7 @@ import qualified Annex import Logs.Trust import Annex.NumCopies-import Types.Remote (uuid, appendonly, config)+import Types.Remote (uuid, appendonly, config, remotetype, thirdPartyPopulated) import qualified Remote import qualified Command.Drop import Command@@ -30,8 +30,9 @@  - and numcopies settings.  -  - Skips trying to drop from remotes that are appendonly, since those drops- - would presumably fail. Also skips dropping from exporttree remotes,- - which don't allow dropping individual keys.+ - would presumably fail. Also skips dropping from exporttree/importtree remotes,+ - which don't allow dropping individual keys, and from thirdPartyPopulated+ - remotes.  -  - The UUIDs are ones where the content is believed to be present.  - The Remote list can include other remotes that do not have the content;@@ -87,6 +88,8 @@ 		| uuid r `S.notMember` slocs = go fs rest n 		| appendonly r = go fs rest n 		| exportTree (config r) = go fs rest n+		| importTree (config r) = go fs rest n+		| thirdPartyPopulated (remotetype r) = go fs rest n 		| checkcopies n (Just $ Remote.uuid r) = 			dropr fs r n >>= go fs rest 		| otherwise = pure n
Annex/Export.hs view
@@ -43,10 +43,15 @@  warnExportImportConflict :: Remote -> Annex () warnExportImportConflict r = do-	ops <- Remote.isImportSupported r >>= return . \case-		True -> "exported to and/or imported from"-		False -> "exported to"-	toplevelWarning True $-		"Conflict detected. Different trees have been " ++ ops ++-		Remote.name r ++ -		". Use git-annex export to resolve this conflict."+	isimport <- Remote.isImportSupported r+	isexport <- Remote.isExportSupported r+	let (ops, resolvcmd) = case (isexport, isimport) of+		(False, True) -> ("imported from", "git-annex import")+		(True, False) -> ("exported to", "git-annex export")+		_ -> ("exported to and/or imported from", "git-annex export")+	toplevelWarning True $ unwords+		[ "Conflict detected. Different trees have been"+		, ops, Remote.name r ++ ". Use"+		, resolvcmd+		, "to resolve this conflict."+		]
Annex/FileMatcher.hs view
@@ -72,9 +72,11 @@ checkMatcher matcher mkey afile notpresent notconfigured d 	| isEmpty matcher = notconfigured 	| otherwise = case (mkey, afile) of-		(Nothing, AssociatedFile (Just file)) -> go =<< fileMatchInfo file-		(Just key, _) -> go (MatchingKey key afile)-		_ -> d+		(_, AssociatedFile (Just file)) ->+			go =<< fileMatchInfo file mkey+		(Just key, AssociatedFile Nothing) ->+			go (MatchingKey key afile)+		(Nothing, _) -> d   where 	go mi = checkMatcher' matcher mi notpresent @@ -82,12 +84,13 @@ checkMatcher' matcher mi notpresent = 	matchMrun matcher $ \o -> matchAction o notpresent mi -fileMatchInfo :: RawFilePath -> Annex MatchInfo-fileMatchInfo file = do+fileMatchInfo :: RawFilePath -> Maybe Key -> Annex MatchInfo+fileMatchInfo file mkey = do 	matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) 	return $ MatchingFile FileInfo 		{ matchFile = matchfile 		, contentFile = Just file+		, matchKey = mkey 		}  matchAll :: FileMatcher Annex
Annex/Import.hs view
@@ -12,6 +12,7 @@ 	ImportCommitConfig(..), 	buildImportCommit, 	buildImportTrees,+	recordImportTree, 	canImportKeys, 	importKeys, 	makeImportMatcher,@@ -37,6 +38,7 @@ import Annex.HashObject import Annex.Transfer import Annex.CheckIgnore+import Annex.VectorClock import Command import Backend import Types.Key@@ -105,6 +107,28 @@ 			Nothing -> go Nothing 			Just _ -> go (Just trackingcommit)   where+	go trackingcommit = do+		(imported, updatestate) <- recordImportTree remote importtreeconfig importable+		buildImportCommit' remote importcommitconfig trackingcommit imported >>= \case+			Just finalcommit -> do+				updatestate+				return (Just finalcommit)+			Nothing -> return Nothing++{- Builds a tree for an import from a special remote.+ -+ - Also returns an action that can be used to update + - all the other state to record the import.+ -}+recordImportTree+	:: Remote+	-> ImportTreeConfig+	-> ImportableContents (Either Sha Key)+	-> Annex (History Sha, Annex ())+recordImportTree remote importtreeconfig importable = do+	imported@(History finaltree _) <- buildImportTrees basetree subdir importable+	return (imported, updatestate finaltree)+  where 	basetree = case importtreeconfig of 		ImportTree -> emptyTree 		ImportSubTree _ sha -> sha@@ -112,21 +136,12 @@ 		ImportTree -> Nothing 		ImportSubTree dir _ -> Just dir 	-	go trackingcommit = do-		imported@(History finaltree _) <--			buildImportTrees basetree subdir importable-		buildImportCommit' remote importcommitconfig trackingcommit imported >>= \case-			Just finalcommit -> do-				updatestate finaltree-				return (Just finalcommit)-			Nothing -> return Nothing-	-	updatestate committedtree = do+	updatestate finaltree = do 		importedtree <- case subdir of-			Nothing -> pure committedtree+			Nothing -> pure finaltree 			Just dir ->  				let subtreeref = Ref $-					fromRef' committedtree +					fromRef' finaltree 						<> ":" 						<> getTopFilePath dir 				in fromMaybe emptyTree@@ -147,7 +162,7 @@ 	 	updateexportlog importedtree = do 		oldexport <- getExport (Remote.uuid remote)-		recordExport (Remote.uuid remote) $ ExportChange+		recordExport (Remote.uuid remote) importedtree $ ExportChange 			{ oldTreeish = exportedTreeishes oldexport 			, newTreeish = importedtree 			}@@ -308,9 +323,10 @@ 	:: Remote 	-> ImportTreeConfig 	-> Bool+	-> Bool 	-> ImportableContents (ContentIdentifier, ByteSize) 	-> Annex (Maybe (ImportableContents (Either Sha Key)))-importKeys remote importtreeconfig importcontent importablecontents = do+importKeys remote importtreeconfig importcontent thirdpartypopulated importablecontents = do 	unless (canImportKeys remote importcontent) $ 		giveup "This remote does not support importing without downloading content." 	-- This map is used to remember content identifiers that@@ -327,12 +343,23 @@ 		bracket CIDDb.openDb CIDDb.closeDb $ \db -> do 			CIDDb.needsUpdateFromLog db 				>>= maybe noop (CIDDb.updateFromLog db)-			go False cidmap importing importablecontents db+			(run (go False cidmap importing importablecontents db))   where+	-- When not importing content, reuse the same vector+	-- clock for all state that's recorded. This can save+	-- a little bit of disk space. Individual file downloads+	-- while downloading take too long for this optimisation+	-- to be safe to do.+	run a+		| importcontent = a+		| otherwise = reuseVectorClockWhile a+ 	go oldversion cidmap importing (ImportableContents l h) db = do 		largematcher <- largeFilesMatcher 		jobs <- forM l $ \i ->-			startimport cidmap importing db i oldversion largematcher+			if thirdpartypopulated+				then thirdpartypopulatedimport cidmap db i+				else startimport cidmap importing db i oldversion largematcher 		l' <- liftIO $ forM jobs $ 			either pure (atomically . takeTMVar) 		if any isNothing l'@@ -391,6 +418,20 @@ 				importaction 			return (Right job) 	+	thirdpartypopulatedimport cidmap db (loc, (cid, sz)) = +		case Remote.importKey ia of+			Nothing -> return $ Left Nothing+			Just importkey ->+				tryNonAsync (importkey loc cid sz nullMeterUpdate) >>= \case+					Right (Just k) -> do+						recordcidkey cidmap db cid k+						logChange k (Remote.uuid remote) InfoPresent				+						return $ Left $ Just (loc, Right k)+					Right Nothing -> return $ Left Nothing+					Left e -> do+						warning (show e)+						return $ Left Nothing+	 	importordownload cidmap db (loc, (cid, sz)) largematcher= do 		f <- locworktreefile loc 		matcher <- largematcher f@@ -433,25 +474,22 @@ 				return Nothing 	  where 		importer = do-			unsizedk <- importkey loc cid-				-- Don't display progress when generating-				-- key, if the content will later be-				-- downloaded, which is a more expensive-				-- operation generally.-				(if importcontent then nullMeterUpdate else p)-			-- This avoids every remote needing-			-- to add the size.-			let k = alterKey unsizedk $ \kd -> kd-				{ keySize = keySize kd <|> Just sz }-			checkSecureHashes k >>= \case-				Nothing -> do-					recordcidkey cidmap db cid k-					logChange k (Remote.uuid remote) InfoPresent-					if importcontent-						then getcontent k-						else return (Just (k, True))-				Just msg -> giveup (msg ++ " to import")-		+			-- Don't display progress when generating+			-- key, if the content will later be+			-- downloaded, which is a more expensive+			-- operation generally.+			let p' = if importcontent then nullMeterUpdate else p+			importkey loc cid sz p' >>= \case+				Nothing -> return Nothing+				Just k -> checkSecureHashes k >>= \case+					Nothing -> do+						recordcidkey cidmap db cid k+						logChange k (Remote.uuid remote) InfoPresent+						if importcontent+							then getcontent k+							else return (Just (k, True))+					Just msg -> giveup (msg ++ " to import")+ 		getcontent :: Key -> Annex (Maybe (Key, Bool)) 		getcontent k = do 			let af = AssociatedFile (Just f)@@ -466,7 +504,7 @@ 				return (Just (k', ok)) 			checkDiskSpaceToGet k Nothing $ 				notifyTransfer Download af $-					download (Remote.uuid remote) k af stdRetry $ \p' ->+					download' (Remote.uuid remote) k af stdRetry $ \p' -> 						withTmp k $ downloader p' 			 	-- The file is small, so is added to git, so while importing@@ -520,7 +558,7 @@ 				return Nothing 		checkDiskSpaceToGet tmpkey Nothing $ 			notifyTransfer Download af $-				download (Remote.uuid remote) tmpkey af stdRetry $ \p ->+				download' (Remote.uuid remote) tmpkey af stdRetry $ \p -> 					withTmp tmpkey $ \tmpfile -> 						metered (Just p) tmpkey $ 							const (rundownload tmpfile)@@ -531,6 +569,7 @@ 			let mi = MatchingFile FileInfo 				{ matchFile = f 				, contentFile = Just tmpfile+				, matchKey = Nothing 				} 			islargefile <- checkMatcher' matcher mi mempty 			if islargefile@@ -629,14 +668,17 @@  - regardless. (Similar to how git add behaves on gitignored files.)  - This avoids creating a remote tracking branch that, when merged,  - would delete the files.+ -+ - Throws exception if unable to contact the remote.+ - Returns Nothing when there is no change since last time.  -} getImportableContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> FileMatcher Annex -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))-getImportableContents r importtreeconfig ci matcher = +getImportableContents r importtreeconfig ci matcher = do 	Remote.listImportableContents (Remote.importActions r) >>= \case-		Nothing -> return Nothing 		Just importable -> do 			dbhandle <- Export.openDb (Remote.uuid r) 			Just <$> filterunwanted dbhandle importable+		Nothing -> return Nothing   where 	filterunwanted dbhandle ic = ImportableContents 		<$> filterM (wanted dbhandle) (importableContents ic)
Annex/Ingest.hs view
@@ -378,6 +378,7 @@ 		Just tmp -> MatchingFile $ FileInfo 			{ contentFile = Just tmp 			, matchFile = file+			, matchKey = Just key 			} 		-- Provide as much info as we can without access to the 		-- file's content.
Annex/Init.hs view
@@ -65,8 +65,8 @@ import Control.Concurrent.Async #endif -checkCanInitialize :: Annex a -> Annex a-checkCanInitialize a = canInitialize' >>= \case+checkInitializeAllowed :: Annex a -> Annex a+checkInitializeAllowed a = noAnnexFileContent' >>= \case 	Nothing -> a 	Just noannexmsg -> do 		warning "Initialization prevented by .noannex file (remove the file to override)"@@ -74,11 +74,12 @@ 			warning noannexmsg 		giveup "Not initialized." -canInitialize :: Annex Bool-canInitialize = isNothing <$> canInitialize'+initializeAllowed :: Annex Bool+initializeAllowed = isNothing <$> noAnnexFileContent' -canInitialize' :: Annex (Maybe String)-canInitialize' = inRepo (noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree)+noAnnexFileContent' :: Annex (Maybe String)+noAnnexFileContent' = inRepo $+	noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree  genDescription :: Maybe String -> Annex UUIDDesc genDescription (Just d) = return $ UUIDDesc $ encodeBS d@@ -94,7 +95,7 @@ 		Left _ -> [hostname, ":", reldir]  initialize :: Maybe String -> Maybe RepoVersion -> Annex ()-initialize mdescription mversion = checkCanInitialize $ do+initialize mdescription mversion = checkInitializeAllowed $ do 	{- Has to come before any commits are made as the shared 	 - clone heuristic expects no local objects. -} 	sharedclone <- checkSharedClone@@ -117,7 +118,7 @@ -- Everything except for uuid setup, shared clone setup, and initial -- description. initialize' :: Maybe RepoVersion -> Annex ()-initialize' mversion = checkCanInitialize  $ do+initialize' mversion = checkInitializeAllowed $ do 	checkLockSupport 	checkFifoSupport 	checkCrippledFileSystem@@ -158,6 +159,29 @@ 	removeRepoUUID 	removeVersion +{- Gets the version that the repo is initialized with.+ -+ - To make sure the repo is fully initialized, also checks that it has a+ - uuid configured. In the unusual case where one is set and the other is+ - not, errors out to avoid running in an inconsistent state.+ -}+getInitializedVersion :: Annex (Maybe RepoVersion)+getInitializedVersion = do+	um <- (\u -> if u == NoUUID then Nothing else Just u) <$> getUUID+	vm <- getVersion+	case (um, vm) of+		(Just _, Just v) -> return (Just v)+		(Nothing, Nothing) -> return Nothing+		(Just _, Nothing) -> onemissing "annex.version" "annex.uuid"+		(Nothing, Just _) -> onemissing "annex.uuid" "annex.version"+  where+	onemissing missing have = giveup $ unwords+		[ "This repository has " ++ have ++ " set,"+		, "but " ++ missing ++ " is not set. Perhaps that"+		, "git config was lost. Cannot use the repository"+		, "in this state; set back " ++ missing ++ " to fix this."+		]+ {- Will automatically initialize if there is already a git-annex  - branch from somewhere. Otherwise, require a manual init  - to avoid git-annex accidentally being run in git@@ -166,23 +190,44 @@  - Checks repository version and handles upgrades too.  -} ensureInitialized :: Annex ()-ensureInitialized = getVersion >>= maybe needsinit checkUpgrade+ensureInitialized = getInitializedVersion >>= maybe needsinit checkUpgrade   where-	needsinit = ifM Annex.Branch.hasSibling+	needsinit = ifM autoInitializeAllowed 		( do 			initialize Nothing Nothing 			autoEnableSpecialRemotes 		, giveup "First run: git-annex init" 		) -{- Initialize if it can do so automatically.+{- Check if auto-initialize is allowed. -}+autoInitializeAllowed :: Annex Bool+autoInitializeAllowed = Annex.Branch.hasSibling <&&> objectDirNotPresent++objectDirNotPresent :: Annex Bool+objectDirNotPresent = do+	d <- fromRawFilePath <$> fromRepo gitAnnexObjectDir+	exists <- liftIO $ doesDirectoryExist d+	when exists $+		giveup $ unwords $ +			[ "This repository is not initialized for use"+			, "by git-annex, but " ++ d ++ " exists,"+			, "which indicates this repository was used by"+			, "git-annex before, and may have lost its"+			, "annex.uuid and annex.version configs. Either"+			, "set back missing configs, or run git-annex init"+			, "to initialize with a new uuid."+			]+	return (not exists)++{- Initialize if it can do so automatically. Avoids failing if it cannot.  -  - Checks repository version and handles upgrades too.  -} autoInitialize :: Annex ()-autoInitialize = getVersion >>= maybe needsinit checkUpgrade+autoInitialize = getInitializedVersion >>= maybe needsinit checkUpgrade   where-	needsinit = whenM (canInitialize <&&> Annex.Branch.hasSibling) $ do+	needsinit =+		whenM (initializeAllowed <&&> autoInitializeAllowed) $ do 			initialize Nothing Nothing 			autoEnableSpecialRemotes @@ -252,7 +297,8 @@ probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do 	let f = tmp P.</> "lockprobe" 	mode <- annexFileMode-	liftIO $ withAsync warnstall (const (go f mode))+	annexrunner <- Annex.makeRunner+	liftIO $ withAsync (warnstall annexrunner) (const (go f mode))   where 	go f mode = do 		removeWhenExistsWith R.removeLink f@@ -264,10 +310,11 @@ 		removeWhenExistsWith R.removeLink f 		return ok 	-	warnstall = do+	warnstall annexrunner = do 		threadDelaySeconds (Seconds 10)-		warningIO "Probing the filesystem for POSIX fcntl lock support is taking a long time."-		warningIO "(Setting annex.pidlock will avoid this probe.)"+		annexrunner $ do+			warning "Probing the filesystem for POSIX fcntl lock support is taking a long time."+			warning "(Setting annex.pidlock will avoid this probe.)" #endif  probeFifoSupport :: Annex Bool@@ -336,10 +383,8 @@ autoEnableSpecialRemotes :: Annex () autoEnableSpecialRemotes = do 	rp <- fromRawFilePath <$> fromRepo Git.repoPath-	withNullHandle $ \nullh -> gitAnnexChildProcess-		[ "init"-		, "--autoenable"-		]+	withNullHandle $ \nullh -> gitAnnexChildProcess "init"+		[ Param "--autoenable" ] 		(\p -> p 			{ std_out = UseHandle nullh 			, std_err = UseHandle nullh
Annex/MetaData.hs view
@@ -107,7 +107,7 @@ 		('>':v) -> checkcmp (>) v 		_ -> checkglob "" 	checkglob v =-		let cglob = compileGlob v CaseInsensative+		let cglob = compileGlob v CaseInsensative (GlobFilePath False) 		in matchGlob cglob . decodeBS . fromMetaValue 	checkcmp cmp v v' = case (doubleval v, doubleval (decodeBS (fromMetaValue v'))) of 		(Just d, Just d') -> d' `cmp` d
Annex/Path.hs view
@@ -11,6 +11,7 @@ import Config.Files import Utility.Env import Annex.PidLock+import qualified Annex  import System.Environment (getExecutablePath) @@ -55,10 +56,22 @@  - to avoid it deadlocking.  -} gitAnnexChildProcess-	:: [String]+	:: String+	-> [CommandParam] 	-> (CreateProcess -> CreateProcess) 	-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) 	-> Annex a-gitAnnexChildProcess ps f a = do+gitAnnexChildProcess subcmd ps f a = do 	cmd <- liftIO programPath-	pidLockChildProcess cmd ps f a+	ps' <- gitAnnexChildProcessParams subcmd ps+	pidLockChildProcess cmd ps' f a++{- Parameters to pass to a git-annex child process to run a subcommand+ - with some parameters.+ -+ - Includes -c values that were passed on the git-annex command line.+ -}+gitAnnexChildProcessParams :: String -> [CommandParam] -> Annex [CommandParam]+gitAnnexChildProcessParams subcmd ps = do+	cps <- concatMap (\c -> [Param "-c", Param c]) <$> Annex.getGitConfigOverrides+	return (Param subcmd : cps ++ ps)
Annex/PidLock.hs view
@@ -38,12 +38,12 @@  -} pidLockChildProcess 	:: FilePath-	-> [String]+	-> [CommandParam] 	-> (CreateProcess -> CreateProcess) 	-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) 	-> Annex a pidLockChildProcess cmd ps f a = do-	let p = f (proc cmd ps)+	let p = f (proc cmd (toCommand ps)) 	let gonopidlock = withCreateProcess p a #ifndef mingw32_HOST_OS 	pidLockFile >>= liftIO . \case@@ -75,7 +75,7 @@  -  - This is like pidLockChildProcess, but rather than running a process  - itself, it runs the action with a modified Annex state that passes the- - necessary env var.+ - necessary env var when running git.  -} runsGitAnnexChildProcessViaGit :: Annex a -> Annex a #ifndef mingw32_HOST_OS
Annex/Ssh.hs view
@@ -230,7 +230,7 @@ 				sshCleanup 				liftIO $ atomically $ putTMVar tv True 	-- Cleanup at shutdown.-	Annex.addCleanup SshCachingCleanup sshCleanup+	Annex.addCleanupAction SshCachingCleanup sshCleanup 	 	let socketlock = socket2lock socketfile
Annex/Tmp.hs view
@@ -24,7 +24,7 @@ -- any time. withOtherTmp :: (RawFilePath -> Annex a) -> Annex a withOtherTmp a = do-	Annex.addCleanup OtherTmpCleanup cleanupOtherTmp+	Annex.addCleanupAction OtherTmpCleanup cleanupOtherTmp 	tmpdir <- fromRepo gitAnnexTmpOtherDir 	tmplck <- fromRepo gitAnnexTmpOtherLock 	withSharedLock (const tmplck) $ do
Annex/Transfer.hs view
@@ -10,13 +10,16 @@ module Annex.Transfer ( 	module X, 	upload,+	upload', 	alwaysUpload, 	download,+	download', 	runTransfer, 	alwaysRunTransfer, 	noRetry, 	stdRetry, 	pickRemote,+	stallDetection, ) where  import Annex.Common@@ -24,7 +27,10 @@ import Logs.Transfer as X import Types.Transfer as X import Annex.Notification as X+import Annex.Content import Annex.Perms+import Annex.Action+import Logs.Location import Utility.Metered import Utility.ThreadScheduler import Annex.LockPool@@ -34,7 +40,9 @@ import Annex.Concurrent.Utility import Types.WorkerPool import Annex.WorkerPool+import Annex.TransferrerPool import Backend (isCryptographicallySecure)+import Types.StallDetection import qualified Utility.RawFilePath as R  import Control.Concurrent@@ -42,16 +50,36 @@ import qualified System.FilePath.ByteString as P import Data.Ord -upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v-upload u key f d a _witness = guardHaveUUID u $ +-- Upload, supporting stall detection.+upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool+upload r key f d witness = stallDetection r >>= \case+	Nothing -> upload' (Remote.uuid r) key f d go witness+	Just sd -> runTransferrer sd r key f d Upload witness+  where+	go = action . Remote.storeKey r key f++-- Upload, not supporting stall detection.+upload' :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v+upload' u key f d a _witness = guardHaveUUID u $  	runTransfer (Transfer Upload u (fromKey id key)) f d a  alwaysUpload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v alwaysUpload u key f d a _witness = guardHaveUUID u $  	alwaysRunTransfer (Transfer Upload u (fromKey id key)) f d a -download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v-download u key f d a _witness = guardHaveUUID u $+-- Download, supporting stall detection.+download :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool+download r key f d witness = logStatusAfter key $ stallDetection r >>= \case+	Nothing -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key f $ \dest ->+		download' (Remote.uuid r) key f d (go dest) witness+	Just sd -> runTransferrer sd r key f d Download witness+  where+	go dest p = verifiedAction $+		Remote.retrieveKeyFile r key f (fromRawFilePath dest) p++-- Download, not supporting stall detection.+download' :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v+download' u key f d a _witness = guardHaveUUID u $ 	runTransfer (Transfer Download u (fromKey id key)) f d a  guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v@@ -81,7 +109,7 @@ alwaysRunTransfer = runTransfer' True  runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v-runTransfer' ignorelock t afile retrydecider transferaction = enteringStage TransferStage $ debugLocks $ checkSecureHashes t $ do+runTransfer' ignorelock t afile retrydecider transferaction = enteringStage TransferStage $ debugLocks $ preCheckSecureHashes (transferKey t) $ do 	info <- liftIO $ startTransferInfo afile 	(meter, tfile, createtfile, metervar) <- mkProgressUpdater t info 	mode <- annexFileMode@@ -168,6 +196,31 @@ 			f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t) 			liftIO $ catchDefaultIO 0 $ getFileSize f +runTransferrer+	:: StallDetection+	-> Remote+	-> Key+	-> AssociatedFile+	-> RetryDecider+	-> Direction+	-> NotifyWitness+	-> Annex Bool+runTransferrer sd r k afile retrydecider direction _witness =+	enteringStage TransferStage $ preCheckSecureHashes k $ do+		info <- liftIO $ startTransferInfo afile+		go 0 info+  where+	go numretries info = +		withTransferrer (performTransfer (Just sd) AnnexLevel id (Just r) t info) >>= \case+			Right () -> return True+			Left newinfo -> do+				let !numretries' = succ numretries+				ifM (retrydecider numretries' info newinfo)+					( go numretries' newinfo+					, return False+					)+	t = Transfer direction (Remote.uuid r) (fromKey id k)+ {- Avoid download and upload of keys with insecure content when  - annex.securehashesonly is configured.  -@@ -180,8 +233,8 @@  - still contains content using an insecure hash, remotes will likewise  - tend to be configured to reject it, so Upload is also prevented.  -}-checkSecureHashes :: Observable v => Transfer -> Annex v -> Annex v-checkSecureHashes t a = ifM (isCryptographicallySecure (transferKey t))+preCheckSecureHashes :: Observable v => Key -> Annex v -> Annex v+preCheckSecureHashes k a = ifM (isCryptographicallySecure k) 	( a 	, ifM (annexSecureHashesOnly <$> Annex.getGitConfig) 		( do@@ -191,7 +244,7 @@ 		) 	)   where-	variety = fromKey keyVariety (transferKey t)+	variety = fromKey keyVariety k  type NumRetries = Integer @@ -314,3 +367,9 @@ lessActiveFirst active a b 	| Remote.cost a == Remote.cost b = comparing (`M.lookup` active) a b 	| otherwise = comparing Remote.cost a b++stallDetection :: Remote -> Annex (Maybe StallDetection)+stallDetection r = maybe globalcfg (pure . Just) remotecfg+  where+	globalcfg = annexStallDetection <$> Annex.getGitConfig+	remotecfg = remoteAnnexStallDetection $ Remote.gitconfig r
+ Annex/TransferrerPool.hs view
@@ -0,0 +1,310 @@+{- A pool of "git-annex transferrer" processes+ -+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}++module Annex.TransferrerPool where++import Annex.Common+import qualified Annex+import Types.TransferrerPool+import Types.Transferrer+import Types.Transfer+import qualified Types.Remote as Remote+import Types.StallDetection+import Types.Messages+import Types.CleanupActions+import Messages.Serialized+import Annex.Path+import Utility.Batch+import Utility.Metered+import Utility.HumanTime+import Utility.ThreadScheduler+import qualified Utility.SimpleProtocol as Proto++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM hiding (check)+import Control.Monad.IO.Class (MonadIO)+import System.Log.Logger (debugM)+import qualified Data.Map as M+#ifndef mingw32_HOST_OS+import System.Posix.Signals+import System.Posix.Process (getProcessGroupIDOf)+#endif++type SignalActionsVar = TVar (M.Map SignalAction (Int -> IO ()))++data RunTransferrer = RunTransferrer String [CommandParam] BatchCommandMaker++mkRunTransferrer :: BatchCommandMaker -> Annex RunTransferrer+mkRunTransferrer batchmaker = RunTransferrer+	<$> liftIO programPath+	<*> gitAnnexChildProcessParams "transferrer" []+	<*> pure batchmaker++{- Runs an action with a Transferrer from the pool. -}+withTransferrer :: (Transferrer -> Annex a) -> Annex a+withTransferrer a = do+	rt <- mkRunTransferrer nonBatchCommandMaker+	pool <- Annex.getState Annex.transferrerpool+	let nocheck = pure (pure True)+	signalactonsvar <- Annex.getState Annex.signalactions+	withTransferrer' False signalactonsvar nocheck rt pool a++withTransferrer'+	:: (MonadIO m, MonadMask m)+	=> Bool+	-- ^ When minimizeprocesses is True, only one Transferrer is left+	-- running in the pool at a time. So if this needed to start a+	-- new Transferrer, it's stopped when done. Otherwise, idle+	-- processes are left in the pool for use later.+	-> SignalActionsVar+	-> MkCheckTransferrer+	-> RunTransferrer+	-> TransferrerPool+	-> (Transferrer -> m a)+	-> m a+withTransferrer' minimizeprocesses signalactonsvar mkcheck rt pool a = do+	(mi, leftinpool) <- liftIO $ atomically (popTransferrerPool pool)+	(i@(TransferrerPoolItem _ check), t) <- liftIO $ case mi of+		Nothing -> do+			t <- mkTransferrer signalactonsvar rt+			i <- mkTransferrerPoolItem mkcheck t+			return (i, t)+		Just i -> checkTransferrerPoolItem signalactonsvar rt i+	a t `finally` returntopool leftinpool check t i+  where+	returntopool leftinpool check t i+		| not minimizeprocesses || leftinpool == 0 =+			-- If the transferrer got killed, the handles will+			-- be closed, so it should not be returned to the+			-- pool.+			liftIO $ whenM (hIsOpen (transferrerWrite t)) $+				liftIO $ atomically $ pushTransferrerPool pool i+		| otherwise = liftIO $ do+			void $ forkIO $ transferrerShutdown t+			atomically $ pushTransferrerPool pool $ TransferrerPoolItem Nothing check++{- Check if a Transferrer from the pool is still ok to be used.+ - If not, stop it and start a new one. -}+checkTransferrerPoolItem :: SignalActionsVar -> RunTransferrer -> TransferrerPoolItem -> IO (TransferrerPoolItem, Transferrer)+checkTransferrerPoolItem signalactonsvar rt i = case i of+	TransferrerPoolItem (Just t) check -> ifM check+		( return (i, t)+		, do+			transferrerShutdown t+			new check+		)+	TransferrerPoolItem Nothing check -> new check+  where+	new check = do+		t <- mkTransferrer signalactonsvar rt+		return (TransferrerPoolItem (Just t) check, t)++data TransferRequestLevel = AnnexLevel | AssistantLevel+	deriving (Show)++{- Requests that a Transferrer perform a Transfer, and waits for it to+ - finish.+ -+ - When a stall is detected, kills the Transferrer.+ -+ - If the transfer failed or stalled, returns TransferInfo with an+ - updated bytesComplete reflecting how much data has been transferred.+ -}+performTransfer+	:: (Monad m, MonadIO m, MonadMask m)+	=> Maybe StallDetection+	-> TransferRequestLevel+	-> (forall a. Annex a -> m a)+	-- ^ Run an annex action in the monad. Will not be used with+	-- actions that block for a long time.+	-> Maybe Remote+	-> Transfer+	-> TransferInfo+	-> Transferrer+	-> m (Either TransferInfo ())+performTransfer stalldetection level runannex r t info transferrer = do+	bpv <- liftIO $ newTVarIO zeroBytesProcessed+	ifM (catchBoolIO $ bracket setup cleanup (go bpv))+		( return (Right ())+		, do+			n <- case transferDirection t of+				Upload -> liftIO $ atomically $ +					fromBytesProcessed <$> readTVar bpv+				Download -> do+					f <- runannex $ fromRepo $ gitAnnexTmpObjectLocation (transferKey t)+					liftIO $ catchDefaultIO 0 $ getFileSize f+			return $ Left $ info { bytesComplete = Just n }+		)+  where+	setup = do+		liftIO $ sendRequest level t r+			(associatedFile info)+			(transferrerWrite transferrer)+		metervar <- liftIO $ newTVarIO Nothing+		stalledvar <- liftIO $ newTVarIO False+		tid <- liftIO $ async $ +			detectStalls stalldetection metervar $ do+				atomically $ writeTVar stalledvar True+				killTransferrer transferrer+		return (metervar, tid, stalledvar)+	+	cleanup (_, tid, stalledvar) = do+		liftIO $ uninterruptibleCancel tid+		whenM (liftIO $ atomically $ readTVar stalledvar) $ do+			runannex $ showLongNote "Transfer stalled"+			-- Close handles, to prevent the transferrer being+			-- reused since the process was killed.+			liftIO $ hClose $ transferrerRead transferrer+			liftIO $ hClose $ transferrerWrite transferrer++	go bpv (metervar, _, _) = relaySerializedOutput+		(liftIO $ readResponse (transferrerRead transferrer))+		(liftIO . sendSerializedOutputResponse (transferrerWrite transferrer))+		(updatemeter bpv metervar)+		runannex+	+	updatemeter bpv metervar (Just n) = liftIO $ do+		atomically $ writeTVar metervar (Just n)+		atomically $ writeTVar bpv n+	updatemeter _bpv metervar Nothing = liftIO $+		atomically $ writeTVar metervar Nothing++detectStalls :: Maybe StallDetection -> TVar (Maybe BytesProcessed) -> IO () -> IO ()+detectStalls Nothing _ _ = noop+detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothing+  where+	go st = do+		threadDelaySeconds (Seconds (fromIntegral (durationSeconds duration)))+		-- Get whatever progress value was reported last, if any.+		v <- atomically $ fmap fromBytesProcessed+			<$> readTVar metervar+		let cont = go v+		case (st, v) of+			(Nothing, _) -> cont+			(_, Nothing) -> cont+			(Just prev, Just sofar)+				-- Just in case a progress meter somehow runs+				-- backwards, or a second progress meter was+				-- started and is at a smaller value than+				-- the previous one.+				| prev > sofar -> cont+				| sofar - prev < minsz -> onstall+				| otherwise -> cont++{- Starts a new git-annex transfer process, setting up handles+ - that will be used to communicate with it. -}+mkTransferrer :: SignalActionsVar -> RunTransferrer -> IO Transferrer+mkTransferrer signalactonsvar (RunTransferrer program params batchmaker) = do+	{- It runs as a batch job. -}+	let (program', params') = batchmaker (program, params)+	{- It's put into its own group so that the whole group can be+	 - killed to stop a transfer. -}+	(Just writeh, Just readh, _, ph) <- createProcess+		(proc program' $ toCommand params')+		{ create_group = True+		, std_in = CreatePipe+		, std_out = CreatePipe+		}++	{- Set up signal propagation, so eg ctrl-c will also interrupt+	 - the processes in the transferrer's process group. +	 -+	 - There is a race between the process being created and this point.+	 - If a signal is received before this can run, it is not sent to+	 - the transferrer. This leaves the transferrer waiting for the+	 - first message on stdin to tell what to do. If the signal kills+	 - this parent process, the transferrer will then get a sigpipe+	 - and die too. If the signal suspends this parent process,+	 - it's ok to leave the transferrer running, as it's waiting on+	 - the pipe until this process wakes back up.+	 -}+#ifndef mingw32_HOST_OS+	pid <- getPid ph+	unregistersignalprop <- case pid of+		Just p -> getProcessGroupIDOf p >>= \pgrp -> do+			atomically $ modifyTVar' signalactonsvar $ +				M.insert (PropagateSignalProcessGroup p) $ \sig ->+					signalProcessGroup (fromIntegral sig) pgrp+			return $ atomically $ modifyTVar' signalactonsvar $+				M.delete (PropagateSignalProcessGroup p)+		Nothing -> return noop+#else+	let unregistersignalprop = noop+#endif++	return $ Transferrer+		{ transferrerRead = readh+		, transferrerWrite = writeh+		, transferrerHandle = ph+		, transferrerShutdown = do+			hClose readh+			hClose writeh+			void $ waitForProcess ph+			unregistersignalprop+		}++-- | Send a request to perform a transfer.+sendRequest :: TransferRequestLevel -> Transfer -> Maybe Remote -> AssociatedFile -> Handle -> IO ()+sendRequest level t mremote afile h = do+	let tr = maybe+		(TransferRemoteUUID (transferUUID t))+		(TransferRemoteName . Remote.name)+		mremote+	let f = case (level, transferDirection t) of+		(AnnexLevel, Upload) -> UploadRequest+		(AnnexLevel, Download) -> DownloadRequest+		(AssistantLevel, Upload) -> AssistantUploadRequest+		(AssistantLevel, Download) -> AssistantDownloadRequest+	let r = f tr (transferKey t) (TransferAssociatedFile afile)+	let l = unwords $ Proto.formatMessage r+	debugM "transfer" ("> " ++ l)+	hPutStrLn h l+	hFlush h++sendSerializedOutputResponse :: Handle -> SerializedOutputResponse -> IO ()+sendSerializedOutputResponse h sor = do+	let l = unwords $ Proto.formatMessage $+		TransferSerializedOutputResponse sor+	debugM "transfer" ("> " ++ show l)+	hPutStrLn h l+	hFlush h++-- | Read a response to a transfer request.+--+-- Before the final response, this will return whatever SerializedOutput+-- should be displayed as the transfer is performed.+readResponse :: Handle -> IO (Either SerializedOutput Bool)+readResponse h = do+	l <- liftIO $ hGetLine h+	debugM "transfer" ("< " ++ l)+	case Proto.parseMessage l of+		Just (TransferOutput so) -> return (Left so)+		Just (TransferResult r) -> return (Right r)+		Nothing -> transferrerProtocolError l++transferrerProtocolError :: String -> a+transferrerProtocolError l = giveup $ "transferrer protocol error: " ++ show l++{- Kill the transferrer, and all its child processes. -}+killTransferrer :: Transferrer -> IO ()+killTransferrer t = do+	interruptProcessGroupOf $ transferrerHandle t+	threadDelay 50000 -- 0.05 second grace period+	terminateProcess $ transferrerHandle t++{- Stop all transferrers in the pool. -}+emptyTransferrerPool :: Annex ()+emptyTransferrerPool = do+	poolvar <- Annex.getState Annex.transferrerpool+	pool <- liftIO $ atomically $ swapTVar poolvar []+	liftIO $ forM_ pool $ \case+		TransferrerPoolItem (Just t) _ -> transferrerShutdown t+		TransferrerPoolItem Nothing _ -> noop
Annex/VectorClock.hs view
@@ -3,42 +3,54 @@  - We don't have a way yet to keep true distributed vector clocks.  - The next best thing is a timestamp.  -- - Copyright 2017-2019 Joey Hess <id@joeyh.name>+ - Copyright 2017-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} -module Annex.VectorClock where--import Data.Time.Clock.POSIX-import Data.ByteString.Builder-import Control.Applicative-import Prelude+module Annex.VectorClock (+	module Annex.VectorClock,+	module Types.VectorClock,+) where -import Utility.Env+import Types.VectorClock+import Annex.Common+import qualified Annex import Utility.TimeStamp-import Utility.QuickCheck++import Data.ByteString.Builder import qualified Data.Attoparsec.ByteString.Lazy as A --- | Some very old logs did not have any time stamp at all;--- Unknown is used for those.-data VectorClock = Unknown | VectorClock POSIXTime-	deriving (Eq, Ord, Show)+currentVectorClock :: Annex VectorClock+currentVectorClock = liftIO =<< Annex.getState Annex.getvectorclock --- Unknown is oldest.-prop_VectorClock_sane :: Bool-prop_VectorClock_sane = Unknown < VectorClock 1+-- Runs the action and uses the same vector clock throughout.+--+-- When the action modifies several files in the git-annex branch,+-- this can cause less space to be used, since the same vector clock+-- value is used, which can compress better.+--+-- However, this should not be used when running a long-duration action,+-- because the vector clock is based on the start of the action, and not on +-- the later points where it writes changes. For example, if this were+-- used across downloads of several files, the location log information+-- would have an earlier vector clock than necessary, which might cause it+-- to be disregarded in favor of other information that was collected+-- at an earlier point in time than when the transfers completted and the+-- log was written.+reuseVectorClockWhile :: Annex a -> Annex a+reuseVectorClockWhile = bracket setup cleanup . const+  where+	setup = do+		origget <- Annex.getState Annex.getvectorclock+		vc <- liftIO origget+		use (pure vc)+		return origget -instance Arbitrary  VectorClock where-	arbitrary = VectorClock <$> arbitrary+	cleanup origget = use origget -currentVectorClock :: IO VectorClock-currentVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK"-  where-	go Nothing = VectorClock <$> getPOSIXTime-	go (Just s) = case parsePOSIXTime s of-		Just t -> return (VectorClock t)-		Nothing -> VectorClock <$> getPOSIXTime+	use vc = Annex.changeState $ \s ->+		s { Annex.getvectorclock = vc }  formatVectorClock :: VectorClock -> String formatVectorClock Unknown = "0"
+ Annex/VectorClock/Utility.hs view
@@ -0,0 +1,23 @@+{- git-annex vector clock utilities+ -+ - Copyright 2017-2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.VectorClock.Utility where++import Data.Time.Clock.POSIX++import Types.VectorClock+import Utility.Env+import Utility.TimeStamp++startVectorClock :: IO (IO VectorClock)+startVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK"+  where+	go Nothing = timebased+	go (Just s) = case parsePOSIXTime s of+		Just t -> return (pure (VectorClock t))+		Nothing -> timebased+	timebased = return (VectorClock <$> getPOSIXTime)
Annex/View.hs view
@@ -163,11 +163,11 @@ combineViewFilter (FilterValues _) newglob@(FilterGlob _) = 	(newglob, Widening) combineViewFilter (FilterGlob oldglob) new@(FilterValues s)-	| all (matchGlob (compileGlob oldglob CaseInsensative) . decodeBS . fromMetaValue) (S.toList s) = (new, Narrowing)+	| all (matchGlob (compileGlob oldglob CaseInsensative (GlobFilePath False)) . decodeBS . fromMetaValue) (S.toList s) = (new, Narrowing) 	| otherwise = (new, Widening) combineViewFilter (FilterGlob old) newglob@(FilterGlob new) 	| old == new = (newglob, Unchanged)-	| matchGlob (compileGlob old CaseInsensative) new = (newglob, Narrowing)+	| matchGlob (compileGlob old CaseInsensative (GlobFilePath False)) new = (newglob, Narrowing) 	| otherwise = (newglob, Widening) combineViewFilter (FilterGlob _) new@(ExcludeValues _) = (new, Narrowing) combineViewFilter (ExcludeValues _) new@(FilterGlob _) = (new, Widening)@@ -216,7 +216,7 @@ 		FilterValues s -> \values -> setmatches $ 			S.intersection s values 		FilterGlob glob ->-			let cglob = compileGlob glob CaseInsensative+			let cglob = compileGlob glob CaseInsensative (GlobFilePath False) 			in \values -> setmatches $ 				S.filter (matchGlob cglob . decodeBS . fromMetaValue) values 		ExcludeValues excludes -> \values ->
Assistant/DaemonStatus.hs view
@@ -56,7 +56,9 @@ 	let syncable = filter good rs 	contentremotes <- filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) $ 		filter (\r -> Remote.uuid r /= NoUUID) syncable-	let (exportremotes, dataremotes) = partition (exportTree . Remote.config) contentremotes+	let (exportremotes, nonexportremotes) = partition (exportTree . Remote.config) contentremotes+	let isimport r = importTree (Remote.config r) || Remote.thirdPartyPopulated (Remote.remotetype r)+	let dataremotes = filter (not . isimport) nonexportremotes  	return $ \dstatus -> dstatus 		{ syncRemotes = syncable
Assistant/Monad.hs view
@@ -35,7 +35,6 @@ import Assistant.Types.ScanRemotes import Assistant.Types.TransferQueue import Assistant.Types.TransferSlots-import Assistant.Types.TransferrerPool import Assistant.Types.Pushes import Assistant.Types.BranchChange import Assistant.Types.Commits@@ -65,7 +64,6 @@ 	, scanRemoteMap :: ScanRemoteMap 	, transferQueue :: TransferQueue 	, transferSlots :: TransferSlots-	, transferrerPool :: TransferrerPool 	, failedPushMap :: FailedPushMap 	, failedExportMap :: FailedPushMap 	, commitChan :: CommitChan@@ -85,7 +83,6 @@ 	<*> newScanRemoteMap 	<*> newTransferQueue 	<*> newTransferSlots-	<*> newTransferrerPool (checkNetworkConnections dstatus) 	<*> newFailedPushMap 	<*> newFailedPushMap 	<*> newCommitChan
Assistant/Threads/Transferrer.hs view
@@ -11,15 +11,15 @@ import Assistant.TransferQueue import Assistant.TransferSlots import Types.Transfer-import Annex.Path+import Annex.TransferrerPool import Utility.Batch  {- Dispatches transfers from the queue. -} transfererThread :: NamedThread transfererThread = namedThread "Transferrer" $ do-	program <- liftIO programPath-	batchmaker <- liftIO getBatchCommandMaker-	forever $ inTransferSlot program batchmaker $+	rt <- liftAnnex . mkRunTransferrer+		=<< liftIO getBatchCommandMaker+	forever $ inTransferSlot rt $ 		maybe (return Nothing) (uncurry genTransfer) 			=<< getNextTransfer notrunning   where
Assistant/TransferSlots.hs view
@@ -1,6 +1,6 @@ {- git-annex assistant transfer slots  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -9,30 +9,35 @@  module Assistant.TransferSlots where +import Control.Concurrent.STM+ import Assistant.Common import Utility.ThreadScheduler+import Utility.NotificationBroadcaster import Assistant.Types.TransferSlots import Assistant.DaemonStatus-import Assistant.TransferrerPool-import Assistant.Types.TransferrerPool+import Annex.TransferrerPool+import Types.TransferrerPool import Assistant.Types.TransferQueue import Assistant.TransferQueue import Assistant.Alert import Assistant.Alert.Utility import Assistant.Commits import Assistant.Drop+import Annex.Transfer (stallDetection) import Types.Transfer import Logs.Transfer import Logs.Location import qualified Git+import qualified Annex import qualified Remote import qualified Types.Remote as Remote import Annex.Content import Annex.Wanted-import Annex.Path import Utility.Batch import Types.NumCopies +import Data.Either import qualified Data.Map as M  import qualified Control.Exception as E import Control.Concurrent@@ -49,17 +54,17 @@ {- Waits until a transfer slot becomes available, then runs a  - TransferGenerator, and then runs the transfer action in its own thread.   -}-inTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant ()-inTransferSlot program batchmaker gen = do+inTransferSlot :: RunTransferrer -> TransferGenerator -> Assistant ()+inTransferSlot rt gen = do 	flip MSemN.wait 1 <<~ transferSlots-	runTransferThread program batchmaker =<< gen+	runTransferThread rt =<< gen  {- Runs a TransferGenerator, and its transfer action,  - without waiting for a slot to become available. -}-inImmediateTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant ()-inImmediateTransferSlot program batchmaker gen = do+inImmediateTransferSlot :: RunTransferrer -> TransferGenerator -> Assistant ()+inImmediateTransferSlot rt gen = do 	flip MSemN.signal (-1) <<~ transferSlots-	runTransferThread program batchmaker =<< gen+	runTransferThread rt =<< gen  {- Runs a transfer action, in an already allocated transfer slot.  - Once it finishes, frees the transfer slot.@@ -71,20 +76,25 @@  - then pausing the thread until a ResumeTransfer exception is raised,  - then rerunning the action.  -}-runTransferThread :: FilePath -> BatchCommandMaker -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant ()-runTransferThread _ _ Nothing = flip MSemN.signal 1 <<~ transferSlots-runTransferThread program batchmaker (Just (t, info, a)) = do+runTransferThread :: RunTransferrer -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant ()+runTransferThread _ Nothing = flip MSemN.signal 1 <<~ transferSlots+runTransferThread rt (Just (t, info, a)) = do 	d <- getAssistant id+	mkcheck <- checkNetworkConnections +		<$> getAssistant daemonStatusHandle 	aio <- asIO1 a-	tid <- liftIO $ forkIO $ runTransferThread' program batchmaker d aio+	tid <- liftIO $ forkIO $ runTransferThread' mkcheck rt d aio 	updateTransferInfo t $ info { transferTid = Just tid } -runTransferThread' :: FilePath -> BatchCommandMaker -> AssistantData -> (Transferrer -> IO ()) -> IO ()-runTransferThread' program batchmaker d run = go+runTransferThread' :: MkCheckTransferrer -> RunTransferrer -> AssistantData -> (Transferrer -> IO ()) -> IO ()+runTransferThread' mkcheck rt d run = go   where-	go = catchPauseResume $-		withTransferrer program batchmaker (transferrerPool d)-			run+	go = catchPauseResume $ do+		p <- runAssistant d $ liftAnnex $ +			Annex.getState Annex.transferrerpool+		signalactonsvar <- runAssistant d $ liftAnnex $+			Annex.getState Annex.signalactions+		withTransferrer' True signalactonsvar mkcheck rt p run 	pause = catchPauseResume $ 		runEvery (Seconds 86400) noop 	{- Note: This must use E.try, rather than E.catch.@@ -116,7 +126,8 @@ 			( do 				debug [ "Transferring:" , describeTransfer t info ] 				notifyTransfer-				return $ Just (t, info, go remote)+				sd <- liftAnnex $ stallDetection remote+				return $ Just (t, info, go remote sd) 			, do 				debug [ "Skipping unnecessary transfer:", 					describeTransfer t info ]@@ -155,7 +166,7 @@ 	 - usual cleanup. However, first check if something else is 	 - running the transfer, to avoid removing active transfers. 	 -}-	go remote transferrer = ifM (liftIO $ performTransfer transferrer t info)+	go remote sd transferrer = ifM (isRight <$> performTransfer sd AssistantLevel liftAnnex (transferRemote info) t info transferrer) 		( do 			case associatedFile info of 				AssociatedFile Nothing -> noop@@ -291,10 +302,16 @@ 		alterTransferInfo t $ \i -> i { transferPaused = False } 		liftIO $ throwTo tid ResumeTransfer 	start info = do-		program <- liftIO programPath-		batchmaker <- liftIO getBatchCommandMaker-		inImmediateTransferSlot program batchmaker $+		rt <- liftAnnex . mkRunTransferrer+			=<< liftIO getBatchCommandMaker+		inImmediateTransferSlot rt $ 			genTransfer t info  getCurrentTransfers :: Assistant TransferMap getCurrentTransfers = currentTransfers <$> getDaemonStatus++checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer+checkNetworkConnections dstatushandle = do+	dstatus <- atomically $ readTVar dstatushandle+	h <- newNotificationHandle False (networkConnectedNotifier dstatus)+	return $ not <$> checkNotification h
− Assistant/TransferrerPool.hs 
@@ -1,94 +0,0 @@-{- A pool of "git-annex transferkeys" processes- -- - Copyright 2013 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--module Assistant.TransferrerPool where--import Assistant.Common-import Assistant.Types.TransferrerPool-import Types.Transfer-import Utility.Batch--import qualified Command.TransferKeys as T--import Control.Concurrent.STM hiding (check)-import Control.Exception (throw)-import Control.Concurrent--{- Runs an action with a Transferrer from the pool.- -- - Only one Transferrer is left running in the pool at a time.- - So if this needed to start a new Transferrer, it's stopped when done.- -}-withTransferrer :: FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a-withTransferrer program batchmaker pool a = do-	(mi, leftinpool) <- atomically (popTransferrerPool pool)-	i@(TransferrerPoolItem (Just t) check) <- case mi of-		Nothing -> mkTransferrerPoolItem pool =<< mkTransferrer program batchmaker-		Just i -> checkTransferrerPoolItem program batchmaker i-	v <- tryNonAsync $ a t-	if leftinpool == 0-		then atomically $ pushTransferrerPool pool i-		else do-			void $ forkIO $ stopTransferrer t-			atomically $ pushTransferrerPool pool $ TransferrerPoolItem Nothing check-	either throw return v--{- Check if a Transferrer from the pool is still ok to be used.- - If not, stop it and start a new one. -}-checkTransferrerPoolItem :: FilePath -> BatchCommandMaker -> TransferrerPoolItem -> IO TransferrerPoolItem-checkTransferrerPoolItem program batchmaker i = case i of-	TransferrerPoolItem (Just t) check -> ifM check-		( return i-		, do-			stopTransferrer t-			new check-		)-	TransferrerPoolItem Nothing check -> new check-  where-	new check = do-		t <- mkTransferrer program batchmaker-		return $ TransferrerPoolItem (Just t) check--{- Requests that a Transferrer perform a Transfer, and waits for it to- - finish. -}-performTransfer :: Transferrer -> Transfer -> TransferInfo -> IO Bool-performTransfer transferrer t info = catchBoolIO $ do-	T.sendRequest t info (transferrerWrite transferrer)-	T.readResponse (transferrerRead transferrer)--{- Starts a new git-annex transferkeys process, setting up handles- - that will be used to communicate with it. -}-mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer-mkTransferrer program batchmaker = do-	{- It runs as a batch job. -}-	let (program', params') = batchmaker (program, [Param "transferkeys"])-	{- It's put into its own group so that the whole group can be-	 - killed to stop a transfer. -}-	(Just writeh, Just readh, _, pid) <- createProcess-		(proc program' $ toCommand params')-		{ create_group = True-		, std_in = CreatePipe-		, std_out = CreatePipe-		}-	return $ Transferrer-		{ transferrerRead = readh-		, transferrerWrite = writeh-		, transferrerHandle = pid-		}--{- Checks if a Transferrer is still running. If not, makes a new one. -}-checkTransferrer :: FilePath -> BatchCommandMaker -> Transferrer -> IO Transferrer-checkTransferrer program batchmaker t =-	maybe (return t) (const $ mkTransferrer program batchmaker)-		=<< getProcessExitCode (transferrerHandle t)--{- Closing the fds will stop the transferrer. -}-stopTransferrer :: Transferrer -> IO ()-stopTransferrer t = do-	hClose $ transferrerRead t-	hClose $ transferrerWrite t-	void $ waitForProcess $ transferrerHandle t
− Assistant/Types/TransferrerPool.hs 
@@ -1,64 +0,0 @@-{- A pool of "git-annex transferkeys" processes available for use- -- - Copyright 2013 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--module Assistant.Types.TransferrerPool where--import Annex.Common-import Utility.NotificationBroadcaster-import Assistant.Types.DaemonStatus--import Control.Concurrent.STM hiding (check)--type TransferrerPool = TVar (MkCheckTransferrer, [TransferrerPoolItem])--type CheckTransferrer = IO Bool-type MkCheckTransferrer = IO (IO Bool)--{- Each item in the pool may have a transferrer running, and has an- - IO action that can be used to check if it's still ok to use the- - transferrer. -}-data TransferrerPoolItem = TransferrerPoolItem (Maybe Transferrer) CheckTransferrer--data Transferrer = Transferrer-	{ transferrerRead :: Handle-	, transferrerWrite :: Handle-	, transferrerHandle :: ProcessHandle-	}--newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool-newTransferrerPool c = newTVarIO (c, [])--popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int)-popTransferrerPool p = do-	(c, l) <- readTVar p-	case l of-		[] -> return (Nothing, 0)-		(i:is) -> do-			writeTVar p (c, is)-			return $ (Just i, length is)--pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM ()-pushTransferrerPool p i = do-	(c, l) <- readTVar p-	let l' = i:l-	writeTVar p (c, l')--{- Note that making a CheckTransferrer may allocate resources,- - such as a NotificationHandle, so it's important that the returned- - TransferrerPoolItem is pushed into the pool, and not left to be- - garbage collected. -}-mkTransferrerPoolItem :: TransferrerPool -> Transferrer -> IO TransferrerPoolItem-mkTransferrerPoolItem p t = do-	mkcheck <- atomically $ fst <$> readTVar p-	check <- mkcheck-	return $ TransferrerPoolItem (Just t) check--checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer-checkNetworkConnections dstatushandle = do-	dstatus <- atomically $ readTVar dstatushandle-	h <- newNotificationHandle False (networkConnectedNotifier dstatus)-	return $ not <$> checkNotification h
CHANGELOG view
@@ -1,3 +1,45 @@+git-annex (8.20201129) upstream; urgency=medium++  * New borg special remote. This is a new kind of remote, that examines+    borg backups of git-annex repositories, learns what files have been+    backed up, and can restore files from the backup and so on. As well+    as backups, it can be useful for archival storage, since borg can+    efficiently store many related versions of files.+  * New config annex.stalldetection, remote.name.annex-stalldetection,+    which can be used to deal with remotes that stall during transfers,+    or are sometimes too slow to want to use.+  * Support special remotes that are configured with importtree=yes but+    without exporttree=yes.+  * Fix bug that made the next download after an empty file from a ssh+    or tor remote fail.+  * Avoid spurious "verification of content failed" message when downloading+    content from a ssh or tor remote fails due to the remote no longer+    having a copy of the content.+  * Fix bug that matched include= and exclude= in preferred/required content+    expressions relative to the current directory, rather than the path+    from the top of the repository.+    (Reversion introduced in version 8.20201116.)+  * Fix hang on shutdown of external special remote using ASYNC protocol+    extension. +    (Reversion introduced in version 8.20201007.)+  * Guard against running in a repo where annex.uuid is set but+    annex.version is not set, or vice-versa.+  * Avoid autoinit when a repo does not have annex.version or annex.uuid+    set, but has a git-annex objects directory, suggesting it was used+    by git-annex before, and the git config may have been lost.+  * importfeed: Avoid using youtube-dl when a feed does not contain an+    enclosure, but only a link to an url which youtube-dl does not support.+  * initremote: Prevent enabling encryption with exporttree=yes or +    importtree=yes.+  * Windows: include= and exclude= containing '/' will also match filenames+    that are written using '\'. (And vice-versa, but it's better to use '/'+    for portability.)+  * Fix a bug that could prevent getting files from an importtree=yes+    remote, because the imported tree was allowed to be garbage collected.+  * stack.yaml: Updated to lts-16.27.++ -- Joey Hess <id@joeyh.name>  Tue, 29 Dec 2020 12:52:58 -0400+ git-annex (8.20201127) upstream; urgency=medium    * adjust: New --unlock-present mode which locks files whose content is not
CmdLine/Batch.hs view
@@ -131,7 +131,7 @@ 	matcher <- getMatcher 	go $ \si f -> 		let f' = toRawFilePath f-		in ifM (matcher $ MatchingFile $ FileInfo (Just f') f')+		in ifM (matcher $ MatchingFile $ FileInfo (Just f') f' Nothing) 			( a (si, f') 			, return Nothing 			)
CmdLine/GitAnnex.hs view
@@ -35,6 +35,7 @@ import qualified Command.RegisterUrl import qualified Command.SetKey import qualified Command.DropKey+import qualified Command.Transferrer import qualified Command.TransferKey import qualified Command.TransferKeys import qualified Command.SetPresentKey@@ -177,6 +178,7 @@ 	, Command.RegisterUrl.cmd 	, Command.SetKey.cmd 	, Command.DropKey.cmd+	, Command.Transferrer.cmd 	, Command.TransferKey.cmd 	, Command.TransferKeys.cmd 	, Command.SetPresentKey.cmd
CmdLine/Seek.hs view
@@ -115,6 +115,7 @@ 	checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo 		{ contentFile = Just f 		, matchFile = relf+		, matchKey = Nothing 		}  withWords :: ([String] -> CommandSeek) -> CmdParams -> CommandSeek@@ -287,7 +288,7 @@   where 	process matcher v@(_si, f) = 		whenM (prefilter v) $-			whenM (matcher $ MatchingFile $ FileInfo (Just f) f) $+			whenM (matcher $ MatchingFile $ FileInfo (Just f) f Nothing) $ 				a v  data MatcherInfo = MatcherInfo@@ -345,7 +346,7 @@ 			maybe noop (Annex.BranchState.setCache logf) logcontent 			checkMatcherWhen mi 				(matcherNeedsLocationLog mi && not (matcherNeedsFileName mi))-				(MatchingKey k (AssociatedFile (Just f)))+				(MatchingFile $ FileInfo (Just f) f (Just k)) 				(commandAction $ startAction seeker si f k) 			precachefinisher mi lreader 		Nothing -> return ()@@ -365,14 +366,14 @@ 		-- checked later, to avoid a slow lookup here. 		(not ((matcherNeedsKey mi || matcherNeedsLocationLog mi)  			&& not (matcherNeedsFileName mi)))-		(MatchingFile $ FileInfo (Just f) f)+		(MatchingFile $ FileInfo (Just f) f Nothing) 		(liftIO $ ofeeder ((si, f), sha))  	keyaction f mi content a =  		case parseLinkTargetOrPointerLazy =<< content of 			Just k -> checkMatcherWhen mi 				(matcherNeedsKey mi && not (matcherNeedsFileName mi || matcherNeedsLocationLog mi))-				(MatchingKey k (AssociatedFile (Just f)))+				(MatchingFile $ FileInfo (Just f) f (Just k)) 				(checkpresence k (a k)) 			Nothing -> noop
CmdLine/Usage.hs view
@@ -16,7 +16,7 @@ usage :: String -> [Command] -> String usage header cmds = unlines $ usageMessage header : commandList cmds -{- Commands listed by section, with breif usage and description. -}+{- Commands listed by section, with brief usage and description. -} commandList :: [Command] -> [String] commandList cmds = concatMap go [minBound..]   where
Command/Add.hs view
@@ -184,7 +184,7 @@ perform :: AddOptions -> RawFilePath -> AddUnlockedMatcher -> CommandPerform perform o file addunlockedmatcher = withOtherTmp $ \tmpdir -> do 	lockingfile <- not <$> addUnlocked addunlockedmatcher-		(MatchingFile (FileInfo (Just file) file))+		(MatchingFile (FileInfo (Just file) file Nothing)) 	let cfg = LockDownConfig 		{ lockingFile = lockingfile 		, hardlinkFileTmpDir = Just tmpdir
Command/AddUrl.hs view
@@ -332,7 +332,7 @@ 			let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink) 			showNote "using youtube-dl" 			Transfer.notifyTransfer Transfer.Download url $-				Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p ->+				Transfer.download' webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p -> 					youtubeDl url (fromRawFilePath workdir) p >>= \case 						Right (Just mediafile) -> do 							cleanuptmp@@ -396,7 +396,7 @@ 	checkDiskSpaceToGet dummykey Nothing $ do 		tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey 		ok <- Transfer.notifyTransfer Transfer.Download url $-			Transfer.download u dummykey afile Transfer.stdRetry $ \p -> do+			Transfer.download' u dummykey afile Transfer.stdRetry $ \p -> do 				createAnnexDirectory (parentDir tmp) 				downloader (fromRawFilePath tmp) p 		if ok
Command/Export.hs view
@@ -46,7 +46,7 @@ cmd :: Command cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption] $ 	command "export" SectionCommon-		"export content to a remote"+		"export a tree of files to a special remote" 		paramTreeish (seek <$$> optParser)  data ExportOptions = ExportOptions@@ -192,7 +192,7 @@ 	-- from a previous export, that are not part of this export. 	c <- Annex.getState Annex.errcounter 	when (c == 0) $ do-		recordExport (uuid r) $ ExportChange+		recordExportUnderway (uuid r) $ ExportChange 			{ oldTreeish = exportedTreeishes old 			, newTreeish = new 			}@@ -283,7 +283,7 @@ 	sent <- tryNonAsync $ case ek of 		AnnexKey k -> ifM (inAnnex k) 			( notifyTransfer Upload af $-				upload (uuid r) k af stdRetry $ \pm -> do+				upload' (uuid r) k af stdRetry $ \pm -> do 					let rollback = void $ 						performUnexport r db [ek] loc 					sendAnnex k rollback $ \f ->@@ -362,10 +362,10 @@ 			removeExportedLocation db (asKey ek) loc 		flushDbQueue db -	-- An appendonly remote can support removeExportLocation to remove-	-- the file from the exported tree, but still retain the content-	-- and allow retrieving it.-	unless (appendonly r) $ do+	-- An versionedExport remote supports removeExportLocation to remove+	-- the file from the exported tree, but still retains the content+	-- and allows retrieving it.+	unless (versionedExport (exportActions r)) $ do 		remaininglocs <- liftIO $  			concat <$> forM eks (\ek -> getExportedLocation db (asKey ek)) 		when (null remaininglocs) $
Command/Forget.hs view
@@ -35,7 +35,7 @@  start :: ForgetOptions -> CommandStart start o = starting "forget" ai si $ do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	let basets = addTransition c ForgetGitHistory noTransitions 	let ts = if dropDead o 		then addTransition c ForgetDeadRemotes basets
Command/Fsck.hs view
@@ -662,7 +662,7 @@ openFsckDb :: UUID -> Annex FsckDb.FsckHandle openFsckDb u = do 	h <- FsckDb.openDb u-	Annex.addCleanup FsckCleanup $+	Annex.addCleanupAction FsckCleanup $ 		FsckDb.closeDb h 	return h
Command/Get.hs view
@@ -9,7 +9,6 @@  import Command import qualified Remote-import Annex.Content import Annex.Transfer import Annex.NumCopies import Annex.Wanted@@ -114,10 +113,6 @@ 		| Remote.hasKeyCheap r = 			either (const False) id <$> Remote.hasKey r key 		| otherwise = return True-	docopy r witness = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key afile $ \dest ->-		download (Remote.uuid r) key afile stdRetry-			(\p -> do-				showAction $ "from " ++ Remote.name r-				Remote.verifiedAction $-					Remote.retrieveKeyFile r key afile (fromRawFilePath dest) p-			) witness+	docopy r witness = do+		showAction $ "from " ++ Remote.name r+		download r key afile stdRetry witness
Command/Import.hs view
@@ -241,6 +241,7 @@ 		let mi = MatchingFile $ FileInfo 			{ contentFile = Just srcfile 			, matchFile = destfile+			, matchKey = Nothing 			} 		lockingfile <- not <$> addUnlocked addunlockedmatcher mi 		-- Minimal lock down with no hard linking so nothing@@ -305,7 +306,7 @@ 	void $ includeCommandAction (listContents remote importtreeconfig ci importabletvar) 	liftIO (atomically (readTVar importabletvar)) >>= \case 		Nothing -> return ()-		Just importable -> importKeys remote importtreeconfig importcontent importable >>= \case+		Just importable -> importKeys remote importtreeconfig importcontent False importable >>= \case 			Nothing -> warning $ concat 				[ "Failed to import some files from " 				, Remote.name remote@@ -323,21 +324,25 @@  listContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart listContents remote importtreeconfig ci tvar = starting "list" ai si $+	listContents' remote importtreeconfig ci $ \importable -> do+		liftIO $ atomically $ writeTVar tvar importable+		next $ return True+  where+	ai = ActionItemOther (Just (Remote.name remote))+	si = SeekInput []++listContents' :: Remote -> ImportTreeConfig -> CheckGitIgnore -> (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize)) -> Annex a) -> Annex a+listContents' remote importtreeconfig ci a =  	makeImportMatcher remote >>= \case-		Right matcher -> getImportableContents remote importtreeconfig ci matcher >>= \case-			Just importable -> next $ do-				liftIO $ atomically $ writeTVar tvar (Just importable)-				return True-			Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote+		Right matcher -> tryNonAsync (getImportableContents remote importtreeconfig ci matcher) >>= \case+			Right importable -> a importable+			Left e -> giveup $ "Unable to list contents of " ++ Remote.name remote ++ ": " ++ show e 		Left err -> giveup $ unwords  			[ "Cannot import from" 			, Remote.name remote 			, "because of a problem with its configuration:" 			, err 			]-  where-	ai = ActionItemOther (Just (Remote.name remote))-	si = SeekInput []  commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents (Either Sha Key) -> CommandStart commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable =
Command/ImportFeed.hs view
@@ -308,27 +308,30 @@ 	 	downloadmedia linkurl mediaurl mediakey 		| rawOption (downloadOptions opts) = downloadlink-		| otherwise = do-			r <- withTmpWorkDir mediakey $ \workdir -> do-				dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate-				case dl of-					Right (Just mediafile) -> do-						let ext = case takeExtension mediafile of-							[] -> ".m"-							s -> s-						ok <- rundownload linkurl ext $ \f ->-							checkCanAdd (downloadOptions opts) f $ \canadd -> do-								addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just (toRawFilePath mediafile))-								return (Just [mediakey])-						return (Just ok)-					-- youtude-dl didn't support it, so-					-- download it as if the link were-					-- an enclosure.-					Right Nothing -> Just <$> downloadlink-					Left msg -> do-						warning msg-						return Nothing-			return (fromMaybe False r)+		| otherwise = ifM (youtubeDlSupported linkurl)+			( do+				r <- withTmpWorkDir mediakey $ \workdir -> do+					dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate+					case dl of+						Right (Just mediafile) -> do+							let ext = case takeExtension mediafile of+								[] -> ".m"+								s -> s+							ok <- rundownload linkurl ext $ \f ->+								checkCanAdd (downloadOptions opts) f $ \canadd -> do+									addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just (toRawFilePath mediafile))+									return (Just [mediakey])+							return (Just ok)+						-- youtube-dl didn't support it, so+						-- download it as if the link were+						-- an enclosure.+						Right Nothing -> Just <$> downloadlink+						Left msg -> do+							warning $ linkurl ++ ": " ++ msg+							return Nothing+				return (fromMaybe False r)+			, downloadlink+			) 	  where 		downloadlink = performDownload addunlockedmatcher opts cache todownload 			{ location = Enclosure linkurl }
Command/Info.hs view
@@ -569,7 +569,7 @@   where 	initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty) 	update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) =-		ifM (matcher $ MatchingFile $ FileInfo (Just file) file)+		ifM (matcher $ MatchingFile $ FileInfo (Just file) file (Just key)) 			( do 				!presentdata' <- ifM (inAnnex key) 					( return $ addKey key presentdata
Command/MetaData.hs view
@@ -74,7 +74,7 @@ seek :: MetaDataOptions -> CommandSeek seek o = case batchOption o of 	NoBatch -> do-		c <- liftIO currentVectorClock+		c <- currentVectorClock 		let ww = WarnUnmatchLsFiles 		let seeker = AnnexedFileSeeker 			{ startAction = start c o@@ -188,7 +188,7 @@ 			, keyOptions = Nothing 			, batchOption = NoBatch 			}-		t <- liftIO currentVectorClock+		t <- currentVectorClock 		-- It would be bad if two batch mode changes used exactly 		-- the same timestamp, since the order of adds and removals 		-- of the same metadata value would then be indeterminate.
Command/Move.hs view
@@ -142,8 +142,7 @@ 		Right False -> logMove srcuuid destuuid False key $ \deststartedwithcopy -> do 			showAction $ "to " ++ Remote.name dest 			ok <- notifyTransfer Upload afile $-				upload (Remote.uuid dest) key afile stdRetry $-					Remote.action . Remote.storeKey dest key afile+				upload dest key afile stdRetry 			if ok 				then finish deststartedwithcopy $ 					Remote.logStatus dest key InfoPresent@@ -208,10 +207,22 @@ 			fromPerform src removewhen key afile  fromOk :: Remote -> Key -> Annex Bool-fromOk src key = do-	u <- getUUID-	remotes <- Remote.keyPossibilities key-	return $ u /= Remote.uuid src && elem src remotes+fromOk src key+	-- check if the remote contains the key, when it can be done cheaply+	| Remote.hasKeyCheap src = +		Remote.hasKey src key >>= \case+			Right True -> return True+			-- Don't skip getting the key just because the+			-- remote no longer contains it if the log+			-- says the remote is supposed to contain it;+			-- that would be surprising behavior.+			_ -> checklog+	| otherwise = checklog+  where+	checklog = do+		u <- getUUID+		remotes <- Remote.keyPossibilities key+		return $ u /= Remote.uuid src && elem src remotes  fromPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform fromPerform src removewhen key afile = do@@ -223,10 +234,8 @@ 			then dispatch removewhen deststartedwithcopy True 			else dispatch removewhen deststartedwithcopy =<< get   where-	get = notifyTransfer Download afile $ -		download (Remote.uuid src) key afile stdRetry $ \p ->-			getViaTmp (Remote.retrievalSecurityPolicy src) (RemoteVerify src) key afile $ \t ->-				Remote.verifiedAction $ Remote.retrieveKeyFile src key afile (fromRawFilePath t) p+	get = notifyTransfer Download afile $+		download src key afile stdRetry 	 	dispatch _ _ False = stop -- failed 	dispatch RemoveNever _ True = next $ return True -- copy complete
Command/Multicast.hs view
@@ -16,6 +16,7 @@ import Annex.Content import Annex.UUID import Annex.Perms+import Logs.Location import Utility.FileMode #ifndef mingw32_HOST_OS import Creds@@ -134,7 +135,7 @@ 			(fs', cleanup) <- seekHelper id ww LsFiles.inRepo 				=<< workTreeItems ww fs 			matcher <- Limit.getMatcher-			let addlist f o = whenM (matcher $ MatchingFile $ FileInfo (Just f) f) $+			let addlist f o = whenM (matcher $ MatchingFile $ FileInfo (Just f) f Nothing) $ 				liftIO $ hPutStrLn h o 			forM_ fs' $ \(_, f) -> do 				mk <- lookupKey f@@ -212,7 +213,7 @@ 		Nothing -> do 			warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file." 			liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)-		Just k -> void $+		Just k -> void $ logStatusAfter k $ 			getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $ 				liftIO $ catchBoolIO $ do 					rename f (fromRawFilePath dest)
Command/RecvKey.hs view
@@ -13,6 +13,7 @@ import Annex import Utility.Rsync import Types.Transfer+import Logs.Location import Command.SendKey (fieldTransfer) import qualified CmdLine.GitAnnexShell.Fields as Fields @@ -35,6 +36,7 @@ 	let rsp = RetrievalAllKeysSecure 	ifM (getViaTmp rsp verify key (AssociatedFile Nothing) go) 		( do+			logStatus key InfoPresent 			-- forcibly quit after receiving one key, 			-- and shutdown cleanly 			_ <- shutdown True
Command/Sync.hs view
@@ -67,7 +67,7 @@ import Annex.Export import Annex.TaggedPush import Annex.CurrentBranch-import Annex.Import (canImportKeys)+import Annex.Import import Annex.CheckIgnore import Types.FileMatcher import qualified Database.Export as Export@@ -207,11 +207,11 @@ 	let withbranch a = a =<< getCurrentBranch  	remotes <- syncRemotes (syncWith o)+	-- Remotes that are git repositories, not special remotes. 	let gitremotes = filter (Remote.gitSyncableRemoteType . Remote.remotetype) remotes-	dataremotes <- filter (\r -> Remote.uuid r /= NoUUID)+	-- Remotes that contain annex object content.+	contentremotes <- filter (\r -> Remote.uuid r /= NoUUID) 		<$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes-	let (exportremotes, keyvalueremotes) = partition (exportTree . Remote.config) dataremotes-	let importremotes = filter (importTree . Remote.config) dataremotes  	if cleanupOption o 		then do@@ -231,17 +231,27 @@ 			 			content <- shouldSyncContent o -			forM_ importremotes $+			forM_ (filter isImport contentremotes) $ 				withbranch . importRemote content o mergeConfig+			forM_ (filter isThirdPartyPopulated contentremotes) $+				pullThirdPartyPopulated o 			 			when content $ do 				-- Send content to any exports before other 				-- repositories, in case that lets content 				-- be dropped from other repositories. 				exportedcontent <- withbranch $-					seekExportContent (Just o) exportremotes+					seekExportContent (Just o)+						(filter isExport contentremotes)++				-- Sync content with remotes, but not with+				-- export or import remotes, which handle content+				-- syncing as part of export and import. 				syncedcontent <- withbranch $-					seekSyncContent o keyvalueremotes+					seekSyncContent o $ filter+						(\r -> not (isExport r || isImport r))+						contentremotes+ 				-- Transferring content can take a while, 				-- and other changes can be pushed to the 				-- git-annex branch on the remotes in the@@ -479,6 +489,33 @@   where 	wantpull = remoteAnnexPull (Remote.gitconfig remote) +{- Handle a remote that is populated by a third party, by listing+ - the contents of the remote, and then adding only the files on it that+ - importKey identifies to a tree. The tree is only used to keep track+ - of where keys are located on the remote, no remote tracking branch is+ - updated, because the filenames are the names of annex object files,+ - not suitable for a tracking branch. Does not transfer any content. -}+pullThirdPartyPopulated :: SyncOptions -> Remote -> CommandSeek+pullThirdPartyPopulated o remote+	| not (pullOption o) || not wantpull = noop+	| not (canImportKeys remote False) = noop+	| otherwise = void $ includeCommandAction $ starting "list" ai si $+		Command.Import.listContents' remote ImportTree (CheckGitIgnore False) go+  where+	go (Just importable) = importKeys remote ImportTree False True importable >>= \case+		Just importablekeys -> do+			(_imported, updatestate) <- recordImportTree remote ImportTree importablekeys+			next $ do+				updatestate+				return True+		Nothing -> next $ return False+	go Nothing = next $ return True -- unchanged from before++	ai = ActionItemOther (Just (Remote.name remote))+	si = SeekInput []+	+	wantpull = remoteAnnexPull (Remote.gitconfig remote)+ {- The remote probably has both a master and a synced/master branch.  - Which to merge from? Well, the master has whatever latest changes  - were committed (or pushed changes, if this is a bare remote),@@ -535,7 +572,7 @@ 	postpushupdate repo = case Git.repoWorkTree repo of 		Nothing -> return True 		Just wt -> ifM needemulation-			( gitAnnexChildProcess ["post-receive"]+			( gitAnnexChildProcess "post-receive" [] 				(\cp -> cp { cwd = Just (fromRawFilePath wt) }) 				(\_ _ _ pid -> waitForProcess pid >>= return . \case 					ExitSuccess -> True@@ -778,6 +815,7 @@  	wantput r 		| Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False+		| isThirdPartyPopulated r = return False 		| otherwise = wantSend True (Just k) af (Remote.uuid r) 	handleput lack = catMaybes <$> ifM (inAnnex k) 		( forM lack $ \r ->@@ -890,3 +928,12 @@ 	| notOnlyAnnexOption o = pure False 	| onlyAnnexOption o = pure True 	| otherwise = getGitConfigVal annexSyncOnlyAnnex+	+isExport :: Remote -> Bool+isExport = exportTree . Remote.config++isImport :: Remote -> Bool+isImport = importTree . Remote.config++isThirdPartyPopulated :: Remote -> Bool+isThirdPartyPopulated = Remote.thirdPartyPopulated . Remote.remotetype
Command/TestRemote.hs view
@@ -294,7 +294,7 @@ 		Just b -> case Types.Backend.verifyKeyContent b of 			Nothing -> return True 			Just verifier -> verifier k (serializeKey' k)-	get r k = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest ->+	get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> 		tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case 			Right v -> return (True, v) 			Left _ -> return (False, UnVerified)@@ -368,13 +368,13 @@ 	, check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> 		Remote.checkPresent r k 	, check (== Right False) "retrieveKeyFile" $ \r k ->-		getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest ->+		logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> 			tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case 				Right v -> return (True, v) 				Left _ -> return (False, UnVerified) 	, check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of 		Nothing -> return False-		Just a -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> +		Just a -> logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest ->  			unVerified $ isRight 				<$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest)) 	]
Command/TransferKey.hs view
@@ -51,7 +51,7 @@  toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform toPerform key file remote = go Upload file $-	upload (uuid remote) key file stdRetry $ \p -> do+	upload' (uuid remote) key file stdRetry $ \p -> do 		tryNonAsync (Remote.storeKey remote key file p) >>= \case 			Right () -> do 				Remote.logStatus remote key InfoPresent@@ -62,8 +62,8 @@  fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key file remote = go Upload file $-	download (uuid remote) key file stdRetry $ \p ->-		getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t ->+	download' (uuid remote) key file stdRetry $ \p ->+		logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> 			tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case 				Right v -> return (True, v)	 				Left e -> do
Command/TransferKeys.hs view
@@ -1,4 +1,7 @@-{- git-annex command, used internally by assistant+{- git-annex command, used internally by assistant in version+ - 8.20201127 and older and provided only to avoid upgrade breakage.+ - Remove at some point when such old versions of git-annex are unlikely+ - to be running any longer.  -  - Copyright 2012, 2013 Joey Hess <id@joeyh.name>  -@@ -22,7 +25,7 @@ data TransferRequest = TransferRequest Direction Remote Key AssociatedFile  cmd :: Command-cmd = command "transferkeys" SectionPlumbing "transfers keys"+cmd = command "transferkeys" SectionPlumbing "transfers keys (deprecated)" 	paramNothing (withParams seek)  seek :: CmdParams -> CommandSeek@@ -37,7 +40,7 @@   where 	runner (TransferRequest direction remote key file) 		| direction == Upload = notifyTransfer direction file $-			upload (Remote.uuid remote) key file stdRetry $ \p -> do+			upload' (Remote.uuid remote) key file stdRetry $ \p -> do 				tryNonAsync (Remote.storeKey remote key file p) >>= \case 					Left e -> do 						warning (show e)@@ -46,8 +49,8 @@ 						Remote.logStatus remote key InfoPresent 						return True 		| otherwise = notifyTransfer direction file $-			download (Remote.uuid remote) key file stdRetry $ \p ->-				getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do+			download' (Remote.uuid remote) key file stdRetry $ \p ->+				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do 					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case 						Left e -> do 							warning (show e)
+ Command/Transferrer.hs view
@@ -0,0 +1,137 @@+{- git-annex command+ -+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Command.Transferrer where++import Command+import qualified Annex+import Annex.Content+import Logs.Location+import Annex.Transfer+import qualified Remote+import Utility.SimpleProtocol (dupIoHandles)+import qualified Database.Keys+import Annex.BranchState+import Types.Messages+import Annex.TransferrerPool+import Types.Transferrer+import qualified Utility.SimpleProtocol as Proto++cmd :: Command+cmd = noCommit $ command "transferrer" SectionPlumbing "transfers content"+	paramNothing (withParams seek)++seek :: CmdParams -> CommandSeek+seek = withNothing (commandAction start)++start :: CommandStart+start = do+	enableInteractiveBranchAccess+	(readh, writeh) <- liftIO dupIoHandles+	let outputwriter = sendTransferResponse writeh . TransferOutput+	let outputresponsereader = do+		l <- getNextLine readh+		return $ case Proto.parseMessage l of+			Just (TransferSerializedOutputResponse r) -> Just r+			Nothing -> Nothing+	Annex.setOutput $ SerializedOutput outputwriter outputresponsereader+	runRequests readh writeh runner+	stop+  where+	runner (UploadRequest _ key (TransferAssociatedFile file)) remote =+		-- This is called by eg, Annex.Transfer.upload,+		-- so caller is responsible for doing notification,+		-- and for retrying, and updating location log.+		upload' (Remote.uuid remote) key file noRetry+			(Remote.action . Remote.storeKey remote key file)+			noNotification+	runner (DownloadRequest _ key (TransferAssociatedFile file)) remote =+		-- This is called by eg, Annex.Transfer.download+		-- so caller is responsible for doing notification+		-- and for retrying, and updating location log.+		let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do+			Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p)+		in download' (Remote.uuid remote) key file noRetry go +			noNotification+	runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote =+		notifyTransfer Upload file $+			upload' (Remote.uuid remote) key file stdRetry $ \p -> do+				tryNonAsync (Remote.storeKey remote key file p) >>= \case+					Left e -> do+						warning (show e)+						return False+					Right () -> do+						Remote.logStatus remote key InfoPresent+						return True+	runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote =+		notifyTransfer Download file $+			download' (Remote.uuid remote) key file stdRetry $ \p ->+				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do+					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case+						Left e -> do+							warning (show e)+							return (False, UnVerified)+						Right v -> return (True, v)+					-- Make sure we get the current+					-- associated files data for the key,+					-- not old cached data.+					Database.Keys.closeDb			+					return r++runRequests+	:: Handle+	-> Handle+	-> (TransferRequest -> Remote -> Annex Bool)+	-> Annex ()+runRequests readh writeh a = go Nothing Nothing+  where+	go lastremoteoruuid lastremote = unlessM (liftIO $ hIsEOF readh) $ do+		l <- liftIO $ getNextLine readh+		case Proto.parseMessage l of+			Just tr -> do+				let remoteoruuid = transferRequestRemote tr+				-- Often the same remote will be used+				-- repeatedly, so cache the last one to+				-- avoid looking up repeatedly.+				mremote <- if lastremoteoruuid == Just remoteoruuid+					then pure lastremote+					else case remoteoruuid of+						TransferRemoteName n ->+							eitherToMaybe <$> Remote.byName' n+						TransferRemoteUUID u -> +							Remote.byUUID u+				case mremote of+					Just remote -> do+						sendresult =<< a tr remote+						go (Just remoteoruuid) mremote+					Nothing -> transferrerProtocolError l+			Nothing -> transferrerProtocolError l++	sendresult = liftIO . sendTransferResponse writeh . TransferResult++sendTransferResponse :: Handle -> TransferResponse -> IO ()+sendTransferResponse h r = silenceIOErrors $ do+	hPutStrLn h $ unwords $ Proto.formatMessage r+	hFlush h++getNextLine :: Handle -> IO String+getNextLine = silenceIOErrors . hGetLine++{- If the pipe we're talking to gets closed due to the parent git-annex+ - having exited, read/write would throw an exception due to sigpipe,+ - which gets displayed on the console in an ugly way. This silences that+ - display, and exits on exception instead.+ -+ - Normally signals like SIGINT get propagated to this process+ - from the parent process. However, since this process is run in its own+ - process group, that propagation requires the parent to actively+ - propagate the signal. One way that could not happen is if the parent+ - gets a signal it cannot catch. Another way is if the parent is hit by+ - the signal before it can set up the signal propagation.+ -}+silenceIOErrors :: IO a -> IO a+silenceIOErrors a = catchIO a (const exitFailure)
Config/Files.hs view
@@ -29,7 +29,7 @@ programFile = userConfigFile "program"  {- A .noannex file in a git repository prevents git-annex from- - initializing that repository.. The content of the file is returned. -}+ - initializing that repository. The content of the file is returned. -} noAnnexFileContent :: Maybe FilePath -> IO (Maybe String) noAnnexFileContent repoworktree = case repoworktree of 	Nothing -> return Nothing
Database/ContentIdentifier.hs view
@@ -52,7 +52,9 @@  import Database.Persist.Sql hiding (Key) import Database.Persist.TH+import Database.Persist.Sqlite (runSqlite) import qualified System.FilePath.ByteString as P+import qualified Data.Text as T  data ContentIdentifierHandle = ContentIdentifierHandle H.DbQueue @@ -62,7 +64,6 @@   cid ContentIdentifier   key Key   ContentIndentifiersKeyRemoteCidIndex key remote cid-  ContentIndentifiersCidRemoteIndex cid remote -- The last git-annex branch tree sha that was used to update -- ContentIdentifiers AnnexBranch@@ -79,9 +80,15 @@ openDb = do 	dbdir <- fromRepo gitAnnexContentIdentifierDbDir 	let db = dbdir P.</> "db"-	unlessM (liftIO $ R.doesPathExist db) $ do-		initDb db $ void $+	ifM (liftIO $ not <$> R.doesPathExist db)+		( initDb db $ void $  			runMigrationSilent migrateContentIdentifier+		-- Migrate from old version of database, which had+		-- an incorrect uniqueness constraint on the+		-- ContentIdentifiers table.+		, liftIO $ runSqlite (T.pack (fromRawFilePath db)) $ void $+			runMigrationSilent migrateContentIdentifier+		) 	h <- liftIO $ H.openDbQueue H.SingleWriter db "content_identifiers" 	return $ ContentIdentifierHandle h
Git/LsTree.hs view
@@ -1,17 +1,17 @@ {- git ls-tree interface  -- - 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.  -} -{-# LANGUAGE BangPatterns #-}- module Git.LsTree ( 	TreeItem(..), 	LsTreeMode(..), 	lsTree, 	lsTree',+	lsTreeStrict,+	lsTreeStrict', 	lsTreeParams, 	lsTreeFiles, 	parseLsTree,@@ -30,6 +30,7 @@ import System.Posix.Types import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString as AS import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Char8 as A8 @@ -38,7 +39,7 @@ 	, typeobj :: S.ByteString 	, sha :: Ref 	, file :: TopFilePath-	} deriving Show+	} deriving (Show)  data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive @@ -51,6 +52,13 @@ 	(l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo 	return (rights (map parseLsTree l), cleanup) +lsTreeStrict :: LsTreeMode -> Ref -> Repo -> IO [TreeItem]+lsTreeStrict = lsTreeStrict' []++lsTreeStrict' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO [TreeItem]+lsTreeStrict' ps lsmode t repo = rights . map parseLsTreeStrict+	<$> pipeNullSplitStrict (lsTreeParams lsmode t ps) repo+ lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] lsTreeParams lsmode r ps = 	[ Param "ls-tree"@@ -82,6 +90,13 @@ parseLsTree b = case A.parse parserLsTree b of 	A.Done _ r  -> Right r 	A.Fail _ _ err -> Left err++parseLsTreeStrict :: S.ByteString -> Either String TreeItem+parseLsTreeStrict b = go (AS.parse parserLsTree b)+  where+	go (AS.Done _ r) = Right r+	go (AS.Fail _ _ err) = Left err+	go (AS.Partial c) = go (c mempty)  {- Parses a line of ls-tree output, in format:  - mode SP type SP sha TAB file
Git/Types.hs view
@@ -135,7 +135,12 @@ fmtObjectType TreeObject = "tree"  {- Types of items in a tree. -}-data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule+data TreeItemType+	= TreeFile+	| TreeExecutable+	| TreeSymlink+	| TreeSubmodule+	| TreeSubtree 	deriving (Eq, Show)  {- Git uses magic numbers to denote the type of a tree item. -}@@ -144,6 +149,7 @@ readTreeItemType "100755" = Just TreeExecutable readTreeItemType "120000" = Just TreeSymlink readTreeItemType "160000" = Just TreeSubmodule+readTreeItemType "040000" = Just TreeSubtree readTreeItemType _ = Nothing  fmtTreeItemType :: TreeItemType -> S.ByteString@@ -151,12 +157,14 @@ fmtTreeItemType TreeExecutable = "100755" fmtTreeItemType TreeSymlink = "120000" fmtTreeItemType TreeSubmodule = "160000"+fmtTreeItemType TreeSubtree = "040000"  toTreeItemType :: FileMode -> Maybe TreeItemType toTreeItemType 0o100644 = Just TreeFile toTreeItemType 0o100755 = Just TreeExecutable toTreeItemType 0o120000 = Just TreeSymlink toTreeItemType 0o160000 = Just TreeSubmodule+toTreeItemType 0o040000 = Just TreeSubtree toTreeItemType _ = Nothing  fromTreeItemType :: TreeItemType -> FileMode@@ -164,6 +172,7 @@ fromTreeItemType TreeExecutable = 0o100755 fromTreeItemType TreeSymlink = 0o120000 fromTreeItemType TreeSubmodule = 0o160000+fromTreeItemType TreeSubtree = 0o040000  data Commit = Commit 	{ commitTree :: Sha
Limit.hs view
@@ -115,7 +115,7 @@ matchGlobFile :: String -> MatchInfo -> Annex Bool matchGlobFile glob = go   where-	cglob = compileGlob glob CaseSensative -- memoized+	cglob = compileGlob glob CaseSensative (GlobFilePath True) -- memoized 	go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi)) 	go (MatchingInfo p) = pure $ matchGlob cglob (fromRawFilePath (providedFilePath p)) 	go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (userProvidedFilePath p)@@ -166,7 +166,7 @@ 		, matchNeedsLocationLog = False 		}   where- 	cglob = compileGlob glob CaseSensative -- memoized+ 	cglob = compileGlob glob CaseSensative (GlobFilePath False) -- memoized 	go (MatchingKey _ _) = pure False 	go (MatchingFile fi) = case contentFile fi of 		Just f -> catchBoolIO $@@ -535,9 +535,11 @@ 	secs = fromIntegral (durationSeconds duration)  lookupFileKey :: FileInfo -> Annex (Maybe Key)-lookupFileKey fi = case contentFile fi of-	Just f -> lookupKey f-	Nothing -> return Nothing+lookupFileKey fi = case matchKey fi of+	Just k -> return (Just k)+	Nothing -> case contentFile fi of+		Just f -> lookupKey f+		Nothing -> return Nothing  checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a
Logs/Activity.hs view
@@ -27,7 +27,7 @@  recordActivity :: Activity -> UUID -> Annex () recordActivity act uuid = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	Annex.Branch.change activityLog $ 		buildLogOld buildActivity 			. changeLog c uuid (Right act)
Logs/Chunk.hs view
@@ -35,7 +35,7 @@  chunksStored :: UUID -> Key -> ChunkMethod -> ChunkCount -> Annex () chunksStored u k chunkmethod chunkcount = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	config <- Annex.getGitConfig 	Annex.Branch.change (chunkLogFile config k) $ 		buildLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog
Logs/Config.hs view
@@ -34,7 +34,7 @@  setGlobalConfig' :: ConfigKey -> ConfigValue -> Annex () setGlobalConfig' name new = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	Annex.Branch.change configLog $  		buildGlobalConfig . changeMapLog c name new . parseGlobalConfig
Logs/ContentIdentifier.hs view
@@ -30,14 +30,18 @@ -- so ones that were recorded before are preserved. recordContentIdentifier :: RemoteStateHandle -> ContentIdentifier -> Key -> Annex () recordContentIdentifier (RemoteStateHandle u) cid k = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	config <- Annex.getGitConfig-	Annex.Branch.change (remoteContentIdentifierLogFile config k) $-		buildLog . addcid c . parseLog+	Annex.Branch.maybeChange (remoteContentIdentifierLogFile config k) $+		addcid c . parseLog   where-	addcid c l = changeMapLog c u (cid :| contentIdentifierList (M.lookup u m)) l+	addcid c v+		| cid `elem` l = Nothing -- no change needed+		| otherwise = Just $ buildLog $+			changeMapLog c u (cid :| l) v 	  where-		m = simpleMap l+		m = simpleMap v+		l = contentIdentifierList (M.lookup u m)  -- | Get all known content identifiers for a key. getContentIdentifiers :: Key -> Annex [(RemoteStateHandle, [ContentIdentifier])]
Logs/Difference.hs view
@@ -25,7 +25,7 @@  recordDifferences :: Differences -> UUID -> Annex () recordDifferences ds@(Differences {}) uuid = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	Annex.Branch.change differenceLog $ 		buildLogOld byteString  			. changeLog c uuid (encodeBS $ showDifferences ds)
Logs/Export.hs view
@@ -1,6 +1,6 @@-{- git-annex export log+{- git-annex export log (also used to log imports)  -- - Copyright 2017-2019 Joey Hess <id@joeyh.name>+ - Copyright 2017-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -15,8 +15,9 @@ 	getExport, 	exportedTreeishes, 	incompleteExportedTreeishes,-	recordExport, 	recordExportBeginning,+	recordExportUnderway,+	recordExport, 	logExportExcluded, 	getExportExcluded, ) where@@ -64,7 +65,6 @@ incompleteExportedTreeishes :: [Exported] -> [Git.Ref] incompleteExportedTreeishes = concatMap incompleteExportedTreeish - data ExportParticipants = ExportParticipants 	{ exportFrom :: UUID 	, exportTo :: UUID@@ -86,8 +86,37 @@ 		| exportTo ep == remoteuuid = Just exported 		| otherwise = Nothing --- | Record a change in what's exported to a special remote.+-- | Record the beginning of an export, to allow cleaning up from+-- interrupted exports. --+-- This is called before any changes are made to the remote.+recordExportBeginning :: UUID -> Git.Ref -> Annex ()+recordExportBeginning remoteuuid newtree = do+	c <- currentVectorClock+	u <- getUUID+	let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }+	old <- fromMaybe (Exported emptyTree [])+		. M.lookup ep . simpleMap +		. parseExportLog+		<$> Annex.Branch.get exportLog+	let new = old { incompleteExportedTreeish = nub (newtree:incompleteExportedTreeish old) }+	Annex.Branch.change exportLog $+		buildExportLog +			. changeMapLog c ep new+			. parseExportLog+	recordExportTreeish newtree++-- Grade a tree ref into the git-annex branch. This is done+-- to ensure that it's available later, when getting exported files+-- from the remote. Since that could happen in another clone of the+-- repository, the tree has to be kept available, even if it+-- doesn't end up being merged into the master branch.+recordExportTreeish :: Git.Ref -> Annex ()+recordExportTreeish t = +	Annex.Branch.rememberTreeish t (asTopFilePath "export.tree")++-- | Record that an export to a special remote is under way.+-- -- This is called before an export begins uploading new files to the -- remote, but after it's cleaned up any files that need to be deleted -- from the old treeish.@@ -96,12 +125,9 @@ -- newTreeish. This way, when multiple repositories are exporting to -- the same special remote, there's no conflict as long as they move -- forward in lock-step.------ Also, the newTreeish is grafted into the git-annex branch. This is done--- to ensure that it's available later.-recordExport :: UUID -> ExportChange -> Annex ()-recordExport remoteuuid ec = do-	c <- liftIO currentVectorClock+recordExportUnderway :: UUID -> ExportChange -> Annex ()+recordExportUnderway remoteuuid ec = do+	c <- currentVectorClock 	u <- getUUID 	let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid } 	let exported = Exported (newTreeish ec) []@@ -115,25 +141,16 @@ 		| u == exportFrom ep || remoteuuid /= exportTo ep || t `notElem` oldTreeish ec = le 		| otherwise = LogEntry c (exported { exportedTreeish = newTreeish ec }) --- | Record the beginning of an export, to allow cleaning up from--- interrupted exports.+-- Record information about the export to the git-annex branch. ----- This is called before any changes are made to the remote.-recordExportBeginning :: UUID -> Git.Ref -> Annex ()-recordExportBeginning remoteuuid newtree = do-	c <- liftIO currentVectorClock-	u <- getUUID-	let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid }-	old <- fromMaybe (Exported emptyTree [])-		. M.lookup ep . simpleMap -		. parseExportLog-		<$> Annex.Branch.get exportLog-	let new = old { incompleteExportedTreeish = nub (newtree:incompleteExportedTreeish old) }-	Annex.Branch.change exportLog $-		buildExportLog -			. changeMapLog c ep new-			. parseExportLog-	Annex.Branch.rememberTreeish newtree (asTopFilePath "export.tree")+-- This is equivilant to recordExportBeginning followed by+-- recordExportUnderway, but without the ability to clean up from+-- interrupted exports.+recordExport :: UUID -> Git.Ref -> ExportChange -> Annex ()+recordExport remoteuuid tree ec = do+	when (oldTreeish ec /= [tree]) $+		recordExportTreeish tree+	recordExportUnderway remoteuuid ec  parseExportLog :: L.ByteString -> MapLog ExportParticipants Exported parseExportLog = parseMapLog exportParticipantsParser exportedParser
Logs/Group.hs view
@@ -38,7 +38,7 @@ groupChange :: UUID -> (S.Set Group -> S.Set Group) -> Annex () groupChange uuid@(UUID _) modifier = do 	curr <- lookupGroups uuid-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	Annex.Branch.change groupLog $ 		buildLogOld buildGroup . changeLog c uuid (modifier curr) . parseLogOld parseGroup
Logs/Location.hs view
@@ -16,6 +16,7 @@ module Logs.Location ( 	LogStatus(..), 	logStatus,+	logStatusAfter, 	logChange, 	loggedLocations, 	loggedLocationsHistorical,@@ -47,6 +48,16 @@ logStatus key s = do 	u <- getUUID 	logChange key u s++{- Run an action that gets the content of a key, and update the log+ - when it succeeds. -}+logStatusAfter :: Key -> Annex Bool -> Annex Bool+logStatusAfter key a = ifM a +	( do+		logStatus key InfoPresent+		return True+	, return False+	)  {- Log a change in the presence of a key's value in a repository. -} logChange :: Key -> UUID -> LogStatus -> Annex ()
Logs/MetaData.hs view
@@ -103,7 +103,7 @@  addMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> Annex () addMetaData' getlogfile k metadata = -	addMetaDataClocked' getlogfile k metadata =<< liftIO currentVectorClock+	addMetaDataClocked' getlogfile k metadata =<< currentVectorClock  {- Reusing the same VectorClock when making changes to the metadata  - of multiple keys is a nice optimisation. The same metadata lines
Logs/Multicast.hs view
@@ -25,7 +25,7 @@  recordFingerprint :: Fingerprint -> UUID -> Annex () recordFingerprint fp uuid = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	Annex.Branch.change multicastLog $ 		buildLogOld buildFindgerPrint 			. changeLog c uuid fp
Logs/PreferredContent/Raw.hs view
@@ -30,7 +30,7 @@  setLog :: RawFilePath -> UUID -> PreferredContentExpression -> Annex () setLog logfile uuid@(UUID _) val = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	Annex.Branch.change logfile $ 		buildLogOld buildPreferredContentExpression 		. changeLog c uuid val@@ -44,7 +44,7 @@ {- Changes the preferred content configuration of a group. -} groupPreferredContentSet :: Group -> PreferredContentExpression -> Annex () groupPreferredContentSet g val = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	Annex.Branch.change groupPreferredContentLog $ 		buildGroupPreferredContent 		. changeMapLog c g val
Logs/Presence.hs view
@@ -51,7 +51,7 @@ {- Generates a new LogLine with the current time. -} logNow :: LogStatus -> LogInfo -> Annex LogLine logNow s i = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	return $ LogLine c s i  {- Reads a log and returns only the info that is still in effect. -}
Logs/Remote.hs view
@@ -32,7 +32,7 @@ {- Adds or updates a remote's config in the log. -} configSet :: UUID -> RemoteConfig -> Annex () configSet u cfg = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	Annex.Branch.change remoteLog $ 		buildRemoteConfigLog 			. changeLog c u (removeSameasInherited cfg)
Logs/RemoteState.hs view
@@ -26,7 +26,7 @@  setRemoteState :: RemoteStateHandle -> Key -> RemoteState -> Annex () setRemoteState (RemoteStateHandle u) k s = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	config <- Annex.getGitConfig 	Annex.Branch.change (remoteStateLogFile config k) $ 		buildRemoteState . changeLog c u s . parseRemoteState
Logs/Schedule.hs view
@@ -32,7 +32,7 @@  scheduleSet :: UUID -> [ScheduledActivity] -> Annex () scheduleSet uuid@(UUID _) activities = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	Annex.Branch.change scheduleLog $ 		buildLogOld byteString  			. changeLog c uuid (encodeBS val)
Logs/SingleValue.hs view
@@ -33,6 +33,6 @@  setLog :: (SingleValueSerializable v) => RawFilePath -> v -> Annex () setLog f v = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	let ent = LogEntry c v 	Annex.Branch.change f $ \_old -> buildLog (S.singleton ent)
Logs/Trust.hs view
@@ -1,6 +1,6 @@ {- git-annex trust log  -- - Copyright 2010-2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -64,20 +64,15 @@ {- Loads the map, updating the cache, -} trustMapLoad :: Annex TrustMap trustMapLoad = do-	overrides <- Annex.getState Annex.forcetrust+	forceoverrides <- Annex.getState Annex.forcetrust 	l <- remoteList-	-- Exports are not trusted, since they are not key/value stores.-	-- This does not apply to appendonly exports, which are key/value-	-- stores.-	let untrustworthy r = pure (not (Types.Remote.appendonly r)) -		<&&> Types.Remote.isExportSupported r -	exports <- filterM untrustworthy l-	let exportoverrides = M.fromList $-		map (\r -> (Types.Remote.uuid r, UnTrusted)) exports+	let untrustoverrides = M.fromList $+		map (\r -> (Types.Remote.uuid r, UnTrusted))+		(filter Types.Remote.untrustworthy l) 	logged <- trustMapRaw 	let configured = M.fromList $ mapMaybe configuredtrust l-	let m = M.unionWith min exportoverrides $-		M.union overrides $+	let m = M.unionWith min untrustoverrides $+		M.union forceoverrides $ 		M.union configured logged 	Annex.changeState $ \s -> s { Annex.trustmap = Just m } 	return m
Logs/Trust/Basic.hs view
@@ -22,7 +22,7 @@ {- Changes the trust level for a uuid in the trustLog. -} trustSet :: UUID -> TrustLevel -> Annex () trustSet uuid@(UUID _) level = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	Annex.Branch.change trustLog $ 		buildLogOld buildTrustLevel . 			changeLog c uuid level .
Logs/UUID.hs view
@@ -31,7 +31,7 @@ {- Records a description for a uuid in the log. -} describeUUID :: UUID -> UUIDDesc -> Annex () describeUUID uuid desc = do-	c <- liftIO currentVectorClock+	c <- currentVectorClock 	Annex.Branch.change uuidLog $ 		buildLogOld buildUUIDDesc . changeLog c uuid desc . parseUUIDLog
Messages.hs view
@@ -285,9 +285,10 @@ commandProgressDisabled :: Annex Bool commandProgressDisabled = withMessageState $ \s -> return $ 	case outputType s of+		NormalOutput -> concurrentOutputEnabled s 		QuietOutput -> True 		JSONOutput _ -> True-		NormalOutput -> concurrentOutputEnabled s+		SerializedOutput _ _ -> True  jsonOutputEnabled :: Annex Bool jsonOutputEnabled = withMessageState $ \s -> return $@@ -313,8 +314,20 @@   where 	goconcurrent = withMessageState $ \s -> do 		let l = promptLock s+		let (run, cleanup) = case outputType s of+			SerializedOutput h hr ->+				( \a -> do+					liftIO $ outputSerialized h BeginPrompt+					liftIO $ waitOutputSerializedResponse hr ReadyPrompt+					a+				, liftIO $ outputSerialized h EndPrompt+				)+			_ ->+				( hideRegionsWhile s+				, noop+				) 		return $ \a -> 			debugLocks $ bracketIO 				(takeMVar l)-				(putMVar l)-				(const $ hideRegionsWhile s a)+				(\v -> putMVar l v >> cleanup)+				(const $ run a)
Messages/Concurrent.hs view
@@ -98,10 +98,14 @@ 			Regions.closeConsoleRegion r  {- The progress region is displayed inline with the current console region. -}-withProgressRegion :: (Regions.ConsoleRegion -> Annex a) -> Annex a-withProgressRegion a = do-	parent <- consoleRegion <$> Annex.getState Annex.output+withProgressRegion+	:: (MonadIO m, MonadMask m)+	=> MessageState +	-> (Regions.ConsoleRegion -> m a) -> m a+withProgressRegion st a = 	Regions.withConsoleRegion (maybe Regions.Linear Regions.InLine parent) a+  where+	parent = consoleRegion st  instance Regions.LiftRegion Annex where 	liftRegion = liftIO . atomically
Messages/Internal.hs view
@@ -1,6 +1,6 @@ {- git-annex output messages, including concurrent output to display regions  -- - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -29,25 +29,32 @@ 		| otherwise -> liftIO $ flushed $ S.putStr msg 	JSONOutput _ -> void $ jsonoutputter jsonbuilder s 	QuietOutput -> q+	SerializedOutput h _ -> do+		liftIO $ outputSerialized h $ OutputMessage msg+		void $ jsonoutputter jsonbuilder s  -- Buffer changes to JSON until end is reached and then emit it. bufferJSON :: JSONBuilder -> MessageState -> Annex Bool bufferJSON jsonbuilder s = case outputType s of-	JSONOutput jsonoptions-		| endjson -> do+	JSONOutput _ -> go (flushed . JSON.emit)+	SerializedOutput h _ -> go (outputSerialized h . JSONObject . JSON.encode)+	_ -> return False+  where+	go emitter+		| endjson = do 			Annex.changeState $ \st ->  				st { Annex.output = s { jsonBuffer = Nothing } }-			maybe noop (liftIO . flushed . JSON.emit . JSON.finalize jsonoptions) json+			maybe noop (liftIO . emitter . JSON.finalize) json 			return True-		| otherwise -> do+		| otherwise = do 			Annex.changeState $ \st -> 			        st { Annex.output = s { jsonBuffer = json } } 			return True-	_ -> return False-  where+	 	(json, endjson) = case jsonbuilder i of 		Nothing -> (jsonBuffer s, False) 		(Just (j, e)) -> (Just j, e)+	 	i = case jsonBuffer s of 		Nothing -> Nothing 		Just b -> Just (b, False)@@ -55,11 +62,14 @@ -- Immediately output JSON. outputJSON :: JSONBuilder -> MessageState -> Annex Bool outputJSON jsonbuilder s = case outputType s of-	JSONOutput _ -> do-		maybe noop (liftIO . flushed . JSON.emit)+	JSONOutput _ -> go (flushed . JSON.emit)+	SerializedOutput h _ -> go (outputSerialized h . JSONObject . JSON.encode)+	_ -> return False+  where+	go emitter = do+		maybe noop (liftIO . emitter) 			(fst <$> jsonbuilder Nothing) 		return True-	_ -> return False  outputError :: String -> Annex () outputError msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of@@ -67,6 +77,8 @@ 		let jb' = Just (JSON.addErrorMessage (lines msg) jb) 		in Annex.changeState $ \st -> 			st { Annex.output = s { jsonBuffer = jb' } }+	(SerializedOutput h _, _) -> +		liftIO $ outputSerialized h $ OutputError msg 	_ 		| concurrentOutputEnabled s -> concurrentMessage s True msg go 		| otherwise -> go@@ -81,3 +93,12 @@  flushed :: IO () -> IO () flushed a = a >> hFlush stdout++outputSerialized :: (SerializedOutput -> IO ()) -> SerializedOutput -> IO ()+outputSerialized = id++-- | Wait for the specified response.+waitOutputSerializedResponse :: (IO (Maybe SerializedOutputResponse)) -> SerializedOutputResponse -> IO ()+waitOutputSerializedResponse getr r = tryIO getr >>= \case+	Right (Just r') | r' == r -> return ()+	v -> error $ "serialized output protocol error; expected " ++ show r ++ " got " ++ show v
Messages/JSON.hs view
@@ -11,6 +11,8 @@ 	JSONBuilder, 	JSONChunk(..), 	emit,+	emit',+	encode, 	none, 	start, 	end,@@ -38,7 +40,6 @@ import Data.Monoid import Prelude -import Types.Messages import Types.Command (SeekInput(..)) import Key import Utility.Metered@@ -52,9 +53,12 @@ emitLock = unsafePerformIO $ newMVar ()  emit :: Object -> IO ()-emit o = do+emit = emit' . encode++emit' :: L.ByteString -> IO ()+emit' b = do 	takeMVar emitLock-	L.hPut stdout (encode o)+	L.hPut stdout b 	putStr "\n" 	putMVar emitLock () @@ -82,12 +86,10 @@ end b (Just (o, _)) = Just (HM.insert "success" (toJSON' b) o, True) end _ Nothing = Nothing -finalize :: JSONOptions -> Object -> Object-finalize jsonoptions o-	-- Always include error-messages field, even if empty,-	-- to make the json be self-documenting.-	| jsonErrorMessages jsonoptions = addErrorMessage [] o-	| otherwise = o+-- Always include error-messages field, even if empty,+-- to make the json be self-documenting.+finalize :: Object -> Object+finalize o = addErrorMessage [] o  addErrorMessage :: [String] -> Object -> Object addErrorMessage msg o =@@ -132,7 +134,7 @@  -- Show JSON formatted progress, including the current state of the JSON  -- object for the action being performed.-progress :: Maybe Object -> Maybe Integer -> BytesProcessed -> IO ()+progress :: Maybe Object -> Maybe TotalSize -> BytesProcessed -> IO () progress maction msize bytesprocessed =  	case j of 		Object o -> emit $ case maction of@@ -142,7 +144,7 @@   where 	n = fromBytesProcessed bytesprocessed :: Integer 	j = case msize of-		Just size -> object+		Just (TotalSize size) -> object 			[ "byte-progress" .= n 			, "percent-progress" .= showPercentage 2 (percentage size n) 			, "total-size" .= size
Messages/Progress.hs view
@@ -1,6 +1,6 @@ {- git-annex progress output  -- - Copyright 2010-2019 Joey Hess <id@joeyh.name>+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -20,27 +20,30 @@ import Utility.InodeCache import qualified Messages.JSON as JSON import Messages.Concurrent+import Messages.Internal  import qualified System.Console.Regions as Regions import qualified System.Console.Concurrent as Console+import Control.Monad.IO.Class (MonadIO)+import Data.IORef  {- Class of things from which a size can be gotten to display a progress  - meter. -} class MeterSize t where-	getMeterSize :: t -> Annex (Maybe FileSize)+	getMeterSize :: t -> Annex (Maybe TotalSize)  instance MeterSize t => MeterSize (Maybe t) where 	getMeterSize Nothing = pure Nothing 	getMeterSize (Just t) = getMeterSize t  instance MeterSize FileSize where-	getMeterSize = pure . Just+	getMeterSize = pure . Just . TotalSize  instance MeterSize Key where-	getMeterSize = pure . fromKey keySize+	getMeterSize = pure . fmap TotalSize . fromKey keySize  instance MeterSize InodeCache where-	getMeterSize = pure . Just . inodeCacheFileSize+	getMeterSize = pure . Just . TotalSize . inodeCacheFileSize  instance MeterSize KeySource where 	getMeterSize = maybe (pure Nothing) getMeterSize . inodeCache@@ -53,48 +56,85 @@  instance MeterSize KeySizer where 	getMeterSize (KeySizer k getsrcfile) = case fromKey keySize k of-		Just sz -> return (Just sz)+		Just sz -> return (Just (TotalSize sz)) 		Nothing -> do 			srcfile <- getsrcfile 			case srcfile of 				Nothing -> return Nothing-				Just f -> catchMaybeIO $ liftIO $ getFileSize f+				Just f -> catchMaybeIO $ liftIO $+					TotalSize <$> getFileSize f  {- Shows a progress meter while performing an action.  - The action is passed the meter and a callback to use to update the meter.  --}-metered :: MeterSize sizer => Maybe MeterUpdate -> sizer -> (Meter -> MeterUpdate -> Annex a) -> Annex a-metered othermeter sizer a = withMessageState $ \st ->-	flip go st =<< getMeterSize sizer+metered+	:: MeterSize sizer+	=> Maybe MeterUpdate+	-> sizer+	-> (Meter -> MeterUpdate -> Annex a)+	-> Annex a+metered othermeter sizer a = withMessageState $ \st -> do+	sz <- getMeterSize sizer+	metered' st othermeter sz showOutput a++metered'+	:: (Monad m, MonadIO m, MonadMask m)+	=> MessageState+	-> Maybe MeterUpdate+	-> Maybe TotalSize+	-> m ()+	-- ^ this should run showOutput+	-> (Meter -> MeterUpdate -> m a)+	-> m a+metered' st othermeter msize showoutput a = go st   where-	go _ (MessageState { outputType = QuietOutput }) = nometer-	go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do-		showOutput+	go (MessageState { outputType = QuietOutput }) = nometer+	go (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do+		showoutput 		meter <- liftIO $ mkMeter msize $  			displayMeterHandle stdout bandwidthMeter-		m <- liftIO $ rateLimitMeterUpdate 0.2 meter $+		m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $ 			updateMeter meter 		r <- a meter (combinemeter m) 		liftIO $ clearMeterHandle meter stdout 		return r-	go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =-		withProgressRegion $ \r -> do+	go (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =+		withProgressRegion st $ \r -> do 			meter <- liftIO $ mkMeter msize $ \_ msize' old new -> 				let s = bandwidthMeter msize' old new 				in Regions.setConsoleRegion r ('\n' : s)-			m <- liftIO $ rateLimitMeterUpdate 0.2 meter $+			m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $ 				updateMeter meter 			a meter (combinemeter m)-	go msize (MessageState { outputType = JSONOutput jsonoptions })+	go (MessageState { outputType = JSONOutput jsonoptions }) 		| jsonProgress jsonoptions = do-			buf <- withMessageState $ return . jsonBuffer-			meter <- liftIO $ mkMeter msize $ \_ msize' _old (new, _now) ->-				JSON.progress buf msize' new-			m <- liftIO $ rateLimitMeterUpdate 0.1 meter $+			let buf = jsonBuffer st+			meter <- liftIO $ mkMeter msize $ \_ msize' _old new ->+				JSON.progress buf msize' (meterBytesProcessed new)+			m <- liftIO $ rateLimitMeterUpdate jsonratelimit meter $ 				updateMeter meter 			a meter (combinemeter m) 		| otherwise = nometer-+	go (MessageState { outputType = SerializedOutput h _ }) = do+		liftIO $ outputSerialized h BeginProgressMeter+		case msize of+			Just sz -> liftIO $ outputSerialized h $ UpdateProgressMeterTotalSize sz+			Nothing -> noop+		szv <- liftIO $ newIORef msize+		meter <- liftIO $ mkMeter msize $ \_ msize' _old new -> do+			case msize' of+				Just sz | msize' /= msize -> do+					psz <- readIORef szv+					when (msize' /= psz) $ do+						writeIORef szv msize'+						outputSerialized h $ UpdateProgressMeterTotalSize sz+				_ -> noop+			outputSerialized h $ UpdateProgressMeter $+				meterBytesProcessed new+		m <- liftIO $ rateLimitMeterUpdate minratelimit meter $+			updateMeter meter+		a meter (combinemeter m)+			`finally` (liftIO $ outputSerialized h EndProgressMeter) 	nometer = do 		dummymeter <- liftIO $ mkMeter Nothing $ 			\_ _ _ _ -> return ()@@ -103,6 +143,12 @@ 	combinemeter m = case othermeter of 		Nothing -> m 		Just om -> combineMeterUpdate m om++	consoleratelimit = 0.2++	jsonratelimit = 0.1++	minratelimit = min consoleratelimit jsonratelimit  {- Poll file size to display meter. -} meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a
+ Messages/Serialized.hs view
@@ -0,0 +1,108 @@+{- serialized output+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE RankNTypes #-}++module Messages.Serialized (+	relaySerializedOutput,+	outputSerialized,+	waitOutputSerializedResponse,+) where++import Common+import Annex+import Types.Messages+import Messages+import Messages.Internal+import Messages.Progress+import qualified Messages.JSON as JSON+import Utility.Metered (BytesProcessed, setMeterTotalSize)++import Control.Monad.IO.Class (MonadIO)++-- | Relay serialized output from a child process to the console.+relaySerializedOutput+	:: (Monad m, MonadIO m, MonadMask m)+	=> m (Either SerializedOutput r)+	-- ^ Get next serialized output, or final value to return.+	-> (SerializedOutputResponse -> m ())+	-- ^ Send response to child process.+	-> (Maybe BytesProcessed -> m ())+	-- ^ When a progress meter is running, is updated with+	-- progress meter values sent by the process.+	-- When a progress meter is stopped, Nothing is sent.+	-> (forall a. Annex a -> m a)+	-- ^ Run an annex action in the monad. Will not be used with+	-- actions that block for a long time.+	-> m r+relaySerializedOutput getso sendsor meterreport runannex = go Nothing+  where+	go st = loop st >>= \case+		Right r -> return r+		Left st' -> go st'+	+	loop st = getso >>= \case+		Right r -> return (Right r)+		Left (OutputMessage msg) -> do+			runannex $ outputMessage'+				(\_ _ -> return False)+				id+				msg+			loop st+		Left (OutputError msg) -> do+			runannex $ outputError msg+			loop st		+		Left (JSONObject b) -> do+			runannex $ withMessageState $ \s -> case outputType s of+				JSONOutput _ -> liftIO $ flushed $ JSON.emit' b+				SerializedOutput h _ -> liftIO $+					outputSerialized h $ JSONObject b+				_ -> q+			loop st+		Left BeginProgressMeter -> do+			ost <- runannex (Annex.getState Annex.output)+			-- Display a progress meter while running, until+			-- the meter ends or a final value is returned.+			metered' ost Nothing Nothing (runannex showOutput) +				(\meter meterupdate -> loop (Just (meter, meterupdate)))+				>>= \case+					Right r -> return (Right r)+					-- Continue processing serialized+					-- output after the progress meter+					-- is done.+					Left _st' -> loop Nothing+		Left EndProgressMeter -> do+			meterreport Nothing+			return (Left st)+		Left (UpdateProgressMeter n) -> do+			case st of+				Just (_, meterupdate) -> do+					meterreport (Just n)+					liftIO $ meterupdate n+				Nothing -> noop+			loop st+		Left (UpdateProgressMeterTotalSize sz) -> do+			case st of+				Just (meter, _) -> liftIO $+					setMeterTotalSize meter sz+				Nothing -> noop+			loop st+		Left BeginPrompt -> do+			prompter <- runannex mkPrompter+			v <- prompter $ do+				sendsor ReadyPrompt+				-- Continue processing serialized output+				-- until EndPrompt or a final value is+				-- returned. (EndPrompt is all that+				-- ought to be sent while in a prompt+				-- really, but if something else did get+				-- sent, display it just in case.)+				loop st+			case v of+				Right r -> return (Right r)+				Left st' -> loop st'+		Left EndPrompt -> return (Left st)
P2P/Annex.hs view
@@ -75,8 +75,8 @@ 		let rsp = RetrievalAllKeysSecure 		v <- tryNonAsync $ do 			let runtransfer ti = -				Right <$> transfer download k af (\p ->-					getViaTmp rsp DefaultVerify k af $ \tmp ->+				Right <$> transfer download' k af (\p ->+					logStatusAfter k $ getViaTmp rsp DefaultVerify k af $ \tmp -> 						storefile (fromRawFilePath tmp) o l getb validitycheck p ti) 			let fallback = return $ Left $ 				ProtoFailureMessage "transfer already in progress, or unable to take transfer lock"@@ -172,6 +172,14 @@ 				runner validitycheck >>= \case 					Right (Just Valid) -> 						return (rightsize, UnVerified)+					Right (Just Invalid) | l == 0 ->+						-- Special case, for when+						-- content was not+						-- available to send, +						-- which is indicated by+						-- sending 0 bytes and +						-- Invalid.+						return (False, UnVerified) 					_ -> do 						-- Invalid, or old protocol 						-- version. Validity is not
P2P/Protocol.hs view
@@ -2,7 +2,7 @@  -  - See doc/design/p2p_protocol.mdwn  -- - Copyright 2016-2018 Joey Hess <id@joeyh.name>+ - Copyright 2016-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -53,6 +53,9 @@ maxProtocolVersion :: ProtocolVersion maxProtocolVersion = ProtocolVersion 1 +newtype ProtoAssociatedFile = ProtoAssociatedFile AssociatedFile+	deriving (Show)+ -- | Service as used by the connect message in gitremote-helpers(1) data Service = UploadPack | ReceivePack 	deriving (Show)@@ -75,8 +78,8 @@ 	| LOCKCONTENT Key 	| UNLOCKCONTENT 	| REMOVE Key-	| GET Offset AssociatedFile Key-	| PUT AssociatedFile Key+	| GET Offset ProtoAssociatedFile Key+	| PUT ProtoAssociatedFile Key 	| PUT_FROM Offset 	| ALREADY_HAVE 	| SUCCESS@@ -154,7 +157,7 @@ 	deserialize "git-receive-pack" = Just ReceivePack 	deserialize _ = Nothing --- | Since AssociatedFile is not the last thing in a protocol line,+-- | Since ProtoAssociatedFile is not the last thing in a protocol line, -- its serialization cannot contain any whitespace. This is handled -- by replacing whitespace with '%' (and '%' with '%%') --@@ -162,11 +165,11 @@ -- to avoid any unusual characters that might cause problems when it's -- displayed to the user. ----- These mungings are ok, because an AssociatedFile is only ever displayed+-- These mungings are ok, because a ProtoAssociatedFile is only ever displayed -- to the user and does not need to match a file on disk.-instance Proto.Serializable AssociatedFile where-	serialize (AssociatedFile Nothing) = ""-	serialize (AssociatedFile (Just af)) = +instance Proto.Serializable ProtoAssociatedFile where+	serialize (ProtoAssociatedFile (AssociatedFile Nothing)) = ""+	serialize (ProtoAssociatedFile (AssociatedFile (Just af))) =  		decodeBS' $ toInternalGitPath $ encodeBS' $ concatMap esc $ fromRawFilePath af 	  where 		esc '%' = "%%"@@ -175,9 +178,10 @@ 			| otherwise = [c] 	 	deserialize s = case fromRawFilePath $ fromInternalGitPath $ toRawFilePath $ deesc [] s of-		[] -> Just (AssociatedFile Nothing)+		[] -> Just $ ProtoAssociatedFile $ AssociatedFile Nothing 		f-			| isRelative f -> Just $ AssociatedFile $ Just $ toRawFilePath f+			| isRelative f -> Just $ ProtoAssociatedFile $ +				AssociatedFile $ Just $ toRawFilePath f 			| otherwise -> Nothing 	  where 	  	deesc b [] = reverse b@@ -277,7 +281,7 @@ 	-- present, runs the protocol action with False. 	| WaitRefChange (ChangedRefs -> c) 	-- ^ Waits for one or more git refs to change and returns them.a-	| UpdateMeterTotalSize Meter Integer c+	| UpdateMeterTotalSize Meter TotalSize c 	-- ^ Updates the total size of a Meter, for cases where the size is 	-- not known until the data is being received. 	| RunValidityCheck (Annex Validity) (Validity -> c)@@ -349,14 +353,15 @@  get :: FilePath -> Key -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification) get dest key af m p = -	receiveContent (Just m) p sizer storer (\offset -> GET offset af key)+	receiveContent (Just m) p sizer storer $ \offset ->+		GET offset (ProtoAssociatedFile af) key   where 	sizer = fileSize dest 	storer = storeContentTo dest  put :: Key -> AssociatedFile -> MeterUpdate -> Proto Bool put key af p = do-	net $ sendMessage (PUT af key)+	net $ sendMessage (PUT (ProtoAssociatedFile af) key) 	r <- net receiveMessage 	case r of 		Just (PUT_FROM offset) -> sendContent key af offset p@@ -461,14 +466,14 @@ 		ServeReadOnly -> do 			readonlyerror 			return ServerContinue-	handler (PUT af key) = case servermode of+	handler (PUT (ProtoAssociatedFile af) key) = case servermode of 		ServeReadWrite -> handleput af key 		ServeAppendOnly -> handleput af key 		ServeReadOnly -> do 			readonlyerror 			return ServerContinue-	handler (GET offset key af) = do-		void $ sendContent af key offset nullMeterUpdate+	handler (GET offset (ProtoAssociatedFile af) key) = do+		void $ sendContent key af offset nullMeterUpdate 		-- setPresent not called because the peer may have 		-- requested the data but not permanently stored it. 		return ServerContinue@@ -508,13 +513,15 @@ sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto Bool sendContent key af offset@(Offset n) p = go =<< local (contentSize key)   where- 	go Nothing = sender (Len 0) L.empty (return Valid) 	go (Just (Len totallen)) = do 		let len = totallen - n 		if len <= 0 			then sender (Len 0) L.empty (return Valid) 			else local $ readContent key af offset $ 				sender (Len len)+	-- Content not available to send. Indicate this by sending+	-- empty data and indlicate it's invalid.+ 	go Nothing = sender (Len 0) L.empty (return Invalid) 	sender len content validitycheck = do 		let p' = offsetMeterUpdate p (toBytesProcessed n) 		net $ sendMessage (DATA len)@@ -541,7 +548,7 @@ 		Just (DATA len@(Len l)) -> do 			local $ case mm of 				Nothing -> return ()-				Just m -> updateMeterTotalSize m (n+l)+				Just m -> updateMeterTotalSize m (TotalSize (n+l)) 			ver <- net getProtocolVersion 			let validitycheck = if ver >= ProtocolVersion 1 				then net receiveMessage >>= \case
Remote.hs view
@@ -70,6 +70,7 @@ import Types.Remote import qualified Annex import Annex.UUID+import Annex.Action import Logs.UUID import Logs.Trust import Logs.Location hiding (logStatus)@@ -81,21 +82,6 @@ import Config.DynamicConfig import Git.Types (RemoteName, ConfigKey(..), fromConfigValue) import Utility.Aeson--{- Runs an action that may throw exceptions, catching and displaying them. -}-action :: Annex () -> Annex Bool-action a = tryNonAsync a >>= \case-	Right () -> return True-	Left e -> do-		warning (show e)-		return False--verifiedAction :: Annex Verification -> Annex (Bool, Verification)-verifiedAction a = tryNonAsync a >>= \case-	Right v -> return (True, v)-	Left e -> do-		warning (show e)-		return (False, UnVerified)  {- Map from UUIDs of Remotes to a calculated value. -} remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)
Remote/Adb.hs view
@@ -46,6 +46,7 @@ 	, setup = adbSetup 	, exportSupported = exportIsSupported 	, importSupported = importIsSupported+	, thirdPartyPopulated = False 	}  androiddirectoryField :: RemoteConfigField@@ -75,6 +76,7 @@ 			{ storeExport = storeExportM serial adir 			, retrieveExport = retrieveExportM serial adir 			, removeExport = removeExportM serial adir+			, versionedExport = False 			, checkPresentExport = checkPresentExportM this serial adir 			, removeExportDirectory = Just $ removeExportDirectoryM serial adir 			, renameExport = renameExportM serial adir@@ -99,6 +101,7 @@ 		, availability = LocallyAvailable 		, readonly = False 		, appendonly = False+		, untrustworthy = False 		, mkUnavailable = return Nothing 		, getInfo = return 			[ ("androidserial", fromAndroidSerial serial)@@ -286,8 +289,11 @@ 		]  listImportableContentsM :: AndroidSerial -> AndroidPath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))-listImportableContentsM serial adir =-	process <$> adbShell serial+listImportableContentsM serial adir = adbfind >>= \case+	Just ls -> return $ Just $ ImportableContents (mapMaybe mk ls) []+	Nothing -> giveup "adb find failed"+  where+	adbfind = adbShell serial 		[ Param "find" 		-- trailing slash is needed, or android's find command 		-- won't recurse into the directory@@ -297,9 +303,6 @@ 		, Param "-c", Param statformat 		, Param "{}", Param "+" 		]-  where-	process Nothing = Nothing-	process (Just ls) = Just $ ImportableContents (mapMaybe mk ls) []  	statformat = adbStatFormat ++ "\t%n"
Remote/BitTorrent.hs view
@@ -49,6 +49,7 @@ 	, setup = error "not supported" 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  -- There is only one bittorrent remote, and it always exists.@@ -85,6 +86,7 @@ 		, getRepo = return r 		, readonly = True 		, appendonly = False+		, untrustworthy = False 		, availability = GloballyAvailable 		, remotetype = remote 		, mkUnavailable = return Nothing@@ -181,7 +183,7 @@  - torrent file once.  -} registerTorrentCleanup :: URLString -> Annex ()-registerTorrentCleanup u = Annex.addCleanup (TorrentCleanup u) $+registerTorrentCleanup u = Annex.addCleanupAction (TorrentCleanup u) $ 	liftIO . removeWhenExistsWith R.removeLink =<< tmpTorrentFile u  {- Downloads the torrent file. (Not its contents.) -}
+ Remote/Borg.hs view
@@ -0,0 +1,345 @@+{- Using borg as a remote.+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Remote.Borg (remote) where++import Annex.Common+import Types.Remote+import Types.Creds+import Types.Import+import qualified Git+import qualified Git.LsTree as LsTree+import Git.Types (toTreeItemType, TreeItemType(..))+import Git.FilePath+import Config+import Config.Cost+import Annex.Tmp+import Annex.SpecialRemote.Config+import Remote.Helper.Special+import Remote.Helper.ExportImport+import Annex.UUID+import Types.ProposedAccepted+import Utility.Metered+import Logs.Export+import qualified Remote.Helper.ThirdPartyPopulated as ThirdPartyPopulated++import Data.Either+import Text.Read+import Control.Exception (evaluate)+import Control.DeepSeq+import qualified Data.Map as M+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified System.FilePath.ByteString as P++type BorgRepo = String++type BorgArchiveName = S.ByteString++remote :: RemoteType+remote = RemoteType+	{ typename = "borg"+	, enumerate = const (findSpecialRemotes "borgrepo")+	, generate = gen+	, configParser = mkRemoteConfigParser+		[ optionalStringParser borgrepoField+			(FieldDesc "(required) borg repository to use")+		, optionalStringParser subdirField+			(FieldDesc "limit to a subdirectory of the borg repository")+		, yesNoParser appendonlyField (Just False)+			(FieldDesc "you will not use borg to delete from the repository")+		]+	, setup = borgSetup+	, exportSupported = exportUnsupported+	, importSupported = importIsSupported+	, thirdPartyPopulated = True+	}++borgrepoField :: RemoteConfigField+borgrepoField = Accepted "borgrepo"++subdirField :: RemoteConfigField+subdirField = Accepted "subdir"++appendonlyField :: RemoteConfigField+appendonlyField = Accepted "appendonly"++gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs = do+	c <- parsedRemoteConfig remote rc+	cst <- remoteCost gc $+		if borgLocal borgrepo+			then nearlyCheapRemoteCost+			else expensiveRemoteCost+	return $ Just $ Remote+		{ uuid = u+		, cost = cst+		, name = Git.repoDescribe r+		, storeKey = storeKeyDummy+		, retrieveKeyFile = retrieveKeyFileDummy+		, retrieveKeyFileCheap = Nothing+		-- Borg cryptographically verifies content.+		, retrievalSecurityPolicy = RetrievalAllKeysSecure+		, removeKey = removeKeyDummy+		, lockContent = Nothing+		, checkPresent = checkPresentDummy+		, checkPresentCheap = borgLocal borgrepo+		, exportActions = exportUnsupported+		, importActions = ImportActions+			{ listImportableContents = listImportableContentsM u borgrepo c+			, importKey = Just ThirdPartyPopulated.importKey+			, retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM borgrepo+			, checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM borgrepo+			-- This remote is thirdPartyPopulated, so these+			-- actions will never be used.+			, storeExportWithContentIdentifier = storeExportWithContentIdentifier importUnsupported+			, removeExportDirectoryWhenEmpty = removeExportDirectoryWhenEmpty importUnsupported+			, removeExportWithContentIdentifier = removeExportWithContentIdentifier importUnsupported+			}+		, whereisKey = Nothing+		, remoteFsck = Nothing+		, repairRepo = Nothing+		, config = c+		, getRepo = return r+		, gitconfig = gc+		, localpath = if borgLocal borgrepo && not (null borgrepo)+			then Just borgrepo+			else Nothing+		, remotetype = remote+		, availability = if borgLocal borgrepo then LocallyAvailable else GloballyAvailable+		, readonly = False+		, appendonly = False+		-- When the user sets the appendonly field, they are+		-- promising not to delete content out from under git-annex+		-- using borg, so the remote is not untrustworthy.+		, untrustworthy = maybe True not $+			getRemoteConfigValue appendonlyField c+		, mkUnavailable = return Nothing+		, getInfo = return [("repo", borgrepo)]+		, claimUrl = Nothing+		, checkUrl = Nothing+		, remoteStateHandle = rs+		}+  where+	borgrepo = fromMaybe (giveup "missing borgrepo") $ remoteAnnexBorgRepo gc++borgSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)+borgSetup _ mu _ c _gc = do+	u <- maybe (liftIO genUUID) return mu++	-- verify configuration is sane+	let borgrepo = maybe (giveup "Specify borgrepo=") fromProposedAccepted $+		M.lookup borgrepoField c++	-- The borgrepo is stored in git config, as well as this repo's+	-- persistant state, so it can vary between hosts.+	gitConfigSpecialRemote u c [("borgrepo", borgrepo)]++	return (c, u)++borgLocal :: BorgRepo -> Bool+borgLocal = notElem ':'++borgArchive :: BorgRepo -> BorgArchiveName -> String+borgArchive r n = r ++ "::" ++ decodeBS' n++listImportableContentsM :: UUID -> BorgRepo -> ParsedRemoteConfig -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))+listImportableContentsM u borgrepo c = prompt $ do+	imported <- getImported u+	ls <- withborglist borgrepo Nothing formatarchivelist $ \as ->+		forM as $ \archivename ->+			case M.lookup archivename imported of+				Just getfast -> return $ Left (archivename, getfast)+				Nothing -> Right <$>+					let archive = borgArchive borgrepo archivename+					in withborglist archive subdir formatfilelist $+						liftIO . evaluate . force . parsefilelist archivename+	if all isLeft ls && M.null (M.difference imported (M.fromList (lefts ls)))+		then return Nothing -- unchanged since last time, avoid work+		else Just . mkimportablecontents <$> mapM (either snd pure) ls+  where+	withborglist what addparam format a = do+		let p = proc "borg" $ toCommand $ catMaybes+			[ Just (Param "list")+			, Just (Param "--format")+			, Just (Param format)+			, Just (Param what)+			, addparam+			]+		(Nothing, Just h, Nothing, pid) <- liftIO $ createProcess $ p+			{ std_out = CreatePipe }+		l <- liftIO $ map L.toStrict +			. filter (not . L.null) +			. L.split 0 +			<$> L.hGetContents h+		let cleanup = liftIO $ do+			hClose h+			forceSuccessProcess p pid+		a l `finally` cleanup++	formatarchivelist = "{barchive}{NUL}"++	formatfilelist = "{size}{NUL}{path}{NUL}"++	subdir = File <$> getRemoteConfigValue subdirField c++	parsefilelist archivename (bsz:f:rest) = case readMaybe (fromRawFilePath bsz) of+		Nothing -> parsefilelist archivename rest+		Just sz ->+			let loc = genImportLocation archivename f+			-- This does a little unncessary work to parse the +			-- key, which is then thrown away. But, it lets the+			-- file list be shrank down to only the ones that are+			-- importable keys, so avoids needing to buffer all+			-- the rest of the files in memory.+			in case ThirdPartyPopulated.importKey' loc sz of+				Just _k -> (loc, (borgContentIdentifier, sz))+					: parsefilelist archivename rest+				Nothing -> parsefilelist archivename rest+	parsefilelist _ _ = []++	-- importableHistory is not used for retrieval, so is not+	-- populated with old archives. Instead, a tree of archives+	-- is constructed, by genImportLocation including the archive+	-- name in the ImportLocation.+	mkimportablecontents l = ImportableContents+		{ importableContents = concat l+		, importableHistory = []+		}++-- We do not need a ContentIdentifier in order to retrieve a file from+-- borg; the ImportLocation contains all that's needed. So, this is left+-- empty.+borgContentIdentifier :: ContentIdentifier+borgContentIdentifier = ContentIdentifier mempty++-- Borg does not allow / in the name of an archive, so the archive+-- name will always be the first directory in the ImportLocation.+--+-- Paths in a borg archive are always relative, not absolute, so the use of+-- </> to combine the archive name with the path will always work.+genImportLocation :: BorgArchiveName -> RawFilePath -> ImportLocation+genImportLocation archivename p  = +	ThirdPartyPopulated.mkThirdPartyImportLocation $+		archivename P.</> p++extractImportLocation :: ImportLocation -> (BorgArchiveName, RawFilePath)+extractImportLocation loc = go $ P.splitDirectories $+	ThirdPartyPopulated.fromThirdPartyImportLocation loc+  where+	go (archivename:rest) = (archivename, P.joinPath rest)+	go _ = giveup $ "Unable to parse import location " ++ fromRawFilePath (fromImportLocation loc)++-- Since the ImportLocation starts with the archive name, a list of all+-- archive names we've already imported can be found by just listing the+-- last imported tree. And the contents of those archives can be retrieved+-- by listing the subtree recursively, which will likely be quite a lot+-- faster than running borg.+getImported :: UUID -> Annex (M.Map BorgArchiveName (Annex [(ImportLocation, (ContentIdentifier, ByteSize))]))+getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u)+  where+	go t = M.fromList . mapMaybe mk+		<$> inRepo (LsTree.lsTreeStrict LsTree.LsTreeNonRecursive t)+	+	mk ti+		| toTreeItemType (LsTree.mode ti) == Just TreeSubtree = Just+			( getTopFilePath (LsTree.file ti)+			, getcontents+				(getTopFilePath (LsTree.file ti))+				(LsTree.sha ti)+			)+		| otherwise = Nothing++	getcontents archivename t = mapMaybe (mkcontents archivename)+		<$> inRepo (LsTree.lsTreeStrict LsTree.LsTreeRecursive t)+	+	mkcontents archivename ti = do+		let f = ThirdPartyPopulated.fromThirdPartyImportLocation $+			mkImportLocation $ getTopFilePath $ LsTree.file ti+		k <- deserializeKey' (P.takeFileName f)+		return+			( genImportLocation archivename f+			,+				( borgContentIdentifier+				-- defaulting to 0 size is ok, this size+				-- only gets used by+				-- ThirdPartyPopulated.importKey,+				-- which ignores the size when the key+				-- does not have a size.+				, fromMaybe 0 (fromKey keySize k)+				)+			)++-- Check if the file is still there in the borg archive.+-- Does not check that the content is unchanged; we assume that +-- the content of files in borg archives does not change, which is normally+-- the case. But archives may be deleted, and files may be deleted.+checkPresentExportWithContentIdentifierM :: BorgRepo -> Key -> ImportLocation -> [ContentIdentifier] -> Annex Bool+checkPresentExportWithContentIdentifierM borgrepo _ loc _ = prompt $ liftIO $ do+	let p = proc "borg" $ toCommand+		[ Param "list"+		, Param "--format"+		, Param "1"+		, Param (borgArchive borgrepo archivename)+		, File (fromRawFilePath archivefile)+		]+	-- borg list exits nonzero with an error message if an archive+	-- no longer exists. But, the user can delete archives at any+	-- time they want. So, hide errors, and if it exists nonzero,+	-- check if the borg repository still exists, and only throw an+	-- exception if not.+	(Nothing, Just h, Nothing, pid) <- withNullHandle $ \nullh ->+		createProcess $ p+			{ std_out = CreatePipe+			, std_err = UseHandle nullh+			}+	ok <- (== "1") <$> hGetContentsStrict h+	hClose h+	ifM (checkSuccessProcess pid)+		( return ok+		, checkrepoexists+		)+  where+	(archivename, archivefile) = extractImportLocation loc+	+	checkrepoexists = do+		let p = proc "borg" $ toCommand+			[ Param "list"+			, Param "--format"+			, Param "1"+			, Param borgrepo+			]+		(Nothing, Nothing, Nothing, pid) <- withNullHandle $ \nullh ->+			createProcess $ p+				{ std_out = UseHandle nullh }+		ifM (checkSuccessProcess pid)+			( return False -- repo exists, content not in it+			, giveup $ "Unable to access borg repository " ++ borgrepo+			)++retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key+retrieveExportWithContentIdentifierM borgrepo loc _ dest mkk _ = do+	showOutput+	prompt $ withOtherTmp $ \othertmp -> liftIO $ do+		-- borgrepo could be relative, and borg has to be run+		-- in the temp directory to get it to write there+		absborgrepo <- fromRawFilePath <$> absPath (toRawFilePath borgrepo)+		let p = proc "borg" $ toCommand+			[ Param "extract"+			, Param (borgArchive absborgrepo archivename)+			, File (fromRawFilePath archivefile)+			]+		(Nothing, Nothing, Nothing, pid) <- createProcess $ p+			{ cwd = Just (fromRawFilePath othertmp) }+		forceSuccessProcess p pid+		-- Filepaths in borg archives are relative, so it's ok to+		-- combine with </>+		moveFile (fromRawFilePath othertmp </> fromRawFilePath archivefile) dest+		removeDirectoryRecursive (fromRawFilePath othertmp)+	mkk+  where+	(archivename, archivefile) = extractImportLocation loc
Remote/Bup.hs view
@@ -50,6 +50,7 @@ 	, setup = bupSetup 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  buprepoField :: RemoteConfigField@@ -94,6 +95,7 @@ 		, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable 		, readonly = False 		, appendonly = False+		, untrustworthy = False 		, mkUnavailable = return Nothing 		, getInfo = return [("repo", buprepo)] 		, claimUrl = Nothing
Remote/Ddar.hs view
@@ -45,6 +45,7 @@ 	, setup = ddarSetup 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  ddarrepoField :: RemoteConfigField@@ -97,6 +98,7 @@ 		, availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable 		, readonly = False 		, appendonly = False+		, untrustworthy = False 		, mkUnavailable = return Nothing 		, getInfo = return [("repo", ddarRepoLocation ddarrepo)] 		, claimUrl = Nothing
Remote/Directory.hs view
@@ -56,6 +56,7 @@ 	, setup = directorySetup 	, exportSupported = exportIsSupported 	, importSupported = importIsSupported+	, thirdPartyPopulated = False 	}  directoryField :: RemoteConfigField@@ -87,6 +88,7 @@ 				{ storeExport = storeExportM dir 				, retrieveExport = retrieveExportM dir 				, removeExport = removeExportM dir+				, versionedExport = False 				, checkPresentExport = checkPresentExportM dir 				-- Not needed because removeExportLocation 				-- auto-removes empty directories.@@ -113,6 +115,7 @@ 			, localpath = Just dir' 			, readonly = False 			, appendonly = False+			, untrustworthy = False 			, availability = LocallyAvailable 			, remotetype = remote 			, mkUnavailable = gen r u rc@@ -337,10 +340,10 @@ 		in go (upFrom loc') =<< tryIO (removeDirectory p)  listImportableContentsM :: RawFilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))-listImportableContentsM dir = catchMaybeIO $ liftIO $ do+listImportableContentsM dir = liftIO $ do 	l <- dirContentsRecursive (fromRawFilePath dir) 	l' <- mapM (go . toRawFilePath) l-	return $ ImportableContents (catMaybes l') []+	return $ Just $ ImportableContents (catMaybes l') []   where 	go f = do 		st <- R.getFileStatus f@@ -369,13 +372,15 @@ 	| new == Just old = cont 	| otherwise = giveup "file content has changed" -importKeyM :: RawFilePath -> ExportLocation -> ContentIdentifier -> MeterUpdate -> Annex Key-importKeyM dir loc cid p = do+importKeyM :: RawFilePath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key)+importKeyM dir loc cid sz p = do 	backend <- chooseBackend f-	k <- fst <$> genKey ks p backend+	unsizedk <- fst <$> genKey ks p backend+	let k = alterKey unsizedk $ \kd -> kd+		{ keySize = keySize kd <|> Just sz } 	currcid <- liftIO $ mkContentIdentifier absf 		=<< R.getFileStatus absf-	guardSameContentIdentifiers (return k) cid currcid+	guardSameContentIdentifiers (return (Just k)) cid currcid   where 	f = fromExportLocation loc 	absf = dir P.</> f
Remote/External.hs view
@@ -53,6 +53,7 @@ 	, setup = externalSetup 	, exportSupported = checkExportSupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  externaltypeField :: RemoteConfigField@@ -81,7 +82,7 @@ 	| otherwise = do 		c <- parsedRemoteConfig remote rc 		external <- newExternal externaltype (Just u) c (Just gc) (Just rs)-		Annex.addCleanup (RemoteCleanup u) $ stopExternal external+		Annex.addCleanupAction (RemoteCleanup u) $ stopExternal external 		cst <- getCost external r gc 		avail <- getAvailability external r gc 		exportsupported <- if exportTree c@@ -92,6 +93,7 @@ 				{ storeExport = storeExportM external 				, retrieveExport = retrieveExportM external 				, removeExport = removeExportM external+				, versionedExport = False 				, checkPresentExport = checkPresentExportM external 				, removeExportDirectory = Just $ removeExportDirectoryM external 				, renameExport = renameExportM external@@ -142,6 +144,7 @@ 			, gitconfig = gc 			, readonly = False 			, appendonly = False+			, untrustworthy = False 			, availability = avail 			, remotetype = remote  				{ exportSupported = cheapexportsupported }@@ -619,7 +622,8 @@ 				`onException` store UncheckedExternalAsync 			if asyncExtensionEnabled extensions 				then do-					relay <- liftIO $ runRelayToExternalAsync external st+					annexrunner <- Annex.makeRunner+					relay <- liftIO $ runRelayToExternalAsync external st annexrunner 					st' <- liftIO $ asyncRelayExternalState relay 					store (ExternalAsync relay) 					return st'
Remote/External/AsyncExtension.hs view
@@ -11,9 +11,10 @@ module Remote.External.AsyncExtension (runRelayToExternalAsync) where  import Common+import Annex import Messages import Remote.External.Types-import Utility.SimpleProtocol as Proto+import qualified Utility.SimpleProtocol as Proto  import Control.Concurrent.Async import Control.Concurrent.STM@@ -23,13 +24,13 @@ -- | Starts a thread that will handle all communication with the external -- process. The input ExternalState communicates directly with the external -- process.-runRelayToExternalAsync :: External -> ExternalState -> IO ExternalAsyncRelay-runRelayToExternalAsync external st = do+runRelayToExternalAsync :: External -> ExternalState -> (Annex () -> IO ()) -> IO ExternalAsyncRelay+runRelayToExternalAsync external st annexrunner = do 	jidmap <- newTVarIO M.empty 	sendq <- newSendQueue 	nextjid <- newTVarIO (JobId 1)-	void $ async $ sendloop st sendq-	void $ async $ receiveloop external st jidmap sendq+	sender <- async $ sendloop st sendq+	receiver <- async $ receiveloop external st jidmap sendq sender annexrunner 	return $ ExternalAsyncRelay $ do 		receiveq <- newReceiveQueue 		jid <- atomically $ do@@ -44,7 +45,7 @@ 					(toAsyncWrapped msg, jid) 			, externalReceive = atomically (readTBMChan receiveq) 			-- This shuts down the whole relay.-			, externalShutdown = shutdown external st sendq+			, externalShutdown = shutdown external st sendq sender receiver 			-- These three TMVars are shared amoung all 			-- ExternalStates that use this relay; they're 			-- common state about the external process.@@ -65,14 +66,14 @@ newSendQueue :: IO SendQueue newSendQueue = newTBMChanIO 10 -receiveloop :: External -> ExternalState -> JidMap -> SendQueue -> IO ()-receiveloop external st jidmap sendq = externalReceive st >>= \case+receiveloop :: External -> ExternalState -> JidMap -> SendQueue -> Async () -> (Annex () -> IO ()) -> IO ()+receiveloop external st jidmap sendq sendthread annexrunner = externalReceive st >>= \case 	Just l -> case parseMessage l :: Maybe AsyncMessage of 		Just (AsyncMessage jid msg) -> 			M.lookup jid <$> readTVarIO jidmap >>= \case 				Just c -> do 					atomically $ writeTBMChan c msg-					receiveloop external st jidmap sendq+					receiveloop external st jidmap sendq sendthread annexrunner 				Nothing -> protoerr "unknown job number" 		Nothing -> case parseMessage l :: Maybe ExceptionalMessage of 			Just _ -> do@@ -80,16 +81,17 @@ 				m <- readTVarIO jidmap 				forM_ (M.elems m) $ \c -> 					atomically  $ writeTBMChan c l-				receiveloop external st jidmap sendq+				receiveloop external st jidmap sendq sendthread annexrunner 			Nothing -> protoerr "unexpected non-async message" 	Nothing -> closeandshutdown   where 	protoerr s = do-		warningIO $ "async external special remote protocol error: " ++ s+		annexrunner $ warning $ "async external special remote protocol error: " ++ s 		closeandshutdown 	 	closeandshutdown = do-		shutdown external st sendq True+		dummy <- async noop+		shutdown external st sendq sendthread dummy True 		m <- atomically $ readTVar jidmap 		forM_ (M.elems m) (atomically . closeTBMChan) @@ -110,8 +112,15 @@   where 	wrapjid msg jid = AsyncMessage jid $ unwords $ Proto.formatMessage msg -shutdown :: External -> ExternalState -> SendQueue -> Bool -> IO ()-shutdown external st sendq b = do+shutdown :: External -> ExternalState -> SendQueue -> Async () -> Async () -> Bool -> IO ()+shutdown external st sendq sendthread receivethread b = do+	-- Receive thread is normally blocked reading from a handle.+	-- That can block closing the handle, so it needs to be canceled.+	cancel receivethread+	-- Cleanly shutdown the send thread as well, allowing it to finish+	-- writing anything that was buffered.+	atomically $ closeTBMChan sendq+	wait sendthread 	r <- atomically $ do 		r <- tryTakeTMVar (externalAsync external)  		putTMVar (externalAsync external)@@ -120,4 +129,3 @@ 	case r of 		Just (ExternalAsync _) -> externalShutdown st b 		_ -> noop-	atomically $ closeTBMChan sendq
Remote/GCrypt.hs view
@@ -78,6 +78,7 @@ 	, setup = gCryptSetup 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  gitRepoField :: RemoteConfigField@@ -152,6 +153,7 @@ 		, gitconfig = gc 		, readonly = Git.repoIsHttp r 		, appendonly = False+		, untrustworthy = False 		, availability = availabilityCalc r 		, remotetype = remote 		, mkUnavailable = return Nothing
Remote/Git.hs view
@@ -87,6 +87,7 @@ 	, setup = gitSetup 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  locationField :: RemoteConfigField@@ -204,6 +205,7 @@ 			, gitconfig = gc 			, readonly = Git.repoIsHttp r 			, appendonly = False+			, untrustworthy = False 			, availability = availabilityCalc r 			, remotetype = remote 			, mkUnavailable = unavailable r u rc gc rs@@ -339,7 +341,7 @@ 			Annex.BranchState.disableUpdate 			catchNonAsync autoInitialize $ \e -> 				warning $ "remote " ++ Git.repoDescribe r ++-					" :"  ++ show e+					":"  ++ show e 			Annex.getState Annex.repo 		s <- Annex.new r 		Annex.eval s $ check `finally` stopCoProcesses@@ -690,7 +692,7 @@ 				copier <- mkCopier hardlink st params 				let verify = Annex.Content.RemoteVerify r 				let rsp = RetrievalAllKeysSecure-				res <- Annex.Content.getViaTmp rsp verify key file $ \dest ->+				res <- logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest -> 					metered (Just (combineMeterUpdate meterupdate p)) key $ \_ p' ->  						copier object (fromRawFilePath dest) p' (liftIO checksuccessio) 				Annex.Content.saveState True@@ -832,7 +834,7 @@ commitOnCleanup :: Git.Repo -> Remote -> State -> Annex a -> Annex a commitOnCleanup repo r st a = go `after` a   where-	go = Annex.addCleanup (RemoteCleanup $ uuid r) cleanup+	go = Annex.addCleanupAction (RemoteCleanup $ uuid r) cleanup 	cleanup 		| not $ Git.repoIsUrl repo = onLocalFast st $ 			doQuietSideAction $
Remote/GitLFS.hs view
@@ -74,6 +74,7 @@ 	, setup = mySetup 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  urlField :: RemoteConfigField@@ -132,6 +133,7 @@ 		, readonly = False 		-- content cannot be removed from a git-lfs repo 		, appendonly = True+		, untrustworthy = False 		, mkUnavailable = return Nothing 		, getInfo = gitRepoInfo (this c cst h) 		, claimUrl = Nothing
Remote/Glacier.hs view
@@ -48,6 +48,7 @@ 	, setup = glacierSetup 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  datacenterField :: RemoteConfigField@@ -98,6 +99,7 @@ 			, localpath = Nothing 			, readonly = False 			, appendonly = False+			, untrustworthy = False 			, availability = GloballyAvailable 			, remotetype = remote 			, mkUnavailable = return Nothing
Remote/Helper/Chunked/Legacy.hs view
@@ -85,8 +85,8 @@  - But this is the best that can be done with the storer interface that  - writes a whole L.ByteString at a time.  -}-storeChunked :: ChunkSize -> [FilePath] -> (FilePath -> L.ByteString -> IO ()) -> L.ByteString -> IO [FilePath]-storeChunked chunksize dests storer content = +storeChunked :: (Annex () -> IO ()) -> ChunkSize -> [FilePath] -> (FilePath -> L.ByteString -> IO ()) -> L.ByteString -> IO [FilePath]+storeChunked annexrunner chunksize dests storer content =  	either onerr return =<< tryNonAsync (go (Just chunksize) dests)   where 	go _ [] = return [] -- no dests!?@@ -99,7 +99,7 @@ 		| otherwise = storechunks sz [] dests content 		 	onerr e = do-		warningIO (show e)+		annexrunner $ warning (show e) 		return [] 	 	storechunks _ _ [] _ = return [] -- ran out of dests
Remote/Helper/Encryptable.hs view
@@ -20,6 +20,7 @@ 	cipherKey, 	extractCipher, 	isEncrypted,+	encryptionIsEnabled, 	describeEncryption, 	encryptionField, 	highRandomQualityField@@ -281,6 +282,14 @@  isEncrypted :: ParsedRemoteConfig -> Bool isEncrypted = isJust . extractCipher++-- Check if encryption is enabled. This can be done before encryption+-- is fully set up yet, so the cipher might not be present yet.+encryptionIsEnabled :: ParsedRemoteConfig -> Bool+encryptionIsEnabled c = case getRemoteConfigValue encryptionField c of+	Nothing -> False+	Just NoneEncryption -> False+	Just _ -> True  describeEncryption :: ParsedRemoteConfig -> String describeEncryption c = case extractCipher c of
Remote/Helper/ExportImport.hs view
@@ -14,7 +14,7 @@ import Types.Key import Types.ProposedAccepted import Backend-import Remote.Helper.Encryptable (isEncrypted)+import Remote.Helper.Encryptable (encryptionIsEnabled) import qualified Database.Export as Export import qualified Database.ContentIdentifier as ContentIdentifier import Annex.Export@@ -39,6 +39,7 @@ 		, retrieveExport = nope 		, checkPresentExport = \_ _ -> return False 		, removeExport = nope+		, versionedExport = False 		, removeExportDirectory = nope 		, renameExport = \_ _ _ -> return Nothing 		}@@ -54,7 +55,7 @@  instance HasImportUnsupported (ImportActions Annex) where 	importUnsupported = ImportActions-		{ listImportableContents = return Nothing+		{ listImportableContents = nope 		, importKey = Nothing 		, retrieveExportWithContentIdentifier = nope 		, storeExportWithContentIdentifier = nope@@ -72,7 +73,7 @@ importIsSupported = \_ _ -> return True  -- | Prevent or allow exporttree=yes and importtree=yes when--- setting up a new remote, depending on exportSupported and importSupported.+-- setting up a new remote, depending on the remote's capabilities. adjustExportImportRemoteType :: RemoteType -> RemoteType adjustExportImportRemoteType rt = rt { setup = setup' }   where@@ -80,10 +81,10 @@ 		pc <- either giveup return . parseRemoteConfig c 			=<< configParser rt c 		let checkconfig supported configured configfield cont =-			ifM (supported rt pc gc)+			ifM (supported rt pc gc <&&> pure (not (thirdPartyPopulated rt))) 				( case st of 					Init-						| configured pc && isEncrypted pc ->+						| configured pc && encryptionIsEnabled pc -> 							giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield 						| otherwise -> cont 					Enable oldc -> do@@ -97,161 +98,171 @@ 				) 		checkconfig exportSupported exportTree exportTreeField $ 			checkconfig importSupported importTree importTreeField $-				if importTree pc && not (exportTree pc)-					then giveup "cannot enable importtree=yes without also enabling exporttree=yes"-					else setup rt st mu cp c gc+				setup rt st mu cp c gc --- | Adjust a remote to support exporttree=yes and importree=yes.------ Note that all remotes with importree=yes also have exporttree=yes.+-- | Adjust a remote to support exporttree=yes and/or importree=yes. adjustExportImport :: Remote -> RemoteStateHandle -> Annex Remote-adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) of-	Nothing -> return $ notexport r-	Just True -> ifM (isExportSupported r)-		( do-			exportdbv <- prepexportdb-			r' <- isexport exportdbv-			if importTree (config r)-				then isimport r' exportdbv-				else return r'-		, return $ notexport r-		)-	Just False -> return $ notexport r-  where-	notexport r' = notimport r'-		{ exportActions = exportUnsupported-		, remotetype = (remotetype r')-			{ exportSupported = exportUnsupported-			}-		}-	-	notimport r' = r'-		{ importActions = importUnsupported-		, remotetype = (remotetype r')-			{ importSupported = importUnsupported+adjustExportImport r rs = do+	isexport <- pure (exportTree (config r))+		<&&> isExportSupported r+	-- When thirdPartyPopulated is True, the remote+	-- does not need to be configured with importTree to support+	-- imports.+	isimport <- pure (importTree (config r) || thirdPartyPopulated (remotetype r))+		<&&> isImportSupported r+	let r' = r+		{ remotetype = (remotetype r)+			{ exportSupported = if isexport+				then exportSupported (remotetype r)+				else exportUnsupported+			, importSupported = if isimport+				then importSupported (remotetype r)+				else importUnsupported 			} 		}-	-	isimport r' exportdbv = do-		ciddbv <- prepciddb--		let keycids k = do-			db <- getciddb ciddbv-			liftIO $ ContentIdentifier.getContentIdentifiers db rs k--		let checkpresent k loc = -			checkPresentExportWithContentIdentifier-				(importActions r')-				k loc -				=<< keycids k--		return $ r'-			{ exportActions = (exportActions r')-				{ storeExport = \f k loc p -> do-					db <- getciddb ciddbv-					exportdb <- getexportdb exportdbv-					oldks <- liftIO $ Export.getExportTreeKey exportdb loc-					oldcids <- liftIO $ concat-						<$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks-					newcid <- storeExportWithContentIdentifier (importActions r') f k loc oldcids p-					withExclusiveLock gitAnnexContentIdentifierLock $ do-						liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k-						liftIO $ ContentIdentifier.flushDbQueue db-					recordContentIdentifier rs newcid k-				, removeExport = \k loc ->-					removeExportWithContentIdentifier (importActions r') k loc-						=<< keycids k-				, removeExportDirectory = removeExportDirectoryWhenEmpty (importActions r')-				-- renameExport is optional, and the-				-- remote's implementation may-				-- lose modifications to the file-				-- (by eg copying and then deleting)-				-- so don't use it-				, renameExport = \_ _ _ -> return Nothing-				, checkPresentExport = checkpresent-				}-			, checkPresent = if appendonly r'-				then checkPresent r'-				else \k -> anyM (checkpresent k)-					=<< getexportlocs exportdbv k-			, getInfo = do-				is <- getInfo r'-				return (is++[("import", "yes")])-			}+	if not isexport && not isimport+		then return r'+		else adjustExportImport' isexport isimport r' rs -	isexport dbv = return $ r-		-- Storing a key on an export could be implemented,-		-- but it would perform unncessary work-		-- when another repository has already stored the-		-- key, and the local repository does not know-		-- about it. To avoid unnecessary costs, don't do it.-		{ storeKey = \_ _ _ ->-			giveup "remote is configured with exporttree=yes; use `git-annex export` to store content on it"-		-- Keys can be retrieved using retrieveExport, -		-- but since that retrieves from a path in the-		-- remote that another writer could have replaced-		-- with content not of the requested key,-		-- the content has to be strongly verified.-		---		-- appendonly remotes have a key/value store,-		-- so don't need to use retrieveExport. However,-		-- fall back to it if retrieveKeyFile fails.+adjustExportImport' :: Bool -> Bool -> Remote -> RemoteStateHandle -> Annex Remote+adjustExportImport' isexport isimport r rs = do+	dbv <- prepdbv+	ciddbv <- prepciddb+	let versioned = versionedExport (exportActions r)+	return $ r+		{ exportActions = if isexport+			then if isimport+				then exportActionsForImport dbv ciddbv (exportActions r)+				else exportActions r+			else exportUnsupported+		, importActions = if isimport+			then importActions r+			else importUnsupported+		, storeKey = \k af p ->+			-- Storing a key on an export could be implemented,+			-- but it would perform unncessary work+			-- when another repository has already stored the+			-- key, and the local repository does not know+			-- about it. To avoid unnecessary costs, don't do it.+			if thirdpartypopulated+				then giveup "remote is not populated by git-annex"+				else if isexport+					then giveup "remote is configured with exporttree=yes; use `git-annex export` to store content on it"+					else if isimport+						then giveup "remote is configured with importtree=yes and without exporttree=yes; cannot modify content stored on it"+						else storeKey r k af p+		, removeKey = \k -> +			-- Removing a key from an export would need to+			-- change the tree in the export log to not include+			-- the file. Otherwise, conflicts when removing+			-- files would not be dealt with correctly.+			-- There does not seem to be a good use case for+			-- removing a key from an export in any case.+			if thirdpartypopulated+				then giveup "dropping content from this remote is not supported"+				else if isexport+					then giveup "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove"+					else if isimport+						then giveup "dropping content from this remote is not supported because it is configured with importtree=yes"+						else removeKey r k+		, lockContent = if versioned+			then lockContent r+			else Nothing 		, retrieveKeyFile = \k af dest p ->-			let retrieveexport = retrieveKeyFileFromExport dbv k af dest p-			in if appendonly r-				then retrieveKeyFile r k af dest p-					`catchNonAsync` const retrieveexport-				else retrieveexport-		, retrieveKeyFileCheap = if appendonly r+			if isimport+				then supportversionedretrieve k af dest p $+					retrieveKeyFileFromImport dbv ciddbv k af dest p+				else if isexport+					then supportversionedretrieve k af dest p $+						retrieveKeyFileFromExport dbv k af dest p+					else retrieveKeyFile r k af dest p+		, retrieveKeyFileCheap = if versioned 			then retrieveKeyFileCheap r 			else Nothing-		-- Removing a key from an export would need to-		-- change the tree in the export log to not include-		-- the file. Otherwise, conflicts when removing-		-- files would not be dealt with correctly.-		-- There does not seem to be a good use case for-		-- removing a key from an export in any case.-		, removeKey = \_k -> giveup "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove"-		-- Can't lock content on exports, since they're-		-- not key/value stores, and someone else could-		-- change what's exported to a file at any time.-		---		-- (except for appendonly remotes)-		, lockContent = if appendonly r-			then lockContent r-			else Nothing-		-- Check if any of the files a key was exported to-		-- are present. This doesn't guarantee the export-		-- contains the right content, which is why export-		-- remotes are untrusted.-		---		-- (but appendonly remotes work the same as any-		-- non-export remote)-		, checkPresent = if appendonly r-			then checkPresent r-			else \k -> anyM (checkPresentExport (exportActions r) k)-				=<< getexportlocs dbv k+		, checkPresent = \k -> if versioned+			then checkPresent r k+			else if isimport+				then anyM (checkPresentImport ciddbv k)+					=<< getanyexportlocs dbv k+				else if isexport+					-- Check if any of the files a key+					-- was exported to are present. This +					-- doesn't guarantee the export+					-- contains the right content,+					-- if the remote is an export,+					-- or if something else can write+					-- to it. Remotes that have such +					-- problems are made untrusted,+					-- so it's not worried about here.+					then anyM (checkPresentExport (exportActions r) k)+						=<< getanyexportlocs dbv k+					else checkPresent r k 		-- checkPresent from an export is more expensive 		-- than otherwise, so not cheap. Also, this 		-- avoids things that look at checkPresentCheap and 		-- silently skip non-present files from behaving 		-- in confusing ways when there's an export-		-- conflict.+		-- conflict (or an import conflict). 		, checkPresentCheap = False+		-- Export/import remotes can lose content stored on them in+		-- many ways. This is not a problem with versioned+		-- ones though, since they still allow accessing by Key.+		-- And for thirdPartyPopulated, it depends on how the+		-- content gets actually stored in the remote, so+		-- is not overriddden here.+		, untrustworthy =+			if versioned || thirdPartyPopulated (remotetype r)+				then untrustworthy r+				else False+		-- git-annex testremote cannot be used to test+		-- import/export since it stores keys. 		, mkUnavailable = return Nothing 		, getInfo = do-			ts <- map fromRef . exportedTreeishes-				<$> getExport (uuid r) 			is <- getInfo r-			return (is++[("export", "yes"), ("exportedtree", unwords ts)])+			is' <- if isexport && not thirdpartypopulated+				then do+					ts <- map fromRef . exportedTreeishes+						<$> getExport (uuid r)+					return (is++[("exporttree", "yes"), ("exportedtree", unwords ts)])+				else return is+			return $ if isimport && not thirdpartypopulated+				then (is'++[("importtree", "yes")])+				else is' 		}+  where+	thirdpartypopulated = thirdPartyPopulated (remotetype r) +	-- exportActions adjusted to use the equivilant import actions,+	-- which take ContentIdentifiers into account.+	exportActionsForImport dbv ciddbv ea = ea+  		{ storeExport = \f k loc p -> do+			db <- getciddb ciddbv+			exportdb <- getexportdb dbv+			oldks <- liftIO $ Export.getExportTreeKey exportdb loc+			oldcids <- liftIO $ concat+				<$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks+			newcid <- storeExportWithContentIdentifier (importActions r) f k loc oldcids p+			withExclusiveLock gitAnnexContentIdentifierLock $ do+				liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k+				liftIO $ ContentIdentifier.flushDbQueue db+			recordContentIdentifier rs newcid k+		, removeExport = \k loc ->+			removeExportWithContentIdentifier (importActions r) k loc+				=<< getkeycids ciddbv k+		, removeExportDirectory = removeExportDirectoryWhenEmpty (importActions r)+		-- renameExport is optional, and the remote's+		-- implementation may lose modifications to the file+		-- (by eg copying and then deleting) so don't use it+		, renameExport = \_ _ _ -> return Nothing+		, checkPresentExport = checkPresentImport ciddbv+		}+	 	prepciddb = do 		lcklckv <- liftIO newEmptyTMVarIO 		dbtv <- liftIO newEmptyTMVarIO 		return (dbtv, lcklckv) 	-	prepexportdb = do+	prepdbv = do 		lcklckv <- liftIO newEmptyTMVarIO 		dbv <- liftIO newEmptyTMVarIO 		exportinconflict <- liftIO $ newTVarIO False@@ -306,20 +317,63 @@ 				liftIO $ atomically $ 					writeTVar exportinconflict True 		-	getexportlocs dbv k = do+	getanyexportlocs dbv k = do 		db <- getexportdb dbv 		liftIO $ Export.getExportTree db k+	+	getfirstexportloc dbv k = do+		getexportlocs dbv k >>= \case+			[] -> giveup "unknown export location"+			(l:_) -> return l+	+	getexportlocs dbv k = do+		db <- getexportdb dbv+		liftIO $ Export.getExportTree db k >>= \case+			[] -> ifM (atomically $ readTVar $ getexportinconflict dbv)+				( giveup "unknown export location, likely due to the export conflict"+				, return []+				)+			ls -> return ls+		+	getkeycids ciddbv k = do+		db <- getciddb ciddbv+		liftIO $ ContentIdentifier.getContentIdentifiers db rs k +	-- Keys can be retrieved using retrieveExport, but since that+	-- retrieves from a path in the remote that another writer could+	-- have replaced with content not of the requested key, the content+	-- has to be strongly verified. 	retrieveKeyFileFromExport dbv k _af dest p = ifM (isVerifiable k) 		( do-			locs <- getexportlocs dbv k-			case locs of-				[] -> ifM (liftIO $ atomically $ readTVar $ getexportinconflict dbv)-					( giveup "unknown export location, likely due to the export conflict"-					, giveup "unknown export location"-					)-				(l:_) -> do-					retrieveExport (exportActions r) k l dest p-					return UnVerified+			l <- getfirstexportloc dbv k+			retrieveExport (exportActions r) k l dest p+			return MustVerify 		, giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend" 		)+	+	retrieveKeyFileFromImport dbv ciddbv k af dest p =+		getkeycids ciddbv k >>= \case+			(cid:_) -> do+				l <- getfirstexportloc dbv k+				void $ retrieveExportWithContentIdentifier (importActions r) l cid dest (pure k) p+				return UnVerified+			-- In case a content identifier is somehow missing,+			-- try this instead.+			[] -> if isexport+				then retrieveKeyFileFromExport dbv k af dest p+				else giveup "no content identifier is recorded, unable to retrieve"+	+	-- versionedExport remotes have a key/value store, so can use+	-- the usual retrieveKeyFile, rather than an import/export+	-- variant. However, fall back to that if retrieveKeyFile fails.+	supportversionedretrieve k af dest p a+		| versionedExport (exportActions r) =+			retrieveKeyFile r k af dest p+				`catchNonAsync` const a+		| otherwise = a++	checkPresentImport ciddbv k loc =+		checkPresentExportWithContentIdentifier+			(importActions r)+			k loc +			=<< getkeycids ciddbv k
Remote/Helper/Hooks.hs view
@@ -76,7 +76,7 @@ 		-- So, requiring idempotency is the right approach. 		run starthook -		Annex.addCleanup (StopHook $ uuid r) $ runstop lck+		Annex.addCleanupAction (StopHook $ uuid r) $ runstop lck 	runstop lck = do 		-- Drop any shared lock we have, and take an 		-- exclusive lock, without blocking. If the lock
+ Remote/Helper/ThirdPartyPopulated.hs view
@@ -0,0 +1,86 @@+{- Helpers for thirdPartyPopulated remotes+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Remote.Helper.ThirdPartyPopulated where++import Annex.Common+import Types.Remote+import Types.Import+import Crypto (isEncKey)+import Utility.Metered++import qualified System.FilePath.ByteString as P+import qualified Data.ByteString as S++-- When a remote is thirdPartyPopulated, the files we want are probably+-- in the .git directory. But, git does not really support .git in paths+-- in a git tree. (Such a tree can be built, but it will lead to problems.)+-- And so anything in .git is prevented from being imported.+-- To work around that, this renames that directory when generating an+-- ImportLocation.+mkThirdPartyImportLocation :: RawFilePath -> ImportLocation+mkThirdPartyImportLocation =+	mkImportLocation . P.joinPath . map esc . P.splitDirectories+  where+	esc ".git" = "dotgit"+	esc x+		| "dotgit" `S.isSuffixOf` x = "dot" <> x+		| otherwise = x++fromThirdPartyImportLocation :: ImportLocation -> RawFilePath+fromThirdPartyImportLocation =+	P.joinPath . map unesc . P.splitDirectories . fromImportLocation+  where+	unesc "dotgit" = ".git"+	unesc x+		| "dotgit" `S.isSuffixOf` x = S.drop 3 x+		| otherwise = x++-- When a remote is thirdPartyPopulated, and contains a backup of a+-- git-annex repository or some special remotes, this can be used to+-- find only those ImportLocations that are annex object files.+-- All other ImportLocations are ignored.+importKey :: ImportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key)+importKey loc _cid sz _ = return $ importKey' loc sz++importKey' :: ImportLocation -> ByteSize -> Maybe Key+importKey' loc sz = case deserializeKey' f of+	Just k+		-- Annex objects always are in a subdirectory with the same+		-- name as the filename. If this is not the case for the file+		-- that was backed up, it is probably not a valid annex object.+		-- Eg, it could be something in annex/bad/, or annex/tmp/.+		-- Or it could be a file that only happens to have a name+		-- like an annex object.+		-- (This does unfortunately prevent recognizing files that are+		-- part of special remotes that don't use that layout. The most+		-- likely special remote to be in a backup, the directory+		-- special remote, does use that layout at least.)+		| lastMaybe (P.splitDirectories (P.dropFileName p)) /= Just f -> Nothing+		-- Chunked or encrypted keys used in special remotes are not+		-- supported.+		| isChunkKey k || isEncKey k -> Nothing+		-- Check that the size of the key is the same as the size of the+		-- file stored in the backup. This is a cheap way to make sure it's+		-- probabably the actual content of the file. We don't fully+		-- verify the content here because that could be a very +		-- expensive operation for a large repository; if the user+		-- wants to detect every possible data corruption problem+		-- (eg, wrong data read off disk during backup, or the object+		-- was corrupt in the git-annex repo and that bad object got+		-- backed up), they can fsck the remote.+		| otherwise -> case fromKey keySize k of+			Just sz'+				| sz' == sz -> Just k+				| otherwise -> Nothing+			Nothing -> Just k+	Nothing -> Nothing+  where+	p = fromImportLocation loc+	f = P.takeFileName p
Remote/Hook.hs view
@@ -40,6 +40,7 @@ 	, setup = hookSetup 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  hooktypeField :: RemoteConfigField@@ -79,6 +80,7 @@ 			, gitconfig = gc 			, readonly = False 			, appendonly = False+			, untrustworthy = False 			, availability = GloballyAvailable 			, remotetype = remote 			, mkUnavailable = gen r u rc
Remote/HttpAlso.hs view
@@ -41,6 +41,7 @@ 	, setup = httpAlsoSetup 	, exportSupported = exportIsSupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  urlField :: RemoteConfigField@@ -72,6 +73,7 @@ 			{ storeExport = cannotModify 			, retrieveExport = retriveExportHttpAlso url 			, removeExport = cannotModify+			, versionedExport = False 			, checkPresentExport = checkPresentExportHttpAlso url 			, removeExportDirectory = Nothing 			, renameExport = cannotModify@@ -86,6 +88,7 @@ 		, getRepo = return r 		, readonly = True 		, appendonly = False+		, untrustworthy = False 		, availability = GloballyAvailable 		, remotetype = remote 		, mkUnavailable = return Nothing
Remote/List.hs view
@@ -36,6 +36,7 @@ import qualified Remote.Ddar import qualified Remote.GitLFS import qualified Remote.HttpAlso+import qualified Remote.Borg import qualified Remote.Hook import qualified Remote.External @@ -57,6 +58,7 @@ 	, Remote.Ddar.remote 	, Remote.GitLFS.remote 	, Remote.HttpAlso.remote+	, Remote.Borg.remote 	, Remote.Hook.remote 	, Remote.External.remote 	]
Remote/P2P.hs view
@@ -41,6 +41,7 @@ 	, setup = error "P2P remotes are set up using git-annex p2p" 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)@@ -73,6 +74,7 @@ 		, gitconfig = gc 		, readonly = False 		, appendonly = False+		, untrustworthy = False 		, availability = GloballyAvailable 		, remotetype = remote 		, mkUnavailable = return Nothing
Remote/Rsync.hs view
@@ -60,6 +60,7 @@ 	, setup = rsyncSetup 	, exportSupported = exportIsSupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  shellEscapeField :: RemoteConfigField@@ -100,6 +101,7 @@ 				{ storeExport = storeExportM o 				, retrieveExport = retrieveExportM o 				, removeExport = removeExportM o+				, versionedExport = False 				, checkPresentExport = checkPresentExportM o 				, removeExportDirectory = Just (removeExportDirectoryM o) 				, renameExport = renameExportM o@@ -116,6 +118,7 @@ 				else Nothing 			, readonly = False 			, appendonly = False+			, untrustworthy = False 			, availability = if islocal then LocallyAvailable else GloballyAvailable 			, remotetype = remote 			, mkUnavailable = return Nothing
Remote/S3.hs view
@@ -118,6 +118,7 @@ 	, setup = s3Setup 	, exportSupported = exportIsSupported 	, importSupported = importIsSupported+	, thirdPartyPopulated = False 	}  bucketField :: RemoteConfigField@@ -209,6 +210,7 @@ 				{ storeExport = storeExportS3 hdl this rs info magic 				, retrieveExport = retrieveExportS3 hdl this info 				, removeExport = removeExportS3 hdl this rs info+				, versionedExport = versioning info 				, checkPresentExport = checkPresentExportS3 hdl this info 				-- S3 does not have directories. 				, removeExportDirectory = Nothing@@ -231,7 +233,8 @@ 			, gitconfig = gc 			, localpath = Nothing 			, readonly = False-			, appendonly = versioning info+			, appendonly = False+			, untrustworthy = False 			, availability = GloballyAvailable 			, remotetype = remote 			, mkUnavailable = gen r u (M.insert hostField (Proposed "!dne!") rc) gc rs@@ -552,12 +555,11 @@ listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) listImportableContentsS3 hv r info = 	withS3Handle hv $ \case-		Nothing -> do-			warning $ needS3Creds (uuid r)-			return Nothing-		Just h -> catchMaybeIO $ liftIO $ runResourceT $-			extractFromResourceT =<< startlist h+		Nothing -> giveup $ needS3Creds (uuid r)+		Just h -> Just <$> go h   where+	go h = liftIO $ runResourceT $ extractFromResourceT =<< startlist h+ 	startlist h 		| versioning info = do 			rsp <- sendS3Handle h $ @@ -656,7 +658,10 @@ 				S3.getObject (bucket info) o 		k <- mkkey 		case extractContentIdentifier cid o of-			Right vid -> setS3VersionID info rs k vid+			Right vid -> do+				vids <- getS3VersionID rs k+				unless (vid `elem` map Just vids) $+					setS3VersionID info rs k vid 			Left _ -> noop 		return k 	Nothing -> giveup $ needS3Creds (uuid r)@@ -1132,7 +1137,7 @@ -- version id involves a request for an object, so this keeps track of what -- the object is. data S3VersionID = S3VersionID S3.Object T.Text-	deriving (Show)+	deriving (Show, Eq)  -- smart constructor mkS3VersionID :: S3.Object -> Maybe T.Text -> Maybe S3VersionID
Remote/Tahoe.hs view
@@ -67,6 +67,7 @@ 	, setup = tahoeSetup 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  scsField :: RemoteConfigField@@ -106,6 +107,7 @@ 		, localpath = Nothing 		, readonly = False 		, appendonly = False+		, untrustworthy = False 		, availability = GloballyAvailable 		, remotetype = remote 		, mkUnavailable = return Nothing
Remote/Web.hs view
@@ -32,6 +32,7 @@ 	, setup = error "not supported" 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  -- There is only one web remote, and it always exists.@@ -71,6 +72,7 @@ 		, getRepo = return r 		, readonly = True 		, appendonly = False+		, untrustworthy = False 		, availability = GloballyAvailable 		, remotetype = remote 		, mkUnavailable = return Nothing
Remote/WebDAV.hs view
@@ -28,6 +28,7 @@ import Types.Remote import Types.Export import qualified Git+import qualified Annex import Config import Config.Cost import Annex.SpecialRemote.Config@@ -56,6 +57,7 @@ 	, setup = webdavSetup 	, exportSupported = exportIsSupported 	, importSupported = importUnsupported+	, thirdPartyPopulated = False 	}  urlField :: RemoteConfigField@@ -98,6 +100,7 @@ 				, retrieveExport = retrieveExportDav hdl 				, checkPresentExport = checkPresentExportDav hdl this 				, removeExport = removeExportDav hdl+				, versionedExport = False 				, removeExportDirectory = Just $ 					removeExportDirectoryDav hdl 				, renameExport = renameExportDav hdl@@ -112,6 +115,7 @@ 			, localpath = Nothing 			, readonly = False 			, appendonly = False+			, untrustworthy = False 			, availability = GloballyAvailable 			, remotetype = remote 			, mkUnavailable = gen r u (M.insert urlField (Proposed "http://!dne!/") rc) gc rs@@ -139,8 +143,9 @@  store :: DavHandleVar -> ChunkConfig -> Storer store hv (LegacyChunks chunksize) = fileStorer $ \k f p -> -	withDavHandle hv $ \dav -> liftIO $-		withMeteredFile f p $ storeLegacyChunked chunksize k dav+	withDavHandle hv $ \dav -> do+		annexrunner <- Annex.makeRunner+		liftIO $ withMeteredFile f p $ storeLegacyChunked annexrunner chunksize k dav store hv _ = httpStorer $ \k reqbody ->  	withDavHandle hv $ \dav -> liftIO $ goDAV dav $ do 		let tmp = keyTmpLocation k@@ -448,15 +453,15 @@ -- Legacy chunking code, to be removed eventually. -- -storeLegacyChunked :: ChunkSize -> Key -> DavHandle -> L.ByteString -> IO ()-storeLegacyChunked chunksize k dav b =+storeLegacyChunked :: (Annex () -> IO ()) -> ChunkSize -> Key -> DavHandle -> L.ByteString -> IO ()+storeLegacyChunked annexrunner chunksize k dav b = 	Legacy.storeChunks k tmp dest storer recorder finalizer   where 	storehttp l b' = void $ goDAV dav $ do 		maybe noop (void . mkColRecursive) (locationParent l) 		debugDav $ "putContent " ++ l 		inLocation l $ putContentM (contentType, b')-	storer locs = Legacy.storeChunked chunksize locs storehttp b+	storer locs = Legacy.storeChunked annexrunner chunksize locs storehttp b 	recorder l s = storehttp l (L8.fromString s) 	finalizer tmp' dest' = goDAV dav $  		finalizeStore dav tmp' (fromJust $ locationParent dest')
Types/CleanupActions.hs view
@@ -1,6 +1,6 @@ {- Enumeration of cleanup actions  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -8,9 +8,10 @@ module Types.CleanupActions where  import Types.UUID- import Utility.Url +import System.Process (Pid)+ data CleanupAction 	= RemoteCleanup UUID 	| StopHook UUID@@ -19,4 +20,8 @@ 	| AdjustedBranchUpdate 	| TorrentCleanup URLString 	| OtherTmpCleanup+	deriving (Eq, Ord)++data SignalAction+	= PropagateSignalProcessGroup Pid 	deriving (Eq, Ord)
Types/FileMatcher.hs view
@@ -18,10 +18,13 @@ import qualified Data.Map as M import qualified Data.Set as S --- Information about a file or a key that can be matched on.+-- Information about a file and/or a key that can be matched on. data MatchInfo 	= MatchingFile FileInfo 	| MatchingKey Key AssociatedFile+	-- ^ This is used when matching a file that may be in another+	-- branch. The AssociatedFile is the filename, but it should not be+	-- accessed from disk when matching. 	| MatchingInfo ProvidedInfo 	| MatchingUserInfo UserProvidedInfo @@ -30,7 +33,11 @@ 	-- ^ path to a file containing the content, for operations 	-- that examine it 	, matchFile :: RawFilePath-	-- ^ filepath to match on; may be relative to top of repo or cwd+	-- ^ filepath to match on; may be relative to top of repo or cwd,+	-- depending on how globs in preferred content expressions+	-- are intended to be matched+	, matchKey :: Maybe Key+	-- ^ provided if a key is already known 	}  data ProvidedInfo = ProvidedInfo
Types/GitConfig.hs view
@@ -41,6 +41,7 @@ import Types.Difference import Types.RefSpec import Types.RepoVersion+import Types.StallDetection import Config.DynamicConfig import Utility.HumanTime import Utility.Gpg (GpgCmd, mkGpgCmd)@@ -116,6 +117,7 @@ 	, annexRetry :: Maybe Integer 	, annexForwardRetry :: Maybe Integer 	, annexRetryDelay :: Maybe Seconds+	, annexStallDetection :: Maybe StallDetection 	, annexAllowedUrlSchemes :: S.Set Scheme 	, annexAllowedIPAddresses :: String 	, annexAllowUnverifiedDownloads :: Bool@@ -202,6 +204,9 @@ 	, annexForwardRetry = getmayberead (annexConfig "forward-retry") 	, annexRetryDelay = Seconds 		<$> getmayberead (annexConfig "retrydelay")+	, annexStallDetection =+		either (const Nothing) Just . parseStallDetection+			=<< getmaybe (annexConfig "stalldetection") 	, annexAllowedUrlSchemes = S.fromList $ map mkScheme $ 		maybe ["http", "https", "ftp"] words $ 			getmaybe (annexConfig "security.allowed-url-schemes")@@ -306,6 +311,7 @@ 	, remoteAnnexRetry :: Maybe Integer 	, remoteAnnexForwardRetry :: Maybe Integer 	, remoteAnnexRetryDelay :: Maybe Seconds+	, remoteAnnexStallDetection :: Maybe StallDetection 	, remoteAnnexAllowUnverifiedDownloads :: Bool 	, remoteAnnexConfigUUID :: Maybe UUID @@ -321,6 +327,7 @@ 	, remoteAnnexGnupgDecryptOptions :: [String] 	, remoteAnnexRsyncUrl :: Maybe String 	, remoteAnnexBupRepo :: Maybe String+	, remoteAnnexBorgRepo :: Maybe String 	, remoteAnnexTahoe :: Maybe FilePath 	, remoteAnnexBupSplitOptions :: [String] 	, remoteAnnexDirectory :: Maybe FilePath@@ -369,6 +376,9 @@ 		, remoteAnnexForwardRetry = getmayberead "forward-retry" 		, remoteAnnexRetryDelay = Seconds 			<$> getmayberead "retrydelay"+		, remoteAnnexStallDetection =+			either (const Nothing) Just . parseStallDetection+				=<< getmaybe "stalldetection" 		, remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ 			getmaybe ("security-allow-unverified-downloads") 		, remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid"@@ -382,6 +392,7 @@ 		, remoteAnnexGnupgDecryptOptions = getoptions "gnupg-decrypt-options" 		, remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl" 		, remoteAnnexBupRepo = getmaybe "buprepo"+		, remoteAnnexBorgRepo = getmaybe "borgrepo" 		, remoteAnnexTahoe = getmaybe "tahoe" 		, remoteAnnexBupSplitOptions = getoptions "bup-split-options" 		, remoteAnnexDirectory = notempty $ getmaybe "directory"
Types/Import.hs view
@@ -31,7 +31,14 @@  {- An identifier for content stored on a remote that has been imported into  - the repository. It should be reasonably short since it is stored in the- - git-annex branch. -}+ - git-annex branch.+ -+ - Since other things than git-annex can modify files on import remotes,+ - and git-annex then be used to import those modifications, the+ - ContentIdentifier needs to change when a file gets changed in such a+ - way. Device, inode, and size is one example of a good content+ - identifier. Or a hash if the remote's interface exposes hashes.+ -} newtype ContentIdentifier = ContentIdentifier S.ByteString 	deriving (Eq, Ord, Show, Generic) @@ -52,6 +59,12 @@ 	-- ^ Used by remotes that support importing historical versions of 	-- files that are stored in them. This is equivilant to a git 	-- commit history.+	--+	-- When retrieving a historical version of a file,+	-- old ImportLocations from importableHistory are not used;+	-- the content is no longer expected to be present at those+	-- locations. So, if a remote does not support Key/Value access,+	-- it should not populate the importableHistory. 	} 	deriving (Show, Generic)
Types/Key.hs view
@@ -11,6 +11,7 @@ 	KeyData(..), 	Key, 	fromKey,+	keyData, 	mkKey, 	alterKey, 	isKeyPrefix,@@ -201,7 +202,7 @@  {- A filename may be associated with a Key. -} newtype AssociatedFile = AssociatedFile (Maybe RawFilePath)-	deriving (Show, Eq, Ord)+	deriving (Show, Read, Eq, Ord)  {- There are several different varieties of keys. -} data KeyVariety
Types/Messages.hs view
@@ -1,6 +1,6 @@ {- git-annex Messages data types  - - - Copyright 2012-2018 Joey Hess <id@joeyh.name>+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -8,12 +8,20 @@ module Types.Messages where  import qualified Utility.Aeson as Aeson+import Utility.Metered  import Control.Concurrent import System.Console.Regions (ConsoleRegion)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L -data OutputType = NormalOutput | QuietOutput | JSONOutput JSONOptions-	deriving (Show)+data OutputType+	= NormalOutput+	| QuietOutput+	| JSONOutput JSONOptions+	| SerializedOutput+		(SerializedOutput -> IO ())+		(IO (Maybe SerializedOutputResponse))  data JSONOptions = JSONOptions 	{ jsonProgress :: Bool@@ -53,3 +61,24 @@ 		, jsonBuffer = Nothing 		, promptLock = promptlock 		}++-- | When communicating with a child process over a pipe while it is+-- performing some action, this is used to pass back output that the child+-- would normally display to the console.+data SerializedOutput+	= OutputMessage S.ByteString+	| OutputError String+	| BeginProgressMeter+	| UpdateProgressMeterTotalSize TotalSize+	| UpdateProgressMeter BytesProcessed+	| EndProgressMeter+	| BeginPrompt+	| EndPrompt+	| JSONObject L.ByteString+	-- ^ This is always sent, it's up to the consumer to decide if it+	-- wants to display JSON, or human-readable messages.+	deriving (Show)++data SerializedOutputResponse+	= ReadyPrompt+	deriving (Eq, Show)
Types/RefSpec.hs view
@@ -22,7 +22,7 @@ 	| RemoveMatching Glob  allRefSpec :: RefSpec-allRefSpec = [AddMatching $ compileGlob "*" CaseSensative]+allRefSpec = [AddMatching $ compileGlob "*" CaseSensative (GlobFilePath False)]  parseRefSpec :: String -> Either String RefSpec parseRefSpec v = case partitionEithers (map mk $ splitc ':' v) of@@ -31,9 +31,9 @@   where 	mk ('+':s) 		| any (`elem` s) "*?" =-			Right $ AddMatching $ compileGlob s CaseSensative+			Right $ AddMatching $ compileGlob s CaseSensative (GlobFilePath False) 		| otherwise = Right $ AddRef $ Ref $ encodeBS s-	mk ('-':s) = Right $ RemoveMatching $ compileGlob s CaseSensative+	mk ('-':s) = Right $ RemoveMatching $ compileGlob s CaseSensative (GlobFilePath False) 	mk "reflog" = Right AddRefLog 	mk s = Left $ "bad refspec item \"" ++ s ++ "\" (expected + or - prefix)"
Types/Remote.hs view
@@ -67,6 +67,11 @@ 	, exportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool 	-- check if a remote of this type is able to support import 	, importSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool+	-- is a remote of this type not a usual key/value store,+	-- or export/import of a tree of files, but instead a collection+	-- of files, populated by something outside git-annex, some of+	-- which may be annex objects?+	, thirdPartyPopulated :: Bool 	}  instance Eq (RemoteTypeA a) where@@ -113,9 +118,9 @@ 	-- Some remotes can checkPresent without an expensive network 	-- operation. 	, checkPresentCheap :: Bool-	-- Some remotes support export of trees.+	-- Some remotes support export. 	, exportActions :: ExportActions a-	-- Some remotes support import of trees.+	-- Some remotes support import. 	, importActions :: ImportActions a 	-- Some remotes can provide additional details for whereis. 	, whereisKey :: Maybe (Key -> a [String])@@ -136,10 +141,15 @@ 	-- a Remote can be known to be readonly 	, readonly :: Bool 	-- a Remote can allow writes but not have a way to delete content-	-- from it. Note that an export remote that supports removeExport-	-- to remove a file from the exported tree, but still retains the-	-- content in accessible form should set this to True.+	-- from it. 	, appendonly :: Bool+	-- Set if a remote cannot be trusted to continue to contain the+	-- contents of files stored there. Notably, most export/import+	-- remotes are untrustworthy because they are not key/value stores.+	-- Since this prevents the user from adjusting a remote's trust+	-- level, it's often better not not set it and instead let the user+	-- decide.+	, untrustworthy :: Bool 	-- a Remote can be globally available. (Ie, "in the cloud".) 	, availability :: Availability 	-- the type of the remote@@ -192,6 +202,7 @@ 	| MustVerify 	-- ^ Content likely to have been altered during transfer, 	-- verify even if verification is normally disabled+	deriving (Show)  unVerified :: Monad m => m a -> m (a, Verification) unVerified a = do@@ -245,6 +256,10 @@ 	-- Can throw exception if unable to access remote, or if remote 	-- refuses to remove the content. 	, removeExport :: Key -> ExportLocation -> a ()+	-- Set when the content of a Key stored in the remote to an+	-- ExportLocation and then removed with removeExport remains+	-- accessible to retrieveKeyFile and checkPresent.+	, versionedExport :: Bool 	-- Removes an exported directory. Typically the directory will be 	-- empty, but it could possibly contain files or other directories, 	-- and it's ok to delete those (but not required to). @@ -257,7 +272,9 @@ 	-- the remote refuses to let the directory be removed. 	, removeExportDirectory :: Maybe (ExportDirectory -> a ()) 	-- Checks if anything is exported to the remote at the specified-	-- ExportLocation.+	-- ExportLocation. It may check the size or other characteristics+	-- of the Key, but does not need to guarantee that the content on+	-- the remote is the same as the Key's content. 	-- Throws an exception if the remote cannot be accessed. 	, checkPresentExport :: Key -> ExportLocation -> a Bool 	-- Renames an already exported file.@@ -275,9 +292,13 @@ 	-- 	-- May also find old versions of files that are still stored in the 	-- remote.+	--+	-- Throws exception on failure to access the remote.+	-- May return Nothing when the remote is unchanged since last time. 	{ listImportableContents :: a (Maybe (ImportableContents (ContentIdentifier, ByteSize)))-	-- Imports a file from the remote, without downloading it,-	-- by generating a Key (of any type).+	-- Generates a Key (of any type) for the file stored on the+	-- remote at the ImportLocation. Does not download the file+	-- from the remote. 	-- 	-- May update the progress meter if it needs to perform an 	-- expensive operation, such as hashing a local file.@@ -286,8 +307,13 @@ 	-- bearing in mind that the file on the remote may have changed 	-- since the ContentIdentifier was generated. 	---	-- Throws exception on failure.-	, importKey :: Maybe (ExportLocation -> ContentIdentifier -> MeterUpdate -> a Key)+	-- When the remote is thirdPartyPopulated, this should check if the+	-- file stored on the remote is the content of an annex object,+	-- and return its Key, or Nothing if it is not. Should not+	-- otherwise return Nothing.+	--+	-- Throws exception on failure to access the remote.+	, importKey :: Maybe (ImportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> a (Maybe Key)) 	-- Retrieves a file from the remote. Ensures that the file 	-- it retrieves has the requested ContentIdentifier. 	--
+ Types/StallDetection.hs view
@@ -0,0 +1,29 @@+{- types for stall detection+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.StallDetection where++import Utility.DataUnits+import Utility.HumanTime+import Utility.Misc++-- Unless the given number of bytes have been sent over the given+-- amount of time, there's a stall.+data StallDetection = StallDetection ByteSize Duration+	deriving (Show)++-- Parse eg, "0KiB/60s"+parseStallDetection :: String -> Either String StallDetection+parseStallDetection s = +	let (bs, ds) = separate (== '/') s+	in do+		b <- maybe +			(Left $ "Unable to parse stall detection amount " ++ bs)+			Right+			(readSize dataUnits bs)+		d <- parseDuration ds+		return (StallDetection b d)
+ Types/Transferrer.hs view
@@ -0,0 +1,159 @@+{- protocol used by "git-annex transferrer"+ -+ - Copyright 2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.Transferrer where++import Annex.Common+import Types.Messages+import Git.Types (RemoteName)+import qualified Utility.SimpleProtocol as Proto+import Utility.Format+import Utility.Metered (TotalSize(..))++import Data.Char++-- Sent to start a transfer.+data TransferRequest+	= UploadRequest TransferRemote Key TransferAssociatedFile+	| DownloadRequest TransferRemote Key TransferAssociatedFile+	| AssistantUploadRequest TransferRemote Key TransferAssociatedFile+	| AssistantDownloadRequest TransferRemote Key TransferAssociatedFile+	deriving (Show)++transferRequestRemote :: TransferRequest -> TransferRemote+transferRequestRemote (UploadRequest r _ _) = r+transferRequestRemote (DownloadRequest r _ _) = r+transferRequestRemote (AssistantUploadRequest r _ _) = r+transferRequestRemote (AssistantDownloadRequest r _ _) = r++data TransferRemote+	= TransferRemoteUUID UUID+	| TransferRemoteName RemoteName+	deriving (Show, Eq)++newtype TransferAssociatedFile = TransferAssociatedFile AssociatedFile+	deriving (Show)++data TransferResponse+	= TransferOutput SerializedOutput+	-- ^ any number may be sent before TransferResult+	| TransferResult Bool+	deriving (Show)++data TransferSerializedOutputResponse = TransferSerializedOutputResponse SerializedOutputResponse+	deriving (Show)++instance Proto.Sendable TransferRequest where+	formatMessage (UploadRequest r kd af) =+		[ "u"+		, Proto.serialize r+		, Proto.serialize kd+		, Proto.serialize af+		]+	formatMessage (DownloadRequest r kd af) =+		[ "d"+		, Proto.serialize r+		, Proto.serialize kd+		, Proto.serialize af+		]+	formatMessage (AssistantUploadRequest r kd af) =+		[ "au"+		, Proto.serialize r+		, Proto.serialize kd+		, Proto.serialize af+		]+	formatMessage (AssistantDownloadRequest r kd af) =+		[ "ad"+		, Proto.serialize r+		, Proto.serialize kd+		, Proto.serialize af+		]++instance Proto.Receivable TransferRequest where+	parseCommand "u" = Proto.parse3 UploadRequest+	parseCommand "d" = Proto.parse3 DownloadRequest+	parseCommand "au" = Proto.parse3 AssistantUploadRequest+	parseCommand "ad" = Proto.parse3 AssistantDownloadRequest+	parseCommand _ = Proto.parseFail++instance Proto.Sendable TransferResponse where+	formatMessage (TransferOutput (OutputMessage m)) =+		["om", Proto.serialize (encode_c (decodeBS m))]+	formatMessage (TransferOutput (OutputError e)) =+		["oe", Proto.serialize (encode_c e)]+	formatMessage (TransferOutput BeginProgressMeter) =+		["opb"]+	formatMessage (TransferOutput (UpdateProgressMeterTotalSize (TotalSize sz))) =+		["ops", Proto.serialize sz]+	formatMessage (TransferOutput (UpdateProgressMeter n)) =+		["op", Proto.serialize n]+	formatMessage (TransferOutput EndProgressMeter) =+		["ope"]+	formatMessage (TransferOutput BeginPrompt) =+		["oprb"]+	formatMessage (TransferOutput EndPrompt) =+		["opre"]+	formatMessage (TransferOutput (JSONObject b)) =+		["oj", Proto.serialize (encode_c (decodeBL b))]+	formatMessage (TransferResult True) =+		["t"]+	formatMessage (TransferResult False) =+		["f"]++instance Proto.Receivable TransferResponse where+	parseCommand "om" = Proto.parse1 $+		TransferOutput . OutputMessage . encodeBS . decode_c+	parseCommand "oe" = Proto.parse1 $+		TransferOutput . OutputError . decode_c+	parseCommand "opb" = Proto.parse0 $+		TransferOutput BeginProgressMeter+	parseCommand "ops" = Proto.parse1 $+		TransferOutput . UpdateProgressMeterTotalSize . TotalSize+	parseCommand "op" = Proto.parse1 $+		TransferOutput . UpdateProgressMeter+	parseCommand "ope" = Proto.parse0 $+		TransferOutput EndProgressMeter+	parseCommand "oprb" = Proto.parse0 $+		TransferOutput BeginPrompt+	parseCommand "opre" = Proto.parse0 $+		TransferOutput EndPrompt+	parseCommand "oj" = Proto.parse1 $+		TransferOutput . JSONObject . encodeBL . decode_c+	parseCommand "t" = Proto.parse0 $+		TransferResult True+	parseCommand "f" = Proto.parse0 $+		TransferResult False+	parseCommand _ = Proto.parseFail++instance Proto.Sendable TransferSerializedOutputResponse where+	formatMessage (TransferSerializedOutputResponse ReadyPrompt) = ["opr"]++instance Proto.Receivable TransferSerializedOutputResponse where+	parseCommand "opr" = Proto.parse0 (TransferSerializedOutputResponse ReadyPrompt)+	parseCommand _ = Proto.parseFail++instance Proto.Serializable TransferRemote where+	serialize (TransferRemoteUUID u) = 'u':fromUUID u+	-- A remote name could contain whitespace or newlines, which needs+	-- to be escaped for the protocol. Use C-style encoding.+	serialize (TransferRemoteName r) = 'r':encode_c' isSpace r++	deserialize ('u':u) = Just (TransferRemoteUUID (toUUID u))+	deserialize ('r':r) = Just (TransferRemoteName (decode_c r))+	deserialize _ = Nothing++instance Proto.Serializable TransferAssociatedFile where+	-- Comes last, so whitespace is ok. But, in case the filename+	-- contains eg a newline, escape it. Use C-style encoding.+	serialize (TransferAssociatedFile (AssociatedFile (Just f))) =+		encode_c (fromRawFilePath f)+	serialize (TransferAssociatedFile (AssociatedFile Nothing)) = ""++	deserialize "" = Just $ TransferAssociatedFile $+		AssociatedFile Nothing+	deserialize s = Just $ TransferAssociatedFile $+		AssociatedFile $ Just $ toRawFilePath $ decode_c s
+ Types/TransferrerPool.hs view
@@ -0,0 +1,59 @@+{- A pool of "git-annex transfer" processes available for use+ -+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.TransferrerPool where++import Common++import Control.Concurrent.STM hiding (check)++type TransferrerPool = TVar [TransferrerPoolItem]++type CheckTransferrer = IO Bool+type MkCheckTransferrer = IO (IO Bool)++{- Each item in the pool may have a transferrer running, and has an+ - IO action that can be used to check if it's still ok to use the+ - transferrer. -}+data TransferrerPoolItem = TransferrerPoolItem (Maybe Transferrer) CheckTransferrer++data Transferrer = Transferrer+	{ transferrerRead :: Handle+	, transferrerWrite :: Handle+	, transferrerHandle :: ProcessHandle+	, transferrerShutdown :: IO ()+	-- ^ Closes the FDs and waits for the process to exit. +	-- Should be used when the transferrer is in between transfers,+	-- as otherwise it may not shutdown promptly.+	}++newTransferrerPool :: IO TransferrerPool+newTransferrerPool = newTVarIO []++popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int)+popTransferrerPool p = do+	l <- readTVar p+	case l of+		[] -> return (Nothing, 0)+		(i:is) -> do+			writeTVar p is+			return $ (Just i, length is)++pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM ()+pushTransferrerPool p i = do+	l <- readTVar p+	let l' = i:l+	writeTVar p l'++{- Note that making a CheckTransferrer may allocate resources,+ - such as a NotificationHandle, so it's important that the returned+ - TransferrerPoolItem is pushed into the pool, and not left to be+ - garbage collected. -}+mkTransferrerPoolItem :: MkCheckTransferrer -> Transferrer -> IO TransferrerPoolItem+mkTransferrerPoolItem mkcheck t = do+	check <- mkcheck+	return $ TransferrerPoolItem (Just t) check
+ Types/VectorClock.hs view
@@ -0,0 +1,29 @@+{- git-annex vector clocks+ -+ - We don't have a way yet to keep true distributed vector clocks.+ - The next best thing is a timestamp.+ -+ - Copyright 2017-2020 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.VectorClock where++import Data.Time.Clock.POSIX+import Control.Applicative+import Prelude++import Utility.QuickCheck++-- | Some very old logs did not have any time stamp at all;+-- Unknown is used for those.+data VectorClock = Unknown | VectorClock POSIXTime+	deriving (Eq, Ord, Show)++-- Unknown is oldest.+prop_VectorClock_sane :: Bool+prop_VectorClock_sane = Unknown < VectorClock 1++instance Arbitrary  VectorClock where+	arbitrary = VectorClock <$> arbitrary
Upgrade.hs view
@@ -103,10 +103,9 @@ 	-- upgrading a git repo other than the current repo. 	upgraderemote = do 		rp <- fromRawFilePath <$> fromRepo Git.repoPath-		gitAnnexChildProcess-			[ "upgrade"-			, "--quiet"-			, "--autoonly"+		gitAnnexChildProcess "upgrade"+			[ Param "--quiet"+			, Param "--autoonly" 			] 			(\p -> p { cwd = Just rp }) 			(\_ _ _ pid -> waitForProcess pid >>= return . \case
Utility/Batch.hs view
@@ -10,6 +10,7 @@ module Utility.Batch ( 	batch, 	BatchCommandMaker,+	nonBatchCommandMaker, 	getBatchCommandMaker, 	toBatchCommand, 	batchCommand,@@ -49,6 +50,9 @@ {- Makes a command be run by whichever of nice, ionice, and nocache  - are available in the path. -} type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam])++nonBatchCommandMaker :: BatchCommandMaker+nonBatchCommandMaker = id  getBatchCommandMaker :: IO BatchCommandMaker getBatchCommandMaker = do
Utility/Format.hs view
@@ -12,6 +12,7 @@ 	formatContainsVar, 	decode_c, 	encode_c,+	encode_c', 	prop_encode_c_decode_c_roundtrip ) where @@ -52,7 +53,7 @@   where 	expand (Const s) = s 	expand (Var name j esc)-		| esc = justify j $ encode_c_strict $ getvar name+		| esc = justify j $ encode_c' isSpace $ getvar name 		| otherwise = justify j $ getvar name 	getvar name = fromMaybe "" $ M.lookup name vars 	justify UnJustified s        = s@@ -162,10 +163,7 @@ encode_c :: String -> FormatString encode_c = encode_c' (const False) -{- Encodes more strictly, including whitespace. -}-encode_c_strict :: String -> FormatString-encode_c_strict = encode_c' isSpace-+{- Encodes special characters, as well as any matching the predicate. -} encode_c' :: (Char -> Bool) -> String -> FormatString encode_c' p = concatMap echar   where@@ -183,8 +181,8 @@ 		| ord c < 0x20 = e_asc c -- low ascii 		| ord c >= 256 = e_utf c -- unicode 		| ord c > 0x7E = e_asc c -- high ascii-		| p c          = e_asc c -- unprintable ascii-		| otherwise    = [c]     -- printable ascii+		| p c          = e_asc c+		| otherwise    = [c] 	-- unicode character is decomposed to individual Word8s, 	-- and each is shown in octal 	e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8])
Utility/Glob.hs view
@@ -1,15 +1,17 @@-{-# LANGUAGE PackageImports #-}- {- file globbing  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -} +{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}+ module Utility.Glob ( 	Glob, 	GlobCase(..),+	GlobFilePath(..), 	compileGlob, 	matchGlob ) where@@ -24,26 +26,42 @@  data GlobCase = CaseSensative | CaseInsensative +-- Is the glob being used to match filenames? +--+-- When matching filenames,+-- a single path separator (eg /) in the glob will match any+-- number of path separators in the filename.+-- And on Windows, both / and \ are used as path separators, so compile+-- the glob to a regexp that matches either path separator.+newtype GlobFilePath = GlobFilePath Bool+ {- Compiles a glob to a regex, that can be repeatedly used. -}-compileGlob :: String -> GlobCase -> Glob-compileGlob glob globcase = Glob $+compileGlob :: String -> GlobCase -> GlobFilePath -> Glob+compileGlob glob globcase globfilepath = Glob $ 	case compile (defaultCompOpt {caseSensitive = casesentitive}) defaultExecOpt regex of 		Right r -> r 		Left _ -> giveup $ "failed to compile regex: " ++ regex   where-	regex = '^' : wildToRegex glob ++ "$"+	regex = '^' : wildToRegex globfilepath glob ++ "$" 	casesentitive = case globcase of 		CaseSensative -> True 		CaseInsensative -> False -wildToRegex :: String -> String-wildToRegex = concat . go+wildToRegex :: GlobFilePath -> String -> String+wildToRegex (GlobFilePath globfile) = concat . go   where 	go [] = [] 	go ('*':xs) = ".*" : go xs 	go ('?':xs) = "." : go xs 	go ('[':'!':xs) = "[^" : inpat xs 	go ('[':xs) = "[" : inpat xs+#ifdef mingw32_HOST_OS+	go ('/':xs) | globfile = "[/\\]+" : go xs+	go ('\\':xs) | globfile = "[/\\]+" : go xs+#else+	go ('/':xs) | globfile = "[/]+" : go xs+	go ('\\':xs) | globfile = "[\\]+" : go xs+#endif 	go (x:xs) 		| isDigit x || isAlpha x = [x] : go xs 		| otherwise = esc x : go xs
Utility/HumanTime.hs view
@@ -45,7 +45,9 @@  {- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} parseDuration :: String -> Either String Duration-parseDuration d = maybe parsefail (Right . Duration) $ go 0 d+parseDuration d+	| null d = parsefail+	| otherwise = maybe parsefail (Right . Duration) $ go 0 d   where 	go n [] = return n 	go n s = do
Utility/Metered.hs view
@@ -9,6 +9,7 @@  module Utility.Metered ( 	MeterUpdate,+	MeterState(..), 	nullMeterUpdate, 	combineMeterUpdate, 	TotalSize(..),@@ -77,7 +78,7 @@  {- Total number of bytes processed so far. -} newtype BytesProcessed = BytesProcessed Integer-	deriving (Eq, Ord, Show)+	deriving (Eq, Ord, Show, Read)  class AsBytesProcessed a where 	toBytesProcessed :: a -> BytesProcessed@@ -169,8 +170,9 @@ 		c <- S.hGet h (nextchunksize (fromBytesProcessed sofar)) 		if S.null c 			then do-				hClose h-				return $ L.empty+				when (wantsize /= Just 0) $+					hClose h+				return L.empty 			else do 				let !sofar' = addBytesProcessed sofar (S.length c) 				meterupdate sofar'@@ -240,6 +242,7 @@ type ProgressParser = String -> (Maybe BytesProcessed, Maybe TotalSize, String)  newtype TotalSize = TotalSize Integer+	deriving (Show, Eq)  {- Runs a command and runs a ProgressParser on its output, in order  - to update a meter.@@ -279,8 +282,8 @@ 				let s = decodeBS b 				let (mbytes, mtotalsize, buf') = progressparser (buf++s) 				sendtotalsize' <- case (sendtotalsize, mtotalsize) of-					(Just meter, Just (TotalSize n)) -> do-						setMeterTotalSize meter n+					(Just meter, Just t) -> do+						setMeterTotalSize meter t 						return Nothing 					_ -> return sendtotalsize 				case mbytes of@@ -366,7 +369,7 @@ 	return $ mu lastupdate   where 	mu lastupdate n@(BytesProcessed i) = readMVar totalsizev >>= \case-		Just t | i >= t -> meterupdate n+		Just (TotalSize t) | i >= t -> meterupdate n 		_ -> do 			now <- getPOSIXTime 			prev <- takeMVar lastupdate@@ -376,33 +379,39 @@ 					meterupdate n 				else putMVar lastupdate prev -data Meter = Meter (MVar (Maybe Integer)) (MVar MeterState) (MVar String) DisplayMeter+data Meter = Meter (MVar (Maybe TotalSize)) (MVar MeterState) (MVar String) DisplayMeter -type MeterState = (BytesProcessed, POSIXTime)+data MeterState = MeterState+	{ meterBytesProcessed :: BytesProcessed+	, meterTimeStamp :: POSIXTime+	} deriving (Show) -type DisplayMeter = MVar String -> Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> IO ()+type DisplayMeter = MVar String -> Maybe TotalSize -> MeterState -> MeterState -> IO () -type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String+type RenderMeter = Maybe TotalSize -> MeterState -> MeterState -> String  -- | Make a meter. Pass the total size, if it's known.-mkMeter :: Maybe Integer -> DisplayMeter -> IO Meter-mkMeter totalsize displaymeter = Meter-	<$> newMVar totalsize-	<*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime)-	<*> newMVar ""-	<*> pure displaymeter+mkMeter :: Maybe TotalSize -> DisplayMeter -> IO Meter+mkMeter totalsize displaymeter = do+	ts <- getPOSIXTime+	Meter+		<$> newMVar totalsize+		<*> newMVar (MeterState zeroBytesProcessed ts)+		<*> newMVar ""+		<*> pure displaymeter -setMeterTotalSize :: Meter -> Integer -> IO ()+setMeterTotalSize :: Meter -> TotalSize -> IO () setMeterTotalSize (Meter totalsizev _ _ _) = void . swapMVar totalsizev . Just  -- | Updates the meter, displaying it if necessary. updateMeter :: Meter -> MeterUpdate updateMeter (Meter totalsizev sv bv displaymeter) new = do 	now <- getPOSIXTime-	(old, before) <- swapMVar sv (new, now)-	when (old /= new) $ do+	let curms = MeterState new now+	oldms <- swapMVar sv curms+	when (meterBytesProcessed oldms /= new) $ do 		totalsize <- readMVar totalsizev-		displaymeter bv totalsize (old, before) (new, now)+		displaymeter bv totalsize oldms curms  -- | Display meter to a Handle. displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter@@ -427,7 +436,7 @@ -- or when total size is not known: --   1.3 MiB      300 KiB/s bandwidthMeter :: RenderMeter-bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) =+bandwidthMeter mtotalsize (MeterState (BytesProcessed old) before) (MeterState (BytesProcessed new) now) = 	unwords $ catMaybes 		[ Just percentamount 		-- Pad enough for max width: "100%  xxxx.xx KiB  xxxx KiB/s"@@ -438,7 +447,7 @@   where 	amount = roughSize' memoryUnits True 2 new 	percentamount = case mtotalsize of-		Just totalsize ->+		Just (TotalSize totalsize) -> 			let p = showPercentage 0 $ 				percentage totalsize (min new totalsize) 			in p ++ replicate (6 - length p) ' ' ++ amount@@ -450,7 +459,7 @@ 	transferred = max 0 (new - old) 	duration = max 0 (now - before) 	estimatedcompletion = case mtotalsize of-		Just totalsize+		Just (TotalSize totalsize) 			| bytespersecond > 0 ->  				Just $ fromDuration $ Duration $ 					(totalsize - new) `div` bytespersecond
Utility/Process.hs view
@@ -34,7 +34,7 @@ ) where  import qualified Utility.Process.Shim-import Utility.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(..), CmdSpec(..), proc, getPid, getProcessExitCode, shell, terminateProcess)+import Utility.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(..), CmdSpec(..), proc, getPid, getProcessExitCode, shell, terminateProcess, interruptProcessGroupOf) import Utility.Misc import Utility.Exception import Utility.Monad
Utility/SimpleProtocol.hs view
@@ -1,6 +1,6 @@ {- Simple line-based protocols.  -- - Copyright 2013-2016 Joey Hess <id@joeyh.name>+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -19,12 +19,15 @@ 	parse1, 	parse2, 	parse3,+	parse4,+	parse5, 	dupIoHandles, 	getProtocolLine, ) where  import Data.Char import GHC.IO.Handle+import Text.Read  import Common @@ -52,11 +55,15 @@ 	serialize = id 	deserialize = Just +instance Serializable Integer where+	serialize = show+	deserialize = readMaybe+ instance Serializable ExitCode where 	serialize ExitSuccess = "0" 	serialize (ExitFailure n) = show n 	deserialize "0" = Just ExitSuccess-	deserialize s = ExitFailure <$> readish s+	deserialize s = ExitFailure <$> readMaybe s  {- Parsing the parameters of messages. Using the right parseN ensures  - that the string is split into exactly the requested number of words,@@ -85,6 +92,21 @@   where 	(p1, rest) = splitWord s 	(p2, p3) = splitWord rest++parse4 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4) => (p1 -> p2 -> p3 -> p4 -> a) -> Parser a+parse4 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4+  where+	(p1, rest) = splitWord s+	(p2, rest') = splitWord rest+	(p3, p4) = splitWord rest'++parse5 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4, Serializable p5) => (p1 -> p2 -> p3 -> p4 -> p5 -> a) -> Parser a+parse5 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4 <*> deserialize p5+  where+	(p1, rest) = splitWord s+	(p2, rest') = splitWord rest+	(p3, rest'') = splitWord rest'+	(p4, p5) = splitWord rest''  splitWord :: String -> (String, String) splitWord = separate isSpace
doc/git-annex-export.mdwn view
@@ -1,6 +1,6 @@ # NAME -git-annex export - export content to a remote+git-annex export - export a tree of files to a special remote  # SYNOPSIS
doc/git-annex-import.mdwn view
@@ -1,6 +1,6 @@ # NAME -git-annex import - add a tree of files to the repository+git-annex import - import files from a special remote  # SYNOPSIS
doc/git-annex-sync.mdwn view
@@ -113,7 +113,7 @@   import changes from the remote, merge them into the branch, and export   any changes that have been committed to the branch back to the remote.   With --no-content, imports will only be made from special remotes that-  support importing without transferting files, and no exports will be done.+  support importing without transferring files, and no exports will be done.   See [[git-annex-import]](1) and [[git-annex-export]](1) for details   about how importing and exporting work.
doc/git-annex-transferkeys.mdwn view
@@ -1,6 +1,6 @@ # NAME -git-annex transferkeys - transfers keys+git-annex transferkeys - transfers keys (deprecated)  # SYNOPSIS @@ -8,19 +8,17 @@  # DESCRIPTION -This plumbing-level command is used by the assistant to transfer data.+This plumbing-level command is used to transfer data, by the assistant+in git-annex version 8.20201127 and older. It is still included only+to prevent breakage during upgrades.+ It is a long-running process, which is fed instructions about the keys to transfer using an internal stdio protocol, which is intentionally not documented (as it may change at any time). -It's normal to have a transferkeys process running when the assistant is-running.- # SEE ALSO  [[git-annex]](1)--[[git-annex-assistant]](1)  # AUTHOR
doc/git-annex.mdwn view
@@ -631,9 +631,15 @@      See [[git-annex-transferkey]](1) for details. +* `transferrer`+  +  Used internally by git-annex to transfer content.++  See [[git-annex-transferrer]](1) for details.+ * `transferkeys`   -  Used internally by the assistant.+  Used internally by old versions of the assistant.    See [[git-annex-transferkey]](1) for details. @@ -831,7 +837,12 @@ # CONFIGURATION  Like other git commands, git-annex is configured via `.git/config`.+These settings, as well as relevant git config settings, are+the ones git-annex uses. +(Some of these settings can also be set, across all clones of the+repository, using [[git-annex-config]]. See its man page for a list.)+ * `annex.uuid`    A unique UUID for this repository (automatically set).@@ -908,7 +919,7 @@    Used to configure which files are large enough to be added to the annex.   It is an expression that matches the large files, eg-  "include=*.mp3 or largerthan(500kb)"+  "`include=*.mp3 or largerthan(500kb)`"   See [[git-annex-matching-expression]](1) for details on the syntax.    Overrides any annex.largefiles attributes in `.gitattributes` files.@@ -1392,6 +1403,31 @@   When making multiple retries of the same transfer, the delay    doubles after each retry. (default 1) +* `remote.<name>.annex-stalldetecton`, `annex.stalldetection`++  This lets stalled or too-slow transfers be detected, and dealt with, so+  rather than getting stuck, git-annex will cancel the stalled operation.+  When this happens, the transfer will be considered to have failed, so+  settings like annex.retry will control what it does next.++  The value specifies how much data git-annex should expect to see+  flowing, minimum, when it's not stalled, over a given period of time.+  The format is "$amount/$timeperiod". ++  For example, to detect outright stalls where no data has been transferred+  after 30 seconds: `git config annex.stalldetection "0/30s"`++  Or, if you have a remote on a USB drive that is normally capable of+  several megabytes per second, but has bad sectors where it gets+  stuck for a long time, you could use:+  `git config remote.usbdrive.annex-stalldetection "1MB/1m"`++  This is not enabled by default, because it can make git-annex use+  more resources. To be able to cancel stalls, git-annex has to run+  transfers in separate processes (one per concurrent job). So it+  may need to open more connections to a remote than usual, or+  the communication with those processes may make it a bit slower.+ * `remote.<name>.annex-checkuuid`    This only affects remotes that have their url pointing to a directory on@@ -1503,6 +1539,12 @@    Used by bup special remotes, this configures   the location of the bup repository to use. Normally this is automatically+  set up by `git annex initremote`, but you can change it if needed.++* `remote.<name>.annex-borgrepo`++  Used by borg special remotes, this configures+  the location of the borg repository to use. Normally this is automatically   set up by `git annex initremote`, but you can change it if needed.  * `remote.<name>.annex-ddarrepo`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20201127+Version: 8.20201129 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -479,7 +479,6 @@       Assistant.Threads.Watcher       Assistant.TransferQueue       Assistant.TransferSlots-      Assistant.TransferrerPool       Assistant.Types.Alert       Assistant.Types.BranchChange       Assistant.Types.Changes@@ -495,7 +494,6 @@       Assistant.Types.ThreadedMonad       Assistant.Types.TransferQueue       Assistant.Types.TransferSlots-      Assistant.Types.TransferrerPool       Assistant.Types.UrlRenderer       Assistant.Unused       Assistant.Upgrade@@ -666,11 +664,13 @@     Annex.TaggedPush     Annex.Tmp     Annex.Transfer+    Annex.TransferrerPool     Annex.UntrustedFilePath     Annex.UpdateInstead     Annex.UUID     Annex.Url     Annex.VectorClock+    Annex.VectorClock.Utility     Annex.VariantFile     Annex.Version     Annex.View@@ -795,6 +795,7 @@     Command.Test     Command.TestRemote     Command.TransferInfo+    Command.Transferrer     Command.TransferKey     Command.TransferKeys     Command.Trust@@ -931,6 +932,7 @@     Messages.Internal     Messages.JSON     Messages.Progress+    Messages.Serialized     P2P.Address     P2P.Annex     P2P.Auth@@ -939,6 +941,7 @@     Remote     Remote.Adb     Remote.BitTorrent+    Remote.Borg     Remote.Bup     Remote.Ddar     Remote.Directory@@ -961,6 +964,7 @@     Remote.Helper.Messages     Remote.Helper.P2P     Remote.Helper.ReadOnly+    Remote.Helper.ThirdPartyPopulated     Remote.Helper.Special     Remote.Helper.Ssh     Remote.HttpAlso@@ -1023,12 +1027,16 @@     Types.RepoVersion     Types.ScheduledActivity     Types.StandardGroups+    Types.StallDetection     Types.StoreRetrieve     Types.Test     Types.Transfer+    Types.Transferrer+    Types.TransferrerPool     Types.TrustLevel     Types.UUID     Types.UrlContents+    Types.VectorClock     Types.View     Types.WorkerPool     Upgrade
stack.yaml view
@@ -25,7 +25,6 @@ - sandi-0.5 - torrent-10000.1.1 - bencode-0.6.1.1-- network-3.1.0.1 explicit-setup-deps:   git-annex: true-resolver: lts-16.16+resolver: lts-16.27