plumb RemoteGitConfig through to decryptCipher

Creds.hs

@@ -58,7 +58,7 @@ setRemoteCredPair encsetup c gc storage mcreds = case mcreds of
 	Just creds
 		| embedCreds c -> case credPairRemoteKey storage of
 			Nothing -> localcache creds
-			Just key -> storeconfig creds key =<< remoteCipher =<< localcache creds
+			Just key -> storeconfig creds key =<< flip remoteCipher gc =<< localcache creds
 		| otherwise -> localcache creds
   where
 	localcache creds = do
@@ -84,7 +84,7 @@ getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv
 	fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage
 	fromconfig = case credPairRemoteKey storage of
 		Just key -> do
-			mcipher <- remoteCipher' c
+			mcipher <- remoteCipher' c gc
 			case (M.lookup key c, mcipher) of
 				(Nothing, _) -> return Nothing
 				(Just enccreds, Just (cipher, storablecipher)) ->

Crypto.hs

@@ -99,14 +99,14 @@ genSharedPubKeyCipher cmd keyid highQuality = do
 {- Updates an existing Cipher, making changes to its keyids.
  -
  - When the Cipher is encrypted, re-encrypts it. -}
-updateCipherKeyIds :: Gpg.GpgCmd -> [(Bool, Gpg.KeyId)] -> StorableCipher -> IO StorableCipher
+updateCipherKeyIds :: LensGpgEncParams encparams => Gpg.GpgCmd -> encparams -> [(Bool, Gpg.KeyId)] -> StorableCipher -> IO StorableCipher
-updateCipherKeyIds _ _ SharedCipher{} = error "Cannot update shared cipher"
+updateCipherKeyIds _ _ _ SharedCipher{} = error "Cannot update shared cipher"
-updateCipherKeyIds _ [] c = return c
+updateCipherKeyIds _ _ [] c = return c
-updateCipherKeyIds cmd changes encipher@(EncryptedCipher _ variant ks) = do
+updateCipherKeyIds cmd encparams changes encipher@(EncryptedCipher _ variant ks) = do
 	ks' <- updateCipherKeyIds' cmd changes ks
-	cipher <- decryptCipher cmd encipher
+	cipher <- decryptCipher cmd encparams encipher
 	encryptCipher cmd cipher variant ks'
-updateCipherKeyIds cmd changes (SharedPubKeyCipher cipher ks) =
+updateCipherKeyIds cmd _ changes (SharedPubKeyCipher cipher ks) =
 	SharedPubKeyCipher cipher <$> updateCipherKeyIds' cmd changes ks
 
 updateCipherKeyIds' :: Gpg.GpgCmd -> [(Bool, Gpg.KeyId)] -> KeyIds -> IO KeyIds
@@ -136,15 +136,16 @@ encryptCipher cmd c variant (KeyIds ks) = do
 		MacOnlyCipher x -> x
 
 {- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -}
-decryptCipher :: Gpg.GpgCmd -> StorableCipher -> IO Cipher
+decryptCipher :: LensGpgEncParams c => Gpg.GpgCmd -> c -> StorableCipher -> IO Cipher
-decryptCipher _ (SharedCipher t) = return $ Cipher t
+decryptCipher _ _ (SharedCipher t) = return $ Cipher t
-decryptCipher _ (SharedPubKeyCipher t _) = return $ MacOnlyCipher t
+decryptCipher _ _ (SharedPubKeyCipher t _) = return $ MacOnlyCipher t
-decryptCipher cmd (EncryptedCipher t variant _) =
+decryptCipher cmd c (EncryptedCipher t variant _) =
-	mkCipher <$> Gpg.pipeStrict cmd [ Param "--decrypt" ] t
+	mkCipher <$> Gpg.pipeStrict cmd params t
   where
 	mkCipher = case variant of
 		Hybrid -> Cipher
 		PubKey -> MacOnlyCipher
+	params = Param "--decrypt" : getGpgDecParams c
 
 type EncKey = Key -> Key
 

