From c498269a88fb9117f6689f0a4445f0ef3c0e2260 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 14 Jan 2020 13:18:15 -0400
Subject: [PATCH] convert configParser to Annex action and add passthrough
 option

Needed so Remote.External can query the external program for its
configs. When the external program does not support the query,
the passthrough option will make all input fields be available.
---
 Annex/SpecialRemote/Config.hs | 23 ++++++++++++++---------
 Creds.hs                      |  7 +++----
 Remote/Directory.hs           |  3 ++-
 Remote/GCrypt.hs              | 12 +++++++-----
 Remote/Git.hs                 |  3 ++-
 Remote/GitLFS.hs              |  5 +++--
 Remote/Helper/Chunked.hs      |  6 +++---
 Remote/Helper/Encryptable.hs  | 12 +++++++-----
 Remote/Helper/ExportImport.hs | 15 ++++++++-------
 Remote/Helper/Special.hs      |  8 ++++----
 Remote/List.hs                |  2 +-
 Remote/P2P.hs                 |  2 +-
 Remote/Rsync.hs               |  2 +-
 Remote/Web.hs                 |  2 +-
 Types/Remote.hs               |  2 +-
 Types/RemoteConfig.hs         | 13 ++++++++++++-
 16 files changed, 70 insertions(+), 47 deletions(-)

diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs
index 0ce0a4d258..0a30d46330 100644
--- a/Annex/SpecialRemote/Config.hs
+++ b/Annex/SpecialRemote/Config.hs
@@ -93,8 +93,8 @@ importTree :: ParsedRemoteConfig -> Bool
 importTree = fromMaybe False . getRemoteConfigValue importTreeField
 
 {- Parsers for fields that are common to all special remotes. -}
-commonFieldsParser :: [RemoteConfigParser]
-commonFieldsParser =
+commonFieldParsers :: [RemoteConfigFieldParser]
+commonFieldParsers =
 	[ optionalStringParser nameField
 	, optionalStringParser sameasNameField
 	, optionalStringParser sameasUUIDField
@@ -166,11 +166,13 @@ getRemoteConfigValue f m = case M.lookup f m of
 			]
 	Nothing -> Nothing
 
-parseRemoteConfig :: RemoteConfig -> [RemoteConfigParser] -> Either String ParsedRemoteConfig
-parseRemoteConfig c ps =
-	go [] (M.filterWithKey notaccepted c) (ps ++ commonFieldsParser)
+parseRemoteConfig :: RemoteConfig -> RemoteConfigParser -> Either String ParsedRemoteConfig
+parseRemoteConfig c rpc =
+	go [] (M.filterWithKey notaccepted c) (remoteConfigFieldParsers rpc ++ commonFieldParsers)
   where
 	go l c' []
