ported Remote.External

Not yet added anything to the protocol to get a list of remote config
fields; any fields will be accepted and are available for the external
remote to use as before.

There is one minor behavior change.. Before, GETCONFIG could be passed a
field such as type, externaltype, encryption, etc, and would get the
value of that. Now, GETCONFIG only works on fields that don't have a
defined meaning to git-annex, so are passed through to the external
remote. This seems unlikely to affect any external special remotes in
practice.

Creds.hs

@@ -9,6 +9,7 @@ module Creds (
 	module Types.Creds,
 	CredPairStorage(..),
 	setRemoteCredPair,
+	setRemoteCredPair',
 	getRemoteCredPair,
 	getRemoteCredPairFor,
 	missingCredPairFor,
@@ -56,8 +57,20 @@ data CredPairStorage = CredPairStorage
  - cipher. The EncryptionIsSetup is witness to that being the case.
  -}
 setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
-setRemoteCredPair encsetup c gc storage mcreds = case mcreds of
+setRemoteCredPair = setRemoteCredPair' id
-	Nothing -> maybe (return c) (setRemoteCredPair encsetup c gc storage . Just)
+	(either (const mempty) id . parseEncryptionConfig)
+
+setRemoteCredPair'
+	:: (ProposedAccepted String -> a)
+	-> (M.Map RemoteConfigField a -> ParsedRemoteConfig)
+	-> EncryptionIsSetup
+	-> M.Map RemoteConfigField a
+	-> RemoteGitConfig
+	-> CredPairStorage
+	-> Maybe CredPair
+	-> Annex (M.Map RemoteConfigField a)
+setRemoteCredPair' mkval parseconfig encsetup c gc storage mcreds = case mcreds of
+	Nothing -> maybe (return c) (setRemoteCredPair' mkval parseconfig encsetup c gc storage . Just)
 		=<< getRemoteCredPair pc gc storage
 	Just creds
 		| embedCreds pc -> do
@@ -75,11 +88,11 @@ setRemoteCredPair encsetup c gc storage mcreds = case mcreds of
 		s <- liftIO $ encrypt cmd (pc, gc) cipher
 			(feedBytes $ L.pack $ encodeCredPair creds)
 			(readBytes $ return . L.unpack)
-		return $ M.insert key (Accepted (toB64 s)) c
+		return $ M.insert key (mkval (Accepted (toB64 s))) c
 	storeconfig creds key Nothing =
-		return $ M.insert key (Accepted (toB64 $ encodeCredPair creds)) c
+		return $ M.insert key (mkval (Accepted (toB64 $ encodeCredPair creds))) c
 	
-	pc = either (const mempty) id (parseEncryptionConfig c)
+	pc = parseconfig c
 
 {- Gets a remote's credpair, from the environment if set, otherwise
  - from the cache in gitAnnexCredsDir, or failing that, from the

Remote/External.hs

@@ -1,6 +1,6 @@
 {- External special remote interface.
  -
- - Copyright 2013-2018 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -19,8 +19,9 @@ import Types.UrlContents
 import Types.ProposedAccepted
 import qualified Git
 import Config
-import Git.Config (isTrueFalse, boolConfig)
+import Git.Config (boolConfig)
 import Git.Env
+import Annex.SpecialRemote.Config
 import Remote.Helper.Special
 import Remote.Helper.ExportImport
 import Remote.Helper.ReadOnly
@@ -48,12 +49,28 @@ remote = RemoteType
 	{ typename = "external"
 	, enumerate = const (findSpecialRemotes "externaltype")
 	, generate = gen
+	, configParser = pure remoteConfigParser
 	, setup = externalSetup
 	, exportSupported = checkExportSupported
 	, importSupported = importUnsupported
 	}
 
-gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+remoteConfigParser :: RemoteConfigParser
+remoteConfigParser = RemoteConfigParser
+	{ remoteConfigFieldParsers =
+		[ optionalStringParser externaltypeField
+		, trueFalseParser readonlyField False
+		]
+	, remoteConfigRestPassthrough = const True
+	}
+
+externaltypeField :: RemoteConfigField
+externaltypeField = Accepted "externaltype"
+
+readonlyField :: RemoteConfigField
+readonlyField = Accepted "readonly"
+
+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
 gen r u c gc rs
 	-- readonly mode only downloads urls; does not use external program
 	| remoteAnnexReadOnly gc = do
@@ -153,31 +170,36 @@ gen r u c gc rs
 externalSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
 externalSetup _ mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
-	let externaltype = maybe (giveup "Specify externaltype=") fromProposedAccepted $
+	pc <- either giveup return $ parseRemoteConfig c remoteConfigParser
-		M.lookup (Accepted "externaltype") c
+	let externaltype = fromMaybe (giveup "Specify externaltype=") $
+		getRemoteConfigValue externaltypeField pc
 	(c', _encsetup) <- encryptionSetup c gc
 
-	c'' <- case parseProposedAccepted (Accepted "readonly") c isTrueFalse False "true or false" of
+	c'' <- case getRemoteConfigValue readonlyField pc of
-		Left err -> giveup err
+		Just True -> do
-		Right (Just True) -> do
 			setConfig (remoteConfig (fromJust (lookupName c)) "readonly") (boolConfig True)
 			return c'
 		_ -> do
-			external <- newExternal externaltype u c' gc Nothing
+			pc' <- either giveup return $ parseRemoteConfig c' remoteConfigParser
+			external <- newExternal externaltype u pc' gc Nothing
 			handleRequest external INITREMOTE Nothing $ \resp -> case resp of
 				INITREMOTE_SUCCESS -> result ()
 				INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg
 				_ -> Nothing
-			withExternalState external $
+			-- Any config changes the external made before
-				liftIO . atomically . readTVar . externalConfig
+			-- responding to INITREMOTE need to be applied to
+			-- the RemoteConfig.
+			changes <- withExternalState external $
+				liftIO . atomically . readTVar . externalConfigChanges
+			return (changes c')
 
 	gitConfigSpecialRemote u c'' [("externaltype", externaltype)]
 	return (c'', u)
 
-checkExportSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool
+checkExportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> Annex Bool
 checkExportSupported c gc = do
 	let externaltype = fromMaybe (giveup "Specify externaltype=") $
-		remoteAnnexExternalType gc <|> (fromProposedAccepted <$> M.lookup (Accepted "externaltype") c)
+		remoteAnnexExternalType gc <|> getRemoteConfigValue externaltypeField c
 	checkExportSupported' 
 		=<< newExternal externaltype NoUUID c gc Nothing
 
@@ -389,17 +411,23 @@ handleRequest' st external req mp responsehandler
 	handleRemoteRequest (DIRHASH_LOWER k) = 
 		send $ VALUE $ fromRawFilePath $ hashDirLower def k
 	handleRemoteRequest (SETCONFIG setting value) =
-		liftIO $ atomically $ modifyTVar' (externalConfig st) $
+		liftIO $ atomically $ do
-			M.insert (Accepted setting) (Accepted value)
+			modifyTVar' (externalConfig st) $
+				M.insert (Accepted setting) $
+					RemoteConfigValue (PassedThrough value)
+			modifyTVar' (externalConfigChanges st) $ \f ->
+				f . M.insert (Accepted setting) (Accepted value)
 	handleRemoteRequest (GETCONFIG setting) = do
-		value <- maybe "" fromProposedAccepted . M.lookup (Accepted setting)
+		value <- fromMaybe ""
+			. M.lookup (Accepted setting)
+			. getRemoteConfigPassedThrough
 			<$> liftIO (atomically $ readTVar $ externalConfig st)
 		send $ VALUE value
 	handleRemoteRequest (SETCREDS setting login password) = do
 		let v = externalConfig st
 		c <- liftIO $ atomically $ readTVar v
 		let gc = externalGitConfig external
-		c' <- setRemoteCredPair encryptionAlreadySetup c gc
+		c' <- setRemoteCredPair' RemoteConfigValue id encryptionAlreadySetup c gc
 			(credstorage setting)
 			(Just (login, password))
 		void $ liftIO $ atomically $ swapTVar v c'
@@ -581,6 +609,7 @@ startExternal external = do
 			createProcess p `catchIO` runerr cmdpath
 		stderrelay <- async $ errrelayer herr
 		cv <- newTVarIO $ externalDefaultConfig external
+		ccv <- newTVarIO id
 		pv <- newTVarIO Unprepared
 		pid <- atomically $ do
 			n <- succ <$> readTVar (externalLastPid external)
@@ -595,6 +624,7 @@ startExternal external = do
 				void $ waitForProcess ph
 			, externalPrepared = pv
 			, externalConfig = cv
+			, externalConfigChanges = ccv
 			}
 	
 	basecmd = externalRemoteProgram $ externalType external

Remote/External/Types.hs

@@ -1,6 +1,6 @@
 {- External special remote data types.
  -
- - Copyright 2013-2018 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -37,7 +37,8 @@ import Types.StandardGroups (PreferredContentExpression)
 import Utility.Metered (BytesProcessed(..))
 import Types.Transfer (Direction(..))
 import Config.Cost (Cost)
-import Types.Remote (RemoteConfig, RemoteStateHandle)
+import Types.RemoteState
+import Types.RemoteConfig
 import Types.Export
 import Types.Availability (Availability(..))
 import Types.Key
@@ -55,12 +56,12 @@ data External = External
 	-- ^ Contains states for external special remote processes
 	-- that are not currently in use.
 	, externalLastPid :: TVar PID
-	, externalDefaultConfig :: RemoteConfig
+	, externalDefaultConfig :: ParsedRemoteConfig
 	, externalGitConfig :: RemoteGitConfig
 	, externalRemoteStateHandle :: Maybe RemoteStateHandle
 	}
 
-newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Maybe RemoteStateHandle -> Annex External
+newExternal :: ExternalType -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> Maybe RemoteStateHandle -> Annex External
 newExternal externaltype u c gc rs = liftIO $ External
 	<$> pure externaltype
 	<*> pure u
@@ -78,7 +79,8 @@ data ExternalState = ExternalState
 	, externalShutdown :: IO ()
 	, externalPid :: PID
 	, externalPrepared :: TVar PrepareStatus
-	, externalConfig :: TVar RemoteConfig
+	, externalConfig :: TVar ParsedRemoteConfig
+	, externalConfigChanges :: TVar (RemoteConfig -> RemoteConfig)
 	}
 
 type PID = Int

Remote/List.hs

@@ -44,9 +44,7 @@ import qualified Remote.Glacier
 import qualified Remote.Ddar
 import qualified Remote.GitLFS
 import qualified Remote.Hook
-{-
 import qualified Remote.External
--}
 
 remoteTypes :: [RemoteType]
 remoteTypes = map adjustExportImportRemoteType
@@ -70,9 +68,7 @@ remoteTypes = map adjustExportImportRemoteType
 	, Remote.Ddar.remote
 	, Remote.GitLFS.remote
 	, Remote.Hook.remote
-{-
 	, Remote.External.remote
--}
 	]
 
 {- Builds a list of all available Remotes.