packages feed

git-annex 7.20200219 → 7.20200226

raw patch · 34 files changed

+223/−172 lines, 34 files

Files

Annex/SpecialRemote/Config.hs view
@@ -11,7 +11,8 @@ module Annex.SpecialRemote.Config where  import Common-import Types.Remote (RemoteConfigField, RemoteConfig)+import Types.Remote (RemoteConfigField, RemoteConfig, configParser)+import Types import Types.UUID import Types.ProposedAccepted import Types.RemoteConfig@@ -106,6 +107,10 @@ 		(FieldDesc "type of special remote") 	, trueFalseParser autoEnableField False 		(FieldDesc "automatically enable special remote")+	, yesNoParser exportTreeField False+		(FieldDesc "export trees of files to this remote")+	, yesNoParser importTreeField False+		(FieldDesc "import trees of files from this remote") 	, optionalStringParser preferreddirField 		(FieldDesc "directory whose content is preferred") 	]@@ -162,7 +167,7 @@  {- Extracts a value from ParsedRemoteConfig. -} getRemoteConfigValue :: HasCallStack => Typeable v => RemoteConfigField -> ParsedRemoteConfig -> Maybe v-getRemoteConfigValue f m = case M.lookup f m of+getRemoteConfigValue f (ParsedRemoteConfig m _) = case M.lookup f m of 	Just (RemoteConfigValue v) -> case cast v of 		Just v' -> Just v' 		Nothing -> error $ unwords@@ -176,13 +181,20 @@  {- Gets all fields that remoteConfigRestPassthrough matched. -} getRemoteConfigPassedThrough :: ParsedRemoteConfig -> M.Map RemoteConfigField String-getRemoteConfigPassedThrough = M.mapMaybe $ \(RemoteConfigValue v) ->-	case cast v of-		Just (PassedThrough s) -> Just s-		Nothing -> Nothing+getRemoteConfigPassedThrough (ParsedRemoteConfig m _) = +	flip M.mapMaybe m $ \(RemoteConfigValue v) ->+		case cast v of+			Just (PassedThrough s) -> Just s+			Nothing -> Nothing  newtype PassedThrough = PassedThrough String +parsedRemoteConfig :: RemoteType -> RemoteConfig -> Annex ParsedRemoteConfig+parsedRemoteConfig t c = either (const emptycfg) id . parseRemoteConfig c +	<$> configParser t c+  where+	emptycfg = ParsedRemoteConfig mempty c+ parseRemoteConfig :: RemoteConfig -> RemoteConfigParser -> Either String ParsedRemoteConfig parseRemoteConfig c rpc = 	go [] c (remoteConfigFieldParsers rpc ++ commonFieldParsers)@@ -195,8 +207,10 @@ 		in if not (null leftovers') 			then Left $ "Unexpected parameters: " ++ 				unwords (map (fromProposedAccepted . fst) leftovers')-			else Right $ M.fromList $-				l ++ map (uncurry passthrough) passover+			else+				let m = M.fromList $+					l ++ map (uncurry passthrough) passover+				in Right (ParsedRemoteConfig m c) 	go l c' (p:rest) = do 		let f = parserForField p 		(valueParser p) (M.lookup f c) c >>= \case
Assistant/WebApp/Configurators/AWS.hs view
@@ -170,8 +170,7 @@ 	m <- liftAnnex readRemoteLog 	isia <- case M.lookup uuid m of 		Just c -> liftAnnex $ do-			pc <- either mempty id . parseRemoteConfig c-				<$> Remote.configParser S3.remote c+			pc <- parsedRemoteConfig S3.remote c 			return $ S3.configIA pc 		Nothing -> return False 	if isia
Assistant/WebApp/Configurators/Edit.hs view
@@ -256,8 +256,7 @@ getRepoInfo (Just r) c = case fromProposedAccepted <$> M.lookup typeField c of 	Just "S3" -> do #ifdef WITH_S3-		pc <- liftAnnex $ either mempty id . parseRemoteConfig c-			<$> Remote.configParser S3.remote c+		pc <- liftAnnex $ parsedRemoteConfig S3.remote c 		if S3.configIA pc 			then IA.getRepoInfo c 			else AWS.getRepoInfo c@@ -283,7 +282,8 @@ 	(Just (EncryptedCipher _ _ ks)) -> desckeys ks 	(Just (SharedPubKeyCipher _ ks)) -> desckeys ks   where-	pc = either mempty id $ parseEncryptionConfig c+	pc = either (const (Remote.ParsedRemoteConfig mempty mempty)) id $+		parseEncryptionConfig c 	desckeys (KeyIds { keyIds = ks }) = do 		cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig 		knownkeys <- liftIO (secretKeys cmd)
Assistant/WebApp/Configurators/WebDAV.hs view
@@ -15,7 +15,7 @@ import qualified Remote.WebDAV as WebDAV import Assistant.WebApp.MakeRemote import qualified Remote-import Types.Remote (RemoteConfig, configParser)+import Types.Remote (RemoteConfig) import Types.StandardGroups import Logs.Remote import Git.Types (RemoteName)@@ -62,8 +62,7 @@ 	let url = fromProposedAccepted $ fromJust $ M.lookup (Accepted "url") c 	mcreds <- liftAnnex $ do 		dummycfg <- liftIO dummyRemoteGitConfig-		pc <- either mempty id . parseRemoteConfig c-			<$> configParser WebDAV.remote c+		pc <- parsedRemoteConfig WebDAV.remote c 		getRemoteCredPairFor "webdav" pc dummycfg (WebDAV.davCreds uuid) 	case mcreds of 		Just creds -> webDAVConfigurator $ liftH $
CHANGELOG view
@@ -1,3 +1,19 @@+git-annex (7.20200226) upstream; urgency=high++  * Fix serious regression in gcrypt and encrypted git-lfs remotes.+    Since version 7.20200202.7, git-annex incorrectly stored content+    on those remotes without encrypting it.+    If your remotes are affected, you will want to make sure to delete+    any content that git-annex has stored on them that is not encrypted!+  * info: Fix display of the encryption value.+    (Some debugging junk had crept in.)+  * Bugfix to getting content from an export remote with -J, when the+    export database was not yet populated.+  * Bugfix: export --tracking (a deprecated option) set +    annex-annex-tracking-branch, instead of annex-tracking-branch.++ -- Joey Hess <id@joeyh.name>  Wed, 26 Feb 2020 17:18:16 -0400+ git-annex (7.20200219) upstream; urgency=medium    * Added sync --only-annex, which syncs the git-annex branch and annexed
Command/Export.hs view
@@ -81,7 +81,7 @@ 	 	-- handle deprecated option 	when (exportTracking o) $-		setConfig (remoteConfig r "annex-tracking-branch")+		setConfig (remoteConfig r "tracking-branch") 			(fromRef $ exportTreeish o) 	 	tree <- filterPreferredContent r =<<
Command/TestRemote.hs view
@@ -24,8 +24,8 @@ import Utility.CopyFile import Types.Messages import Types.Export-import Types.Crypto import Types.RemoteConfig+import Types.ProposedAccepted import Annex.SpecialRemote.Config (exportTreeField) import Remote.Helper.ExportImport import Remote.Helper.Chunked@@ -122,18 +122,18 @@ 		]  adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote)-adjustChunkSize r chunksize = adjustRemoteConfig r-	(M.insert chunkField (RemoteConfigValue (show chunksize)))+adjustChunkSize r chunksize = adjustRemoteConfig r $+	M.insert chunkField (Proposed (show chunksize))  -- Variants of a remote with no encryption, and with simple shared -- encryption. Gpg key based encryption is not tested. encryptionVariants :: Remote -> Annex [Remote] encryptionVariants r = do 	noenc <- adjustRemoteConfig r $-		M.insert encryptionField (RemoteConfigValue NoneEncryption)+		M.insert encryptionField (Proposed "none") 	sharedenc <- adjustRemoteConfig r $-		M.insert encryptionField (RemoteConfigValue SharedEncryption) .-		M.insert highRandomQualityField (RemoteConfigValue False)+		M.insert encryptionField (Proposed "shared") .+		M.insert highRandomQualityField (Proposed "false") 	return $ catMaybes [noenc, sharedenc]  -- Variant of a remote with exporttree disabled.@@ -145,19 +145,20 @@ exportTreeVariant :: Remote -> Annex (Maybe Remote) exportTreeVariant r = ifM (Remote.isExportSupported r) 	( adjustRemoteConfig r $-		M.insert encryptionField (RemoteConfigValue NoneEncryption) . -		M.insert exportTreeField (RemoteConfigValue True)+		M.insert encryptionField (Proposed "none") . +		M.insert exportTreeField (Proposed "yes") 	, return Nothing 	)  -- Regenerate a remote with a modified config.-adjustRemoteConfig :: Remote -> (Remote.ParsedRemoteConfig -> Remote.ParsedRemoteConfig) -> Annex (Maybe Remote)+adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote) adjustRemoteConfig r adjustconfig = do 	repo <- Remote.getRepo r+	let ParsedRemoteConfig _ origc = Remote.config r 	Remote.generate (Remote.remotetype r) 		repo 		(Remote.uuid r)-		(adjustconfig (Remote.config r))+		(adjustconfig origc) 		(Remote.gitconfig r) 		(Remote.remoteStateHandle r)
Creds.hs view
@@ -57,8 +57,9 @@  - cipher. The EncryptionIsSetup is witness to that being the case.  -} setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig-setRemoteCredPair = setRemoteCredPair' id-	(either (const mempty) id . parseEncryptionConfig)+setRemoteCredPair = setRemoteCredPair' id go+  where+	go c = either (const (ParsedRemoteConfig mempty c)) id (parseEncryptionConfig c)  setRemoteCredPair' 	:: (ProposedAccepted String -> a)@@ -203,18 +204,18 @@ 	liftIO $ nukeFile f  includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)]-includeCredsInfo c storage info = do+includeCredsInfo pc@(ParsedRemoteConfig cm _) storage info = do 	v <- liftIO $ getEnvCredPair storage 	case v of 		Just _ -> do 			let (uenv, penv) = credPairEnvironment storage 			ret $ "from environment variables (" ++ unwords [uenv, penv] ++ ")"-		Nothing -> case (`M.lookup` c) (credPairRemoteField storage) of+		Nothing -> case (`M.lookup` cm) (credPairRemoteField storage) of 			Nothing -> ifM (existsCacheCredPair storage) 				( ret "stored locally" 				, ret "not available" 				)-			Just _ -> case extractCipher c of+			Just _ -> case extractCipher pc of 				Just (EncryptedCipher {}) -> ret "embedded in git repository (gpg encrypted)" 				_ -> ret "embedded in git repository (not encrypted)"   where
Git/LsTree.hs view
@@ -21,7 +21,6 @@ import Common import Git import Git.Command-import Git.Sha import Git.FilePath import qualified Git.Filename import Utility.Attoparsec
NEWS view
@@ -1,3 +1,18 @@+git-annex (7.20200226) upstream; urgency=high++  There was a serious regression in gcrypt and encrypted git-lfs remotes.+  Since version 7.20200202.7, git-annex incorrectly stored content+  on those remotes without encrypting it.++  If your remotes are affected, you will want to make sure to delete+  any content that git-annex has stored on them that is not encrypted!++  One way to do so is, before upgrading to this version,+  run git-annex move --from the affected remotes. It will move+  only the content that was not encrypted.++ -- Joey Hess <id@joeyh.name>  Wed, 26 Feb 2020 17:18:16 -0400+ git-annex (7.20191024) upstream; urgency=medium    When annex.largefiles is not configured, `git add` and `git commit -a`
Remote/Adb.hs view
@@ -54,8 +54,9 @@ androidserialField :: RemoteConfigField androidserialField = Accepted "androidserial" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs = do+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs = do+	c <- parsedRemoteConfig remote rc 	let this = Remote 		{ uuid = u 		-- adb operates over USB or wifi, so is not as cheap
Remote/BitTorrent.hs view
@@ -28,6 +28,7 @@ import Annex.UUID import qualified Annex.Url as Url import Remote.Helper.ExportImport+import Annex.SpecialRemote.Config  import Network.URI @@ -53,9 +54,10 @@ 	r <- liftIO $ Git.Construct.remoteNamed "bittorrent" (pure Git.Construct.fromUnknown) 	return [r] -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r _ c gc rs = do+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r _ rc gc rs = do 	cst <- remoteCost gc expensiveRemoteCost+	c <- parsedRemoteConfig remote rc 	return $ Just Remote 		{ uuid = bitTorrentUUID 		, cost = cst
Remote/Bup.hs view
@@ -55,8 +55,9 @@ buprepoField :: RemoteConfigField buprepoField = Accepted "buprepo" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs = do+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs = do+	c <- parsedRemoteConfig remote rc 	bupr <- liftIO $ bup2GitRemote buprepo 	cst <- remoteCost gc $ 		if bupLocal buprepo@@ -99,6 +100,10 @@ 		, checkUrl = Nothing 		, remoteStateHandle = rs 		}+	let specialcfg = (specialRemoteCfg c)+		-- chunking would not improve bup+		{ chunkConfig = NoChunks+		} 	return $ Just $ specialRemote' specialcfg c 		(simplyPrepare $ store this buprepo) 		(simplyPrepare $ retrieve buprepo)@@ -107,10 +112,6 @@ 		this   where 	buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc-	specialcfg = (specialRemoteCfg c)-		-- chunking would not improve bup-		{ chunkConfig = NoChunks-		}  bupSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) bupSetup _ mu _ c gc = do
Remote/Ddar.hs view
@@ -48,20 +48,25 @@ ddarrepoField :: RemoteConfigField ddarrepoField = Accepted "ddarrepo" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs = do+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 ddarLocal ddarrepo 			then nearlyCheapRemoteCost 			else expensiveRemoteCost+	let specialcfg = (specialRemoteCfg c)+		-- chunking would not improve ddar+		{ chunkConfig = NoChunks+		} 	return $ Just $ specialRemote' specialcfg c 		(simplyPrepare $ store ddarrepo) 		(simplyPrepare $ retrieve ddarrepo) 		(simplyPrepare $ remove ddarrepo) 		(simplyPrepare $ checkKey ddarrepo)-		(this cst)+		(this c cst)   where-	this cst = Remote+	this c cst = Remote 		{ uuid = u 		, cost = cst 		, name = Git.repoDescribe r@@ -97,10 +102,6 @@ 		, remoteStateHandle = rs 		} 	ddarrepo = maybe (giveup "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc)-	specialcfg = (specialRemoteCfg c)-		-- chunking would not improve ddar-		{ chunkConfig = NoChunks-		}  ddarSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) ddarSetup _ mu _ c gc = do
Remote/Directory.hs view
@@ -54,8 +54,9 @@ directoryField :: RemoteConfigField directoryField = Accepted "directory" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs = do+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs = do+	c <- parsedRemoteConfig remote rc 	cst <- remoteCost gc cheapRemoteCost 	let chunkconfig = getChunkConfig c 	return $ Just $ specialRemote c@@ -106,7 +107,7 @@ 			, appendonly = False 			, availability = LocallyAvailable 			, remotetype = remote-			, mkUnavailable = gen r u c+			, mkUnavailable = gen r u rc 				(gc { remoteAnnexDirectory = Just "/dev/null" }) rs 			, getInfo = return [("directory", dir)] 			, claimUrl = Nothing
Remote/External.hs view
@@ -62,12 +62,13 @@ readonlyField :: RemoteConfigField readonlyField = Accepted "readonly" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs 	-- readonly mode only downloads urls; does not use external program 	| remoteAnnexReadOnly gc = do+		c <- parsedRemoteConfig remote rc 		cst <- remoteCost gc expensiveRemoteCost-		mk cst GloballyAvailable+		mk c cst GloballyAvailable 			readonlyStorer 			retrieveUrl 			readonlyRemoveKey@@ -79,6 +80,7 @@ 			exportUnsupported 			exportUnsupported 	| otherwise = do+		c <- parsedRemoteConfig remote rc 		external <- newExternal externaltype (Just u) c (Just gc) (Just rs) 		Annex.addCleanup (RemoteCleanup u) $ stopExternal external 		cst <- getCost external r gc@@ -101,7 +103,7 @@ 		let cheapexportsupported = if exportsupported 			then exportIsSupported 			else exportUnsupported-		mk cst avail+		mk c cst avail 			(storeKeyM external) 			(retrieveKeyFileM external) 			(removeKeyM external)@@ -113,7 +115,7 @@ 			exportactions 			cheapexportsupported   where-	mk cst avail tostore toretrieve toremove tocheckkey towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = do+	mk c cst avail tostore toretrieve toremove tocheckkey towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = do 		let rmt = Remote 			{ uuid = u 			, cost = cst@@ -144,7 +146,7 @@ 			, availability = avail 			, remotetype = remote  				{ exportSupported = cheapexportsupported }-			, mkUnavailable = gen r u c+			, mkUnavailable = gen r u rc 				(gc { remoteAnnexExternalType = Just "!dne!" }) rs 			, getInfo = togetinfo 			, claimUrl = toclaimurl@@ -409,25 +411,28 @@ 		send $ VALUE $ fromRawFilePath $ hashDirLower def k 	handleRemoteRequest (SETCONFIG setting value) = 		liftIO $ atomically $ do-			modifyTVar' (externalConfig st) $-				M.insert (Accepted setting) $-					RemoteConfigValue (PassedThrough value)+			modifyTVar' (externalConfig st) $ \(ParsedRemoteConfig m c) ->+				let m' = M.insert+					(Accepted setting)+					(RemoteConfigValue (PassedThrough value))+					m+				in ParsedRemoteConfig m' c 			modifyTVar' (externalConfigChanges st) $ \f -> 				f . M.insert (Accepted setting) (Accepted value) 	handleRemoteRequest (GETCONFIG setting) = do 		value <- fromMaybe ""-			. M.lookup (Accepted setting)+			. (M.lookup (Accepted setting)) 			. getRemoteConfigPassedThrough 			<$> liftIO (atomically $ readTVar $ externalConfig st) 		send $ VALUE value 	handleRemoteRequest (SETCREDS setting login password) = case (externalUUID external, externalGitConfig external) of 		(Just u, Just gc) -> do 			let v = externalConfig st-			c <- liftIO $ atomically $ readTVar v-			c' <- setRemoteCredPair' RemoteConfigValue id encryptionAlreadySetup c gc+			(ParsedRemoteConfig m c) <- liftIO $ atomically $ readTVar v+			m' <- setRemoteCredPair' RemoteConfigValue (\m' -> ParsedRemoteConfig m' c) encryptionAlreadySetup m gc 				(credstorage setting u) 				(Just (login, password))-			void $ liftIO $ atomically $ swapTVar v c'+			void $ liftIO $ atomically $ swapTVar v (ParsedRemoteConfig m' c) 		_ -> senderror "cannot send SETCREDS here" 	handleRemoteRequest (GETCREDS setting) = case (externalUUID external, externalGitConfig external) of 		(Just u, Just gc) -> do
Remote/GCrypt.hs view
@@ -80,16 +80,16 @@ gitRepoField :: RemoteConfigField gitRepoField = Accepted "gitrepo" -chainGen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-chainGen gcryptr u c gc rs = do+chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+chainGen gcryptr u rc gc rs = do 	g <- gitRepo 	-- get underlying git repo with real path, not gcrypt path 	r <- liftIO $ Git.GCrypt.encryptedRemote g gcryptr 	let r' = r { Git.remoteName = Git.remoteName gcryptr }-	gen r' u c gc rs+	gen r' u rc gc rs -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen baser u c gc rs = do+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen baser u rc gc rs = do 	-- doublecheck that cache matches underlying repo's gcrypt-id 	-- (which might not be set), only for local repos 	(mgcryptid, r) <- getGCryptId True baser gc@@ -97,7 +97,9 @@ 	case (mgcryptid, Git.GCrypt.remoteRepoId g (Git.remoteName baser)) of 		(Just gcryptid, Just cachedgcryptid) 			| gcryptid /= cachedgcryptid -> resetup gcryptid r-		_ -> gen' r u c gc rs+		_ -> do+			c <- parsedRemoteConfig remote rc+			gen' r u c gc rs   where 	-- A different drive may have been mounted, making a different 	-- gcrypt remote available. So need to set the cached@@ -108,10 +110,8 @@ 		let u' = genUUIDInNameSpace gCryptNameSpace gcryptid 		v <- M.lookup u' <$> readRemoteLog 		case (Git.remoteName baser, v) of-			(Just remotename, Just c') -> do-				pc <- either giveup return-					. parseRemoteConfig c'-					=<< configParser remote c'+			(Just remotename, Just rc') -> do+				pc <- parsedRemoteConfig remote rc' 				setGcryptEncryption pc remotename 				storeUUIDIn (remoteConfig baser "uuid") u' 				setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid
Remote/Git.hs view
@@ -161,20 +161,21 @@ 			Just r' -> return r' 		_ -> return r -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs 	-- Remote.GitLFS may be used with a repo that is also encrypted 	-- with gcrypt so is checked first.-	| remoteAnnexGitLFS gc = Remote.GitLFS.gen r u c gc rs-	| Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc rs+	| remoteAnnexGitLFS gc = Remote.GitLFS.gen r u rc gc rs+	| Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u rc gc rs 	| otherwise = case repoP2PAddress r of 		Nothing -> do 			st <- mkState r u gc-			go st <$> remoteCost gc defcst-		Just addr -> Remote.P2P.chainGen addr r u c gc rs+			c <- parsedRemoteConfig remote rc+			go st c <$> remoteCost gc defcst+		Just addr -> Remote.P2P.chainGen addr r u rc gc rs   where 	defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost-	go st cst = Just new+	go st c cst = Just new 	  where 		new = Remote  			{ uuid = u@@ -205,14 +206,14 @@ 			, appendonly = False 			, availability = availabilityCalc r 			, remotetype = remote-			, mkUnavailable = unavailable r u c gc rs+			, mkUnavailable = unavailable r u rc gc rs 			, getInfo = gitRepoInfo new 			, claimUrl = Nothing 			, checkUrl = Nothing 			, remoteStateHandle = rs 			} -unavailable :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) unavailable r = gen r'   where 	r' = case Git.location r of
Remote/GitLFS.hs view
@@ -73,8 +73,9 @@ urlField :: RemoteConfigField urlField = Accepted "url" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs = do+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs = do+	c <- parsedRemoteConfig remote rc 	-- If the repo uses gcrypt, get the underlaying repo without the 	-- gcrypt url, to do LFS endpoint discovery on. 	r' <- if Git.GCrypt.isEncrypted r@@ -85,14 +86,18 @@ 	sem <- liftIO $ MSemN.new 1 	h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc 	cst <- remoteCost gc expensiveRemoteCost+	let specialcfg = (specialRemoteCfg c)+		-- chunking would not improve git-lfs+		{ chunkConfig = NoChunks+		} 	return $ Just $ specialRemote' specialcfg c 		(simplyPrepare $ store rs h) 		(simplyPrepare $ retrieve rs h) 		(simplyPrepare $ remove h) 		(simplyPrepare $ checkKey rs h)-		(this cst)+		(this c cst)   where-	this cst = Remote+	this c cst = Remote 		{ uuid = u 		, cost = cst 		, name = Git.repoDescribe r@@ -122,14 +127,10 @@ 		-- content cannot be removed from a git-lfs repo 		, appendonly = True 		, mkUnavailable = return Nothing-		, getInfo = gitRepoInfo (this cst)+		, getInfo = gitRepoInfo (this c cst) 		, claimUrl = Nothing 		, checkUrl = Nothing 		, remoteStateHandle = rs-		}-	specialcfg = (specialRemoteCfg c)-		-- chunking would not improve git-lfs-		{ chunkConfig = NoChunks 		}  mySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
Remote/Glacier.hs view
@@ -59,10 +59,12 @@ fileprefixField :: RemoteConfigField fileprefixField = Accepted "fileprefix" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs = new <$> remoteCost gc veryExpensiveRemoteCost+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs = new +	<$> parsedRemoteConfig remote rc+	<*> remoteCost gc veryExpensiveRemoteCost   where-	new cst = Just $ specialRemote' specialcfg c+	new c cst = Just $ specialRemote' specialcfg c 		(prepareStore this) 		(prepareRetrieve this) 		(simplyPrepare $ remove this)@@ -105,10 +107,10 @@ 			, checkUrl = Nothing 			, remoteStateHandle = rs 			}-	specialcfg = (specialRemoteCfg c)-		-- Disabled until jobList gets support for chunks.-		{ chunkConfig = NoChunks-		}+		specialcfg = (specialRemoteCfg c)+			-- Disabled until jobList gets support for chunks.+			{ chunkConfig = NoChunks+			}  glacierSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) glacierSetup ss mu mcreds c gc = do
Remote/Helper/Encryptable.hs view
@@ -284,7 +284,7 @@  describeEncryption :: ParsedRemoteConfig -> String describeEncryption c = case extractCipher c of-	Nothing -> "none" ++ show (getRemoteConfigValue cipherField c :: Maybe String) ++ show (M.keys c)+	Nothing -> "none" 	Just cip -> nameCipher cip ++ " (" ++ describeCipher cip ++ ")"  nameCipher :: StorableCipher -> String
Remote/Helper/ExportImport.hs view
@@ -72,15 +72,11 @@ -- | Prevent or allow exporttree=yes and importtree=yes when -- setting up a new remote, depending on exportSupported and importSupported. adjustExportImportRemoteType :: RemoteType -> RemoteType-adjustExportImportRemoteType rt = rt-	{ setup = setup'-	, configParser = configparser-	}+adjustExportImportRemoteType rt = rt { setup = setup' }   where-	configparser c = addRemoteConfigParser exportImportConfigParsers -		<$> configParser rt c 	setup' st mu cp c gc = do-		pc <- either giveup return . parseRemoteConfig c =<< configparser c+		pc <- either giveup return . parseRemoteConfig c+			=<< configParser rt c 		let checkconfig supported configured configfield cont = 			ifM (supported rt pc gc) 				( case st of@@ -89,7 +85,7 @@ 							giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield 						| otherwise -> cont 					Enable oldc -> do-						oldpc <- either mempty id . parseRemoteConfig oldc <$> configparser oldc+						oldpc <- parsedRemoteConfig rt oldc 						if configured pc /= configured oldpc 							then giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote" 							else cont@@ -103,14 +99,6 @@ 					then giveup "cannot enable importtree=yes without also enabling exporttree=yes" 					else setup rt st mu cp c gc -exportImportConfigParsers :: [RemoteConfigFieldParser]-exportImportConfigParsers =-	[ yesNoParser exportTreeField False-		(FieldDesc "export trees of files to this remote")-	, yesNoParser importTreeField False-		(FieldDesc "import trees of files from this remote")-	]- -- | Adjust a remote to support exporttree=yes and importree=yes. -- -- Note that all remotes with importree=yes also have exporttree=yes.@@ -160,7 +148,6 @@ 				{ storeExport = \f k loc p -> do 					db <- getciddb ciddbv 					exportdb <- getexportdb exportdbv-					updateexportdb exportdb exportdbv 					oldks <- liftIO $ Export.getExportTreeKey exportdb loc 					oldcids <- liftIO $ concat 						<$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks@@ -277,8 +264,7 @@ 		lcklckv <- liftIO newEmptyTMVarIO 		dbv <- liftIO newEmptyTMVarIO 		exportinconflict <- liftIO $ newTVarIO False-		exportupdated <- liftIO $ newTMVarIO ()-		return (dbv, lcklckv, exportinconflict, exportupdated)+		return (dbv, lcklckv, exportinconflict)  	-- Only open the database once it's needed. 	getciddb (dbtv, lcklckv) =@@ -300,13 +286,18 @@ 				) 	 	-- Only open the database once it's needed.-	getexportdb (dbv, lcklckv, _, _) = +	--+	-- After opening the database, check if the export log is+	-- different than the database, and update the database, to notice+	-- when an export has been updated from another repository.+	getexportdb (dbv, lcklckv, exportinconflict) =  		liftIO (atomically (tryReadTMVar dbv)) >>= \case 			Just db -> return db 			-- let only one thread take the lock 			Nothing -> ifM (liftIO $ atomically $ tryPutTMVar lcklckv ()) 				( do 					db <- Export.openDb (uuid r)+					updateexportdb db exportinconflict 					liftIO $ atomically $ putTMVar dbv db 					return db 				-- loser waits for winner to open the db and@@ -314,24 +305,18 @@ 				, liftIO $ atomically (readTMVar dbv) 				) -	getexportinconflict (_, _, v, _) = v+	getexportinconflict (_, _, v) = v -	-- Check once if the export log is different than the database and-	-- updates the database, to notice when an export has been-	-- updated from another repository.				-	updateexportdb db (_, _, exportinconflict, exportupdated) =-		liftIO (atomically (tryTakeTMVar exportupdated)) >>= \case-			Just () -> Export.updateExportTreeFromLog db >>= \case-				Export.ExportUpdateSuccess -> return ()-				Export.ExportUpdateConflict -> do-					warnExportImportConflict r-					liftIO $ atomically $-						writeTVar exportinconflict True-			Nothing -> return ()+	updateexportdb db exportinconflict =+		Export.updateExportTreeFromLog db >>= \case+			Export.ExportUpdateSuccess -> return ()+			Export.ExportUpdateConflict -> do+				warnExportImportConflict r+				liftIO $ atomically $+					writeTVar exportinconflict True 		 	getexportlocs dbv k = do 		db <- getexportdb dbv-		updateexportdb db dbv 		liftIO $ Export.getExportTree db k  	retrieveKeyFileFromExport dbv k _af dest p = unVerified $
Remote/Hook.hs view
@@ -45,8 +45,9 @@ hooktypeField :: RemoteConfigField hooktypeField = Accepted "hooktype" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs = do+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs = do+	c <- parsedRemoteConfig remote rc 	cst <- remoteCost gc expensiveRemoteCost 	return $ Just $ specialRemote c 		(simplyPrepare $ store hooktype)@@ -80,7 +81,7 @@ 			, appendonly = False 			, availability = GloballyAvailable 			, remotetype = remote-			, mkUnavailable = gen r u c+			, mkUnavailable = gen r u rc 				(gc { remoteAnnexHookType = Just "!dne!" }) 				rs 			, getInfo = return [("hooktype", hooktype)]
Remote/List.hs view
@@ -20,7 +20,6 @@ import Remote.Helper.Hooks import Remote.Helper.ReadOnly import Remote.Helper.ExportImport-import Annex.SpecialRemote.Config import qualified Git import qualified Git.Config @@ -110,8 +109,7 @@ 	let cu = fromMaybe u $ remoteAnnexConfigUUID gc 	let rs = RemoteStateHandle cu 	let c = fromMaybe M.empty $ M.lookup cu m-	pc <- either (const mempty) id . parseRemoteConfig c <$> configParser t c-	generate t g u pc gc rs >>= \case+	generate t g u c gc rs >>= \case 		Nothing -> return Nothing 		Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs
Remote/P2P.hs view
@@ -26,6 +26,7 @@ import Remote.Helper.ExportImport import Remote.Helper.P2P import Utility.AuthToken+import Annex.SpecialRemote.Config  import Control.Concurrent.STM @@ -42,8 +43,9 @@ 	, importSupported = importUnsupported 	} -chainGen :: P2PAddress -> Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-chainGen addr r u c gc rs = do+chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+chainGen addr r u rc gc rs = do+	c <- parsedRemoteConfig remote rc 	connpool <- mkConnectionPool 	cst <- remoteCost gc veryExpensiveRemoteCost 	let protorunner = runProto u addr connpool
Remote/Rsync.hs view
@@ -67,13 +67,17 @@ rsyncUrlField :: RemoteConfigField rsyncUrlField = Accepted "rsyncurl" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs = do+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs = do+	c <- parsedRemoteConfig remote rc 	cst <- remoteCost gc expensiveRemoteCost 	(transport, url) <- rsyncTransport gc $ 		fromMaybe (giveup "missing rsyncurl") $ remoteAnnexRsyncUrl gc 	let o = genRsyncOpts c gc transport url 	let islocal = rsyncUrlIsPath $ rsyncUrl o+	let specialcfg = (specialRemoteCfg c)+		-- Rsync displays its own progress.+		{ displayProgress = False } 	return $ Just $ specialRemote' specialcfg c 		(simplyPrepare $ fileStorer $ store o) 		(simplyPrepare $ fileRetriever $ retrieve o)@@ -119,10 +123,6 @@ 			, checkUrl = Nothing 			, remoteStateHandle = rs 			}-  where-	specialcfg = (specialRemoteCfg c)-		-- Rsync displays its own progress.-		{ displayProgress = False }  -- Things used by genRsyncOpts rsyncRemoteConfigs :: [RemoteConfigFieldParser]
Remote/S3.hs view
@@ -154,15 +154,16 @@ mungekeysField :: RemoteConfigField mungekeysField = Accepted "mungekeys" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs = do+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs = do+	c <- parsedRemoteConfig remote rc 	cst <- remoteCost gc expensiveRemoteCost 	info <- extractS3Info c 	hdl <- mkS3HandleVar c gc u 	magic <- liftIO initMagicMime-	return $ new cst info hdl magic+	return $ new c cst info hdl magic   where-	new cst info hdl magic = Just $ specialRemote c+	new c cst info hdl magic = Just $ specialRemote c 		(simplyPrepare $ store hdl this info magic) 		(simplyPrepare $ retrieve hdl this rs c info) 		(simplyPrepare $ remove hdl this info)@@ -211,7 +212,7 @@ 			, appendonly = versioning info 			, availability = GloballyAvailable 			, remotetype = remote-			, mkUnavailable = gen r u (M.insert hostField (RemoteConfigValue ("!dne!" :: String)) c) gc rs+			, mkUnavailable = gen r u (M.insert hostField (Proposed "!dne!") rc) gc rs 			, getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info) 			, claimUrl = Nothing 			, checkUrl = Nothing@@ -1251,9 +1252,7 @@ 		Init -> when (versioning info) $ 			enableversioning (bucket info) 		Enable oldc -> do-			oldpc <- either (const mempty) id-				. parseRemoteConfig oldc -				<$> configParser remote oldc+			oldpc <- parsedRemoteConfig remote oldc 			oldinfo <- extractS3Info oldpc 			when (versioning info /= versioning oldinfo) $ 				giveup "Cannot change versioning= of existing S3 remote."
Remote/Tahoe.hs view
@@ -74,8 +74,9 @@ furlField :: RemoteConfigField furlField = Accepted "introducer-furl" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs = do+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs = do+	c <- parsedRemoteConfig remote rc 	cst <- remoteCost gc expensiveRemoteCost 	hdl <- liftIO $ TahoeHandle 		<$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc)
Remote/Web.hs view
@@ -21,6 +21,7 @@ import Utility.Metered import qualified Annex.Url as Url import Annex.YoutubeDl+import Annex.SpecialRemote.Config  remote :: RemoteType remote = RemoteType@@ -41,8 +42,9 @@ 	r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown) 	return [r] -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r _ c gc rs = do+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r _ rc gc rs = do+	c <- parsedRemoteConfig remote rc 	cst <- remoteCost gc expensiveRemoteCost 	return $ Just Remote 		{ uuid = webUUID
Remote/WebDAV.hs view
@@ -63,10 +63,12 @@ davcredsField :: RemoteConfigField davcredsField = Accepted "davcreds" -gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)-gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost+gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)+gen r u rc gc rs = new+	<$> parsedRemoteConfig remote rc+	<*> remoteCost gc expensiveRemoteCost   where-	new cst = Just $ specialRemote c+	new c cst = Just $ specialRemote c 		(prepareDAV this $ store chunkconfig) 		(prepareDAV this $ retrieve chunkconfig) 		(prepareDAV this $ remove)@@ -108,7 +110,7 @@ 			, appendonly = False 			, availability = GloballyAvailable 			, remotetype = remote-			, mkUnavailable = gen r u (M.insert urlField (RemoteConfigValue "http://!dne!/") c) gc rs+			, mkUnavailable = gen r u (M.insert urlField (Proposed "http://!dne!/") rc) gc rs 			, getInfo = includeCredsInfo c (davCreds u) $ 				[("url", fromMaybe "unknown" $ getRemoteConfigValue urlField c)] 			, claimUrl = Nothing
Test.hs view
@@ -1622,7 +1622,7 @@ 				checkKeys cip (Just v) <&&> checkCipher encipher ks' 		_ -> return False 	  where-		pc =either mempty id $+		pc = either (const (Types.Remote.ParsedRemoteConfig mempty mempty)) id $ 			Remote.Helper.Encryptable.parseEncryptionConfig c 		keysMatch (Utility.Gpg.KeyIds ks') = 			maybe False (\(Utility.Gpg.KeyIds ks2) ->@@ -1632,7 +1632,7 @@ 		checkScheme Types.Crypto.PubKey = scheme == "pubkey" 		checkKeys cip mvariant = do 			dummycfg <- Types.GitConfig.dummyRemoteGitConfig-			let encparams = (mempty :: Types.Remote.ParsedRemoteConfig, dummycfg)+			let encparams = (Types.Remote.ParsedRemoteConfig mempty mempty, dummycfg) 			cipher <- Crypto.decryptCipher gpgcmd encparams cip 			files <- filterM doesFileExist $ 				map ("dir" </>) $ concatMap (serializeKeys cipher) keys
Types/Remote.hs view
@@ -58,7 +58,7 @@ 	-- The Bool is True if automatic initialization of remotes is desired 	, enumerate :: Bool -> a [Git.Repo] 	-- generates a remote of this type-	, generate :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))+	, generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a)) 	-- parse configs of remotes of this type 	, configParser :: RemoteConfig -> a RemoteConfigParser 	-- initializes or enables a remote
Types/RemoteConfig.hs view
@@ -22,7 +22,9 @@ type RemoteConfig = M.Map RemoteConfigField (ProposedAccepted String)  {- Before being used a RemoteConfig has to be parsed. -}-type ParsedRemoteConfig = M.Map RemoteConfigField RemoteConfigValue+data ParsedRemoteConfig = ParsedRemoteConfig+	(M.Map RemoteConfigField RemoteConfigValue)+	RemoteConfig  {- Remotes can have configuration values of many types, so use Typeable  - to let them all be stored in here. -}
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 7.20200219+Version: 7.20200226 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>