+		| remoteConfigRestPassthrough rpc = Right $ M.fromList $
+			l ++ map (uncurry passthrough) (M.toList c')
 		| M.null c' = Right (M.fromList l)
 		| otherwise = Left $ "Unexpected fields: " ++
 			unwords (map fromProposedAccepted (M.keys c'))
@@ -179,19 +181,22 @@ parseRemoteConfig c ps =
 		case v of
 			Just v' -> go ((f,v'):l) (M.delete f c') rest
 			Nothing -> go l (M.delete f c') rest
+	
+	passthrough f v = (f, RemoteConfigValue (fromProposedAccepted v))
+
 	notaccepted (Proposed _) _ = True
 	notaccepted (Accepted _) _ = False
 
-optionalStringParser :: RemoteConfigField -> RemoteConfigParser
+optionalStringParser :: RemoteConfigField -> RemoteConfigFieldParser
 optionalStringParser f = (f, p)
   where
 	p (Just v) _c = Right (Just (RemoteConfigValue (fromProposedAccepted v)))
 	p Nothing _c = Right Nothing
 
-yesNoParser :: RemoteConfigField -> Bool -> RemoteConfigParser
+yesNoParser :: RemoteConfigField -> Bool -> RemoteConfigFieldParser
 yesNoParser = genParser yesNo "yes or no"
 
-trueFalseParser :: RemoteConfigField -> Bool -> RemoteConfigParser
+trueFalseParser :: RemoteConfigField -> Bool -> RemoteConfigFieldParser
 trueFalseParser = genParser Git.Config.isTrueFalse "true or false"
 
 genParser
@@ -200,7 +205,7 @@ genParser
 	-> String -- ^ description of the value
 	-> RemoteConfigField
 	-> t -- ^ fallback value
-	-> RemoteConfigParser
+	-> RemoteConfigFieldParser
 genParser parse desc f fallback = (f, p)
   where
 	p Nothing _c = Right (Just (RemoteConfigValue fallback))
diff --git a/Creds.hs b/Creds.hs
index a1c81517d2..52db539843 100644
--- a/Creds.hs
+++ b/Creds.hs
@@ -1,6 +1,6 @@
 {- Credentials storage
  -
- - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -30,7 +30,7 @@ import Utility.FileMode
 import Crypto
 import Types.Remote (RemoteConfig, RemoteConfigField)
 import Types.ProposedAccepted
-import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher, encryptionConfigParser)
+import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher, parseEncryptionConfig)
 import Utility.Env (getEnv)
 
 import qualified Data.ByteString.Lazy.Char8 as L
@@ -79,8 +79,7 @@ setRemoteCredPair encsetup c gc storage mcreds = case mcreds of
 	storeconfig creds key Nothing =
 		return $ M.insert key (Accepted (toB64 $ encodeCredPair creds)) c
 	
-	pc = either (const mempty) id
-		(parseRemoteConfig c encryptionConfigParser)
+	pc = either (const mempty) id (parseEncryptionConfig c)
 
 {- Gets a remote's credpair, from the environment if set, otherwise
  - from the cache in gitAnnexCredsDir, or failing that, from the
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index b3421e2a04..d70c50e2f4 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -42,7 +42,8 @@ remote = specialRemoteType $ RemoteType
 	{ typename = "directory"
 	, enumerate = const (findSpecialRemotes "directory")
 	, generate = gen
-	, configParser = [optionalStringParser directoryField]
+	, configParser = mkRemoteConfigParser
+		[optionalStringParser directoryField]
 	, setup = directorySetup
 	, exportSupported = exportIsSupported
 	, importSupported = importIsSupported
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 507a2ffd14..497c967e0a 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -66,7 +66,8 @@ remote = specialRemoteType $ RemoteType
 	-- and will call our gen on them.
 	, enumerate = const (return [])
 	, generate = gen
-	, configParser = [optionalStringParser gitRepoField]
+	, configParser = mkRemoteConfigParser
+		[optionalStringParser gitRepoField]
 	, setup = gCryptSetup
 	, exportSupported = exportUnsupported
 	, importSupported = importUnsupported
@@ -104,8 +105,9 @@ gen baser u c gc rs = do
 		v <- M.lookup u' <$> readRemoteLog
 		case (Git.remoteName baser, v) of
 			(Just remotename, Just c') -> do
-				pc <- either giveup return $
-					parseRemoteConfig c' (configParser remote)
+				pc <- either giveup return
+					. parseRemoteConfig c'
+					=<< configParser remote
 				setGcryptEncryption pc remotename
 				storeUUIDIn (remoteConfig baser "uuid") u'
 				setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid
@@ -214,8 +216,8 @@ gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c
 				| Git.repoLocation r == url -> noop
 				| otherwise -> error "Another remote with the same name already exists."		
 
-		pc <- either giveup return $
-			parseRemoteConfig c' (configParser remote)
+		pc <- either giveup return . parseRemoteConfig c'
+			=<< configParser remote
 		setGcryptEncryption pc remotename
 
 		{- Run a git fetch and a push to the git repo in order to get
diff --git a/Remote/Git.hs b/Remote/Git.hs
index c910a5c524..11995a7175 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -80,7 +80,8 @@ remote = RemoteType
 	{ typename = "git"
 	, enumerate = list
 	, generate = gen
-	, configParser = [optionalStringParser locationField]
+	, configParser = mkRemoteConfigParser
+		[optionalStringParser locationField]
 	, setup = gitSetup
 	, exportSupported = exportUnsupported
 	, importSupported = importUnsupported
diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs
index 8ed0586ebc..0f99ddb507 100644
--- a/Remote/GitLFS.hs
+++ b/Remote/GitLFS.hs
@@ -60,7 +60,8 @@ remote = specialRemoteType $ RemoteType
 	-- and will call our gen on them.
 	, enumerate = const (return [])
 	, generate = gen
-	, configParser = [optionalStringParser urlField]
+	, configParser = mkRemoteConfigParser
+		[optionalStringParser urlField]
 	, setup = mySetup
 	, exportSupported = exportUnsupported
 	, importSupported = importUnsupported
@@ -133,7 +134,7 @@ mySetup _ mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
 
 	(c', _encsetup) <- encryptionSetup c gc
-	pc <- either giveup return $ parseRemoteConfig c' (configParser remote)
+	pc <- either giveup return . parseRemoteConfig c' =<< configParser remote
 	case (isEncrypted pc, Git.GCrypt.urlPrefix `isPrefixOf` url) of
 		(False, False) -> noop
 		(True, True) -> Remote.GCrypt.setGcryptEncryption pc remotename
diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs
index cff59e7312..7fc11283d9 100644
--- a/Remote/Helper/Chunked.hs
+++ b/Remote/Helper/Chunked.hs
@@ -10,7 +10,7 @@ module Remote.Helper.Chunked (
 	ChunkConfig(..),
 	noChunks,
 	describeChunkConfig,
-	chunkConfigParser,
+	chunkConfigParsers,
 	getChunkConfig,
 	storeChunks,
 	removeChunks,
@@ -49,8 +49,8 @@ noChunks :: ChunkConfig -> Bool
 noChunks NoChunks = True
 noChunks _ = False
 
-chunkConfigParser :: [RemoteConfigParser]
-chunkConfigParser =
+chunkConfigParsers :: [RemoteConfigFieldParser]
+chunkConfigParsers =
 	[ optionalStringParser chunksizeField
 	, optionalStringParser chunkField
 	]
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
index dda8020ac5..cb8cee8074 100644
--- a/Remote/Helper/Encryptable.hs
+++ b/Remote/Helper/Encryptable.hs
@@ -12,7 +12,7 @@ module Remote.Helper.Encryptable (
 	encryptionSetup,
 	noEncryptionUsed,
 	encryptionAlreadySetup,
-	encryptionConfigParser,
+	encryptionConfigParsers,
 	parseEncryptionConfig,
 	remoteCipher,
 	remoteCipher',
@@ -51,8 +51,8 @@ noEncryptionUsed = NoEncryption
 encryptionAlreadySetup :: EncryptionIsSetup
 encryptionAlreadySetup = EncryptionIsSetup
 
-encryptionConfigParser :: [RemoteConfigParser]
-encryptionConfigParser =
+encryptionConfigParsers :: [RemoteConfigFieldParser]
+encryptionConfigParsers =
 	[ (encryptionField, \v c -> Just  . RemoteConfigValue <$> parseEncryptionMethod (fmap fromProposedAccepted v) c)
 	, optionalStringParser cipherField
 	, optionalStringParser cipherkeysField
@@ -66,11 +66,13 @@ encryptionConfigParser =
 	]
 
 encryptionConfigs :: S.Set RemoteConfigField
-encryptionConfigs = S.fromList (map fst encryptionConfigParser)
+encryptionConfigs = S.fromList (map fst encryptionConfigParsers)
 
 -- Parse only encryption fields, ignoring all others.
 parseEncryptionConfig :: RemoteConfig -> Either String ParsedRemoteConfig
-parseEncryptionConfig c = parseRemoteConfig (M.restrictKeys c encryptionConfigs) encryptionConfigParser
+parseEncryptionConfig c = parseRemoteConfig
+	(M.restrictKeys c encryptionConfigs)
+	(RemoteConfigParser encryptionConfigParsers False)
 
 parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod
 parseEncryptionMethod (Just "none") _ = Right NoneEncryption
diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs
index 04f41322d5..2db7deb14f 100644
--- a/Remote/Helper/ExportImport.hs
+++ b/Remote/Helper/ExportImport.hs
@@ -77,9 +77,10 @@ adjustExportImportRemoteType rt = rt
 	, configParser = configparser
 	}
   where
-	configparser = configParser rt ++ exportImportConfigParser
+	configparser = addRemoteConfigParser exportImportConfigParsers 
+		<$> configParser rt
 	setup' st mu cp c gc = do
-		pc <- either giveup return $ parseRemoteConfig c configparser
+		pc <- either giveup return . parseRemoteConfig c =<< configparser
 		let checkconfig supported configured configfield cont =
 			ifM (supported rt pc gc)
 				( case st of
@@ -87,9 +88,9 @@ adjustExportImportRemoteType rt = rt
 						| configured pc && isEncrypted pc ->
 							giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield
 						| otherwise -> cont
-					Enable oldc ->
-						let oldpc = either mempty id $ parseRemoteConfig oldc configparser
-						in if configured pc /= configured oldpc
+					Enable oldc -> do
+						oldpc <- either mempty id . parseRemoteConfig oldc <$> configparser
+						if configured pc /= configured oldpc
 							then giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote"
 							else cont
 				, if configured pc
@@ -102,8 +103,8 @@ adjustExportImportRemoteType rt = rt
 					then giveup "cannot enable importtree=yes without also enabling exporttree=yes"
 					else setup rt st mu cp c gc
 
-exportImportConfigParser :: [RemoteConfigParser]
-exportImportConfigParser =
+exportImportConfigParsers :: [RemoteConfigFieldParser]
+exportImportConfigParsers =
 	[ yesNoParser exportTreeField False
 	, yesNoParser importTreeField False
 	]
diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs
index 26e544a22f..f4e53a1fd8 100644
--- a/Remote/Helper/Special.hs
+++ b/Remote/Helper/Special.hs
@@ -28,7 +28,6 @@ module Remote.Helper.Special (
 	retreiveKeyFileDummy,
 	removeKeyDummy,
 	checkPresentDummy,
-	specialRemoteConfigParser,
 	SpecialRemoteCfg(..),
 	specialRemoteCfg,
 	specialRemoteType,
@@ -170,11 +169,12 @@ specialRemoteCfg c = SpecialRemoteCfg (getChunkConfig c) True
 -- Modifies a base RemoteType to support chunking and encryption configs.
 specialRemoteType :: RemoteType -> RemoteType
 specialRemoteType r = r 
-	{ configParser = configParser r ++ specialRemoteConfigParser
+	{ configParser = addRemoteConfigParser specialRemoteConfigParsers
+		<$> configParser r
 	}
 
-specialRemoteConfigParser :: [RemoteConfigParser]
-specialRemoteConfigParser = chunkConfigParser ++ encryptionConfigParser
+specialRemoteConfigParsers :: [RemoteConfigFieldParser]
+specialRemoteConfigParsers = chunkConfigParsers ++ encryptionConfigParsers
 
 -- Modifies a base Remote to support both chunking and encryption,
 -- which special remotes typically should support.
diff --git a/Remote/List.hs b/Remote/List.hs
index e1621a3a29..e65e9d1c7e 100644
--- a/Remote/List.hs
+++ b/Remote/List.hs
@@ -122,7 +122,7 @@ remoteGen m t g = do
 	let cu = fromMaybe u $ remoteAnnexConfigUUID gc
 	let rs = RemoteStateHandle cu
 	let c = fromMaybe M.empty $ M.lookup cu m
-	let pc = either mempty id (parseRemoteConfig c (configParser t))
+	pc <- either mempty id . parseRemoteConfig c <$> configParser t
 	generate t g u pc gc rs >>= \case
 		Nothing -> return Nothing
 		Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs
diff --git a/Remote/P2P.hs b/Remote/P2P.hs
index 28c75a0be0..be90ce55f6 100644
--- a/Remote/P2P.hs
+++ b/Remote/P2P.hs
@@ -36,7 +36,7 @@ remote = RemoteType
 	-- and will call chainGen on them.
 	, enumerate = const (return [])
 	, generate = \_ _ _ _ _ -> return Nothing
-	, configParser = []
+	, configParser = mkRemoteConfigParser []
 	, setup = error "P2P remotes are set up using git-annex p2p"
 	, exportSupported = exportUnsupported
 	, importSupported = importUnsupported
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 959fd4dd7e..6ff6d327da 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -51,7 +51,7 @@ remote = specialRemoteType $ RemoteType
 	{ typename = "rsync"
 	, enumerate = const (findSpecialRemotes "rsyncurl")
 	, generate = gen
-	, configParser =
+	, configParser = mkRemoteConfigParser
 		[ yesNoParser shellEscapeField True
 		, optionalStringParser rsyncUrlField
 		]
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 2f6ab81597..1df743ed3a 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -27,7 +27,7 @@ remote = RemoteType
 	{ typename = "web"
 	, enumerate = list
 	, generate = gen
-	, configParser = []
+	, configParser = mkRemoteConfigParser []
 	, setup = error "not supported"
 	, exportSupported = exportUnsupported
 	, importSupported = importUnsupported
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 93ee1c53ad..d56fa6fd25 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -60,7 +60,7 @@ data RemoteTypeA a = RemoteType
 	-- generates a remote of this type
 	, generate :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))
 	-- parse configs of remotes of this type
-	, configParser :: [RemoteConfigParser]
+	, configParser :: a RemoteConfigParser
 	-- initializes or enables a remote
 	, setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
 	-- check if a remote of this type is able to support export
diff --git a/Types/RemoteConfig.hs b/Types/RemoteConfig.hs
index 5035aa036f..4f6bb9b8fd 100644
--- a/Types/RemoteConfig.hs
+++ b/Types/RemoteConfig.hs
@@ -37,4 +37,15 @@ data RemoteConfigValue where
  - Presence of fields that are not included in this list will cause
  - a parse failure.
  -}
-type RemoteConfigParser = (RemoteConfigField, Maybe (ProposedAccepted String) -> RemoteConfig -> Either String (Maybe RemoteConfigValue))
+type RemoteConfigFieldParser = (RemoteConfigField, Maybe (ProposedAccepted String) -> RemoteConfig -> Either String (Maybe RemoteConfigValue))
+
+data RemoteConfigParser = RemoteConfigParser
+	{ remoteConfigFieldParsers :: [RemoteConfigFieldParser]
+	, remoteConfigRestPassthrough :: Bool
+	}
+
+mkRemoteConfigParser :: Monad m => [RemoteConfigFieldParser] -> m RemoteConfigParser
+mkRemoteConfigParser l = pure (RemoteConfigParser l False)
+
+addRemoteConfigParser :: [RemoteConfigFieldParser] -> RemoteConfigParser -> RemoteConfigParser
+addRemoteConfigParser l rpc = rpc { remoteConfigFieldParsers = remoteConfigFieldParsers rpc ++ l }
-- 
2.30.2