Remote/Bup.hs

@@ -91,13 +91,13 @@ gen r u c gc = do
 		}
 
 bupSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-bupSetup mu _ c _ = do
+bupSetup mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
 
 	-- verify configuration is sane
 	let buprepo = fromMaybe (error "Specify buprepo=") $
 		M.lookup "buprepo" c
-	(c', _encsetup) <- encryptionSetup c
+	(c', _encsetup) <- encryptionSetup c gc
 
 	-- bup init will create the repository.
 	-- (If the repository already exists, bup init again appears safe.)

Remote/Ddar.hs

@@ -83,13 +83,13 @@ gen r u c gc = do
 		}
 
 ddarSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-ddarSetup mu _ c _ = do
+ddarSetup mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
 
 	-- verify configuration is sane
 	let ddarrepo = fromMaybe (error "Specify ddarrepo=") $
 		M.lookup "ddarrepo" c
-	(c', _encsetup) <- encryptionSetup c
+	(c', _encsetup) <- encryptionSetup c gc
 
 	-- The ddarrepo is stored in git config, as well as this repo's
 	-- persistant state, so it can vary between hosts.

Remote/Directory.hs

@@ -78,7 +78,7 @@ gen r u c gc = do
 	dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
 
 directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-directorySetup mu _ c _ = do
+directorySetup mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
 	-- verify configuration is sane
 	let dir = fromMaybe (error "Specify directory=") $
@@ -86,7 +86,7 @@ directorySetup mu _ c _ = do
 	absdir <- liftIO $ absPath dir
 	liftIO $ unlessM (doesDirectoryExist absdir) $
 		error $ "Directory does not exist: " ++ absdir
-	(c', _encsetup) <- encryptionSetup c
+	(c', _encsetup) <- encryptionSetup c gc
 
 	-- The directory is stored in git config, not in this remote's
 	-- persistant state, so it can vary between hosts.

Remote/External.hs

@@ -113,7 +113,7 @@ externalSetup mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
 	let externaltype = fromMaybe (error "Specify externaltype=") $
 		M.lookup "externaltype" c
-	(c', _encsetup) <- encryptionSetup c
+	(c', _encsetup) <- encryptionSetup c gc
 
 	c'' <- case M.lookup "readonly" c of
 		Just v | isTrue v == Just True -> do

Remote/GCrypt.hs

@@ -170,12 +170,12 @@ unsupportedUrl :: a
 unsupportedUrl = error "using non-ssh remote repo url with gcrypt is not supported"
 
 gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-gCryptSetup mu _ c _ = go $ M.lookup "gitrepo" c
+gCryptSetup mu _ c gc = go $ M.lookup "gitrepo" c
   where
 	remotename = fromJust (M.lookup "name" c)
 	go Nothing = error "Specify gitrepo="
 	go (Just gitrepo) = do
-		(c', _encsetup) <- encryptionSetup c
+		(c', _encsetup) <- encryptionSetup c gc
 		inRepo $ Git.Command.run 
 			[ Param "remote", Param "add"
 			, Param remotename

Remote/Glacier.hs

@@ -84,7 +84,7 @@ glacierSetup mu mcreds c gc = do
 	glacierSetup' (isJust mu) u mcreds c gc
 glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
 glacierSetup' enabling u mcreds c gc = do
-	(c', encsetup) <- encryptionSetup c
+	(c', encsetup) <- encryptionSetup c gc
 	c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
 	let fullconfig = c'' `M.union` defaults
 	unless enabling $
@@ -288,7 +288,7 @@ jobList r keys = go =<< glacierEnv (config r) (gitconfig r) (uuid r)
 			else do
 				enckeys <- forM keys $ \k ->
 					maybe k (\(_, enck) -> enck k)
-						<$> cipherKey (config r)
+						<$> cipherKey (config r) (gitconfig r)
 				let keymap = M.fromList $ zip enckeys keys
 				let convert = mapMaybe (`M.lookup` keymap)
 				return (convert succeeded, convert failed)

Remote/Helper/Encryptable.hs

@@ -48,8 +48,8 @@ encryptionAlreadySetup = EncryptionIsSetup
  - an encryption key, or not encrypt. An encrypted cipher is created, or is
  - updated to be accessible to an additional encryption key. Or the user
  - could opt to use a shared cipher, which is stored unencrypted. -}
-encryptionSetup :: RemoteConfig -> Annex (RemoteConfig, EncryptionIsSetup)
+encryptionSetup :: RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, EncryptionIsSetup)
-encryptionSetup c = do
+encryptionSetup c gc = do
 	cmd <- gpgCmd <$> Annex.getGitConfig
 	maybe (genCipher cmd) (updateCipher cmd) (extractCipher c)
   where
@@ -78,10 +78,10 @@ encryptionSetup c = do
 	updateCipher cmd v = case v of
 		SharedCipher _ | maybe True (== "shared") encryption -> return (c', EncryptionIsSetup)
 		EncryptedCipher _ variant _
-			| maybe True (== if variant == Hybrid then "hybrid" else "pubkey") encryption ->
+			| maybe True (== if variant == Hybrid then "hybrid" else "pubkey") encryption -> do
-				use "encryption update" $ updateCipherKeyIds cmd newkeys v
+				use "encryption update" $ updateCipherKeyIds cmd (c, gc) newkeys v
 		SharedPubKeyCipher _ _ ->
-			use "encryption update" $ updateCipherKeyIds cmd newkeys v
+			use "encryption update" $ updateCipherKeyIds cmd (c, gc) newkeys v
 		_ -> cannotchange
 	encsetup a = use "encryption setup" . a =<< highRandomQuality
 	use m a = do
@@ -99,13 +99,13 @@ encryptionSetup c = do
 		-- remotes (while being backward-compatible).
 		[ "keyid", "keyid+", "keyid-", "highRandomQuality" ]
 
-remoteCipher :: RemoteConfig -> Annex (Maybe Cipher)
+remoteCipher :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe Cipher)
-remoteCipher = fmap fst <$$> remoteCipher'
+remoteCipher c gc = fmap fst <$> remoteCipher' c gc
 
 {- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex
  - state. -}
-remoteCipher' :: RemoteConfig -> Annex (Maybe (Cipher, StorableCipher))
+remoteCipher' :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, StorableCipher))
-remoteCipher' c = go $ extractCipher c
+remoteCipher' c gc = go $ extractCipher c
   where
 	go Nothing = return Nothing
 	go (Just encipher) = do
@@ -114,7 +114,7 @@ remoteCipher' c = go $ extractCipher c
 			Just cipher -> return $ Just (cipher, encipher)
 			Nothing -> do
 				cmd <- gpgCmd <$> Annex.getGitConfig
-				cipher <- liftIO $ decryptCipher cmd encipher
+				cipher <- liftIO $ decryptCipher cmd (c, gc) encipher
 				Annex.changeState (\s -> s { Annex.ciphers = M.insert encipher cipher cache })
 				return $ Just (cipher, encipher)
 
@@ -134,8 +134,8 @@ embedCreds c
 	| otherwise = False
 
 {- Gets encryption Cipher, and key encryptor. -}
-cipherKey :: RemoteConfig -> Annex (Maybe (Cipher, EncKey))
+cipherKey :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey))
-cipherKey c = fmap make <$> remoteCipher c
+cipherKey c gc = fmap make <$> remoteCipher c gc
   where
 	make ciphertext = (ciphertext, encryptKey mac ciphertext)
 	mac = fromMaybe defaultMac $ M.lookup "mac" c >>= readMac

Remote/Helper/Special.hs

@@ -176,7 +176,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
 			then whereisKey baser
 			else Nothing
 		}
-	cip = cipherKey c
+	cip = cipherKey c (gitconfig baser)
 	isencrypted = isJust (extractCipher c)
 
 	safely a = catchNonAsync a (\e -> warning (show e) >> return False)

Remote/Hook.hs

@@ -71,11 +71,11 @@ gen r u c gc = do
 	hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
 
 hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-hookSetup mu _ c _ = do
+hookSetup mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
 	let hooktype = fromMaybe (error "Specify hooktype=") $
 		M.lookup "hooktype" c
-	(c', _encsetup) <- encryptionSetup c
+	(c', _encsetup) <- encryptionSetup c gc
 	gitConfigSpecialRemote u c' "hooktype" hooktype
 	return (c', u)
 

Remote/Rsync.hs

@@ -138,12 +138,12 @@ rsyncTransport gc url
 	fromNull as xs = if null xs then as else xs
 
 rsyncSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-rsyncSetup mu _ c _ = do
+rsyncSetup mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
 	-- verify configuration is sane
 	let url = fromMaybe (error "Specify rsyncurl=") $
 		M.lookup "rsyncurl" c
-	(c', _encsetup) <- encryptionSetup c
+	(c', _encsetup) <- encryptionSetup c gc
 
 	-- The rsyncurl is stored in git config, not only in this remote's
 	-- persistant state, so it can vary between hosts.

Remote/S3.hs

@@ -123,7 +123,7 @@ s3Setup' new u mcreds c gc
 		return (fullconfig, u)
 
 	defaulthost = do
-		(c', encsetup) <- encryptionSetup c
+		(c', encsetup) <- encryptionSetup c gc
 		c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
 		let fullconfig = c'' `M.union` defaults
 		when new $

Remote/WebDAV.hs

@@ -87,7 +87,7 @@ webdavSetup mu mcreds c gc = do
 	url <- case M.lookup "url" c of
 		Nothing -> error "Specify url="
 		Just url -> return url
-	(c', encsetup) <- encryptionSetup c
+	(c', encsetup) <- encryptionSetup c gc
 	creds <- maybe (getCreds c' gc u) (return . Just) mcreds
 	testDav url creds
 	gitConfigSpecialRemote u c' "webdav" "true"

Test.hs

@@ -50,6 +50,7 @@ import qualified Git.LsTree
 import qualified Git.FilePath
 import qualified Annex.Locations
 import qualified Types.KeySource
+import qualified Types.Remote
 import qualified Types.Backend
 import qualified Types.TrustLevel
 import qualified Types
@@ -1525,6 +1526,7 @@ test_crypto = do
 	testscheme "pubkey"
   where
 	gpgcmd = Utility.Gpg.mkGpgCmd Nothing
+	encparams = (mempty :: Types.Remote.RemoteConfig, def :: Types.RemoteGitConfig)
 	testscheme scheme = intmpclonerepo $ whenM (Utility.Path.inPath (Utility.Gpg.unGpgCmd gpgcmd)) $ do
 		Utility.Gpg.testTestHarness gpgcmd 
 			@? "test harness self-test failed"
@@ -1580,7 +1582,7 @@ test_crypto = do
 		checkScheme Types.Crypto.Hybrid = scheme == "hybrid"
 		checkScheme Types.Crypto.PubKey = scheme == "pubkey"
 		checkKeys cip mvariant = do
-			cipher <- Crypto.decryptCipher gpgcmd cip
+			cipher <- Crypto.decryptCipher gpgcmd encparams cip
 			files <- filterM doesFileExist $
 				map ("dir" </>) $ concatMap (key2files cipher) keys
 			return (not $ null files) <&&> allM (checkFile mvariant) files

debian/changelog

@@ -21,7 +21,8 @@ git-annex (6.20160512) UNRELEASED; urgency=medium
     has a dotfile in its root.
   * Support building with ghc 8.0.1.
   * Pass the various gnupg-options configs to gpg in several cases where
-    they were not before.
+    they were not before. Most notably, gnupg-decrypt-options is now
+    passed when decrypting an encrypted cipher.
 
  -- Joey Hess <id@joeyh.name>  Wed, 11 May 2016 16:08:38 -0400