add LISTCONFIGS to external special remote protocol

Special remote programs that use GETCONFIG/SETCONFIG are recommended to implement it. The description is not yet used, but will be useful later when adding a way to make initremote list all accepted configs. configParser now takes a RemoteConfig parameter. Normally, that's not needed, because configParser returns a parter, it does not parse it itself. But, it's needed to look at externaltype and work out what external remote program to run for LISTCONFIGS. Note that, while externalUUID is changed to a Maybe UUID, checkExportSupported used to use NoUUID. The code that now checks for Nothing used to behave in some undefined way if the external program made requests that triggered it. Also, note that in externalSetup, once it generates external, it parses the RemoteConfig strictly. That generates a ParsedRemoteConfig, which is thrown away. The reason it's ok to throw that away, is that, if the strict parse succeeded, the result must be the same as the earlier, lenient parse. initremote of an external special remote now runs the program three times. First for LISTCONFIGS, then EXPORTSUPPORTED, and again LISTCONFIGS+INITREMOTE. It would not be hard to eliminate at least one of those, and it should be possible to only run the program once.
2020-01-17 15:30:14 -04:00 · 2020-01-17 15:30:14 -04:00 · 99cb3e75f1
commit 99cb3e75f1
parent 1ce722d86f
20 changed files with 158 additions and 76 deletions
--- a/Remote/External.hs
+++ b/Remote/External.hs
@ -43,27 +43,19 @@ import Control.Concurrent.STM
 import Control.Concurrent.Async
 import System.Log.Logger (debugM)
 import qualified Data.Map as M
+import qualified Data.Set as S

 remote :: RemoteType
-remote = RemoteType
+remote = specialRemoteType $ RemoteType
 	{ typename = "external"
 	, enumerate = const (findSpecialRemotes "externaltype")
 	, generate = gen
-	, configParser = pure remoteConfigParser
+	, configParser = remoteConfigParser
 	, setup = externalSetup
 	, exportSupported = checkExportSupported
 	, importSupported = importUnsupported
 	}

-remoteConfigParser :: RemoteConfigParser
-remoteConfigParser = RemoteConfigParser
-	{ remoteConfigFieldParsers =
-		[ optionalStringParser externaltypeField
-		, trueFalseParser readonlyField False
-		]
-	, remoteConfigRestPassthrough = const True
-	}
-
 externaltypeField :: RemoteConfigField
 externaltypeField = Accepted "externaltype"

@ -87,7 +79,7 @@ gen r u c gc rs
 			exportUnsupported
 			exportUnsupported
 	| otherwise = do
-		external <- newExternal externaltype u c gc (Just rs)
+		external <- newExternal externaltype (Just u) c (Just gc) (Just rs)
 		Annex.addCleanup (RemoteCleanup u) $ stopExternal external
 		cst <- getCost external r gc
 		avail <- getAvailability external r gc
@ -170,7 +162,7 @@ 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
-	pc <- either giveup return $ parseRemoteConfig c remoteConfigParser
+	pc <- either giveup return $ parseRemoteConfig c lenientRemoteConfigParser
 	let externaltype = fromMaybe (giveup "Specify externaltype=") $
 		getRemoteConfigValue externaltypeField pc
 	(c', _encsetup) <- encryptionSetup c gc
@ -180,8 +172,14 @@ externalSetup _ mu _ c gc = do
 			setConfig (remoteConfig (fromJust (lookupName c)) "readonly") (boolConfig True)
 			return c'
 		_ -> do
-			pc' <- either giveup return $ parseRemoteConfig c' remoteConfigParser
-			external <- newExternal externaltype u pc' gc Nothing
+			pc' <- either giveup return $ parseRemoteConfig c' lenientRemoteConfigParser
+			external <- newExternal externaltype (Just u) pc' (Just gc) Nothing
+			-- Now that we have an external, ask it to LISTCONFIGS, 
+			-- and re-parse the RemoteConfig strictly, so we can
+			-- error out if the user provided an unexpected config.
+			p <- strictRemoteConfigParser external
+			let p' = addRemoteConfigParser specialRemoteConfigParsers p
+			_ <- either giveup return $ parseRemoteConfig c' p'
 			handleRequest external INITREMOTE Nothing $ \resp -> case resp of
 				INITREMOTE_SUCCESS -> result ()
 				INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg
@ -201,7 +199,7 @@ checkExportSupported c gc = do
 	let externaltype = fromMaybe (giveup "Specify externaltype=") $
 		remoteAnnexExternalType gc <|> getRemoteConfigValue externaltypeField c
 	checkExportSupported' 
-		=<< newExternal externaltype NoUUID c gc Nothing
+		=<< newExternal externaltype Nothing c (Just gc) Nothing

 checkExportSupported' :: External -> Annex Bool
 checkExportSupported' external = go `catchNonAsync` (const (return False))
@ -423,30 +421,36 @@ handleRequest' st external req mp responsehandler
 			. 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' RemoteConfigValue id encryptionAlreadySetup c gc
-			(credstorage setting)
-			(Just (login, password))
-		void $ liftIO $ atomically $ swapTVar v c'
-	handleRemoteRequest (GETCREDS setting) = do
-		c <- liftIO $ atomically $ readTVar $ externalConfig st
-		let gc = externalGitConfig external
-		creds <- fromMaybe ("", "") <$> 
-			getRemoteCredPair c gc (credstorage setting)
-		send $ CREDS (fst creds) (snd creds)
-	handleRemoteRequest GETUUID = send $
-		VALUE $ fromUUID $ externalUUID external
+	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
+				(credstorage setting u)
+				(Just (login, password))
+			void $ liftIO $ atomically $ swapTVar v c'
+		_ -> senderror "cannot send SETCREDS here"
+	handleRemoteRequest (GETCREDS setting) = case (externalUUID external, externalGitConfig external) of
+		(Just u, Just gc) -> do
+			c <- liftIO $ atomically $ readTVar $ externalConfig st
+			creds <- fromMaybe ("", "") <$> 
+				getRemoteCredPair c gc (credstorage setting u)
+			send $ CREDS (fst creds) (snd creds)
+		_ -> senderror "cannot send GETCREDS here"
+	handleRemoteRequest GETUUID = case externalUUID external of
+		Just u -> send $ VALUE $ fromUUID u
+		Nothing -> senderror "cannot send GETUUID here"
 	handleRemoteRequest GETGITDIR = 
 		send . VALUE . fromRawFilePath =<< fromRepo Git.localGitDir
-	handleRemoteRequest (SETWANTED expr) =
-		preferredContentSet (externalUUID external) expr
-	handleRemoteRequest GETWANTED = do
-		expr <- fromMaybe "" . M.lookup (externalUUID external)
-			<$> preferredContentMapRaw
-		send $ VALUE expr
+	handleRemoteRequest (SETWANTED expr) = case externalUUID external of
+		Just u -> preferredContentSet u expr
+		Nothing -> senderror "cannot send SETWANTED here"
+	handleRemoteRequest GETWANTED = case externalUUID external of
+		Just u -> do
+			expr <- fromMaybe "" . M.lookup u
+				<$> preferredContentMapRaw
+			send $ VALUE expr
+		Nothing -> senderror "cannot send GETWANTED here"
 	handleRemoteRequest (SETSTATE key state) =
 		case externalRemoteStateHandle external of
 			Just h -> setRemoteState h key state
@ -478,13 +482,13 @@ handleRequest' st external req mp responsehandler
 	send = sendMessage st external
 	senderror = sendMessage st external . ERROR 

-	credstorage setting = CredPairStorage
+	credstorage setting u = CredPairStorage
 		{ credPairFile = base
 		, credPairEnvironment = (base ++ "login", base ++ "password")
 		, credPairRemoteField = Accepted setting
 		}
 	  where
-		base = replace "/" "_" $ fromUUID (externalUUID external) ++ "-" ++ setting
+		base = replace "/" "_" $ fromUUID u ++ "-" ++ setting
 			
 	withurl mk uri = handleRemoteRequest $ mk $
 		setDownloader (show uri) OtherDownloader
@ -777,3 +781,48 @@ getInfoM external = (++)
 		INFOVALUE v -> Just $ return $
 			GetNextMessage $ collect ((f, v) : l)
 		_ -> Nothing
+
+{- All unknown configs are passed through in case the external program
+ - uses them. -}
+lenientRemoteConfigParser :: RemoteConfigParser
+lenientRemoteConfigParser = RemoteConfigParser
+	{ remoteConfigFieldParsers =
+		[ optionalStringParser externaltypeField
+		, trueFalseParser readonlyField False
+		]
+	, remoteConfigRestPassthrough = const True
+	}
+
+{- When the remote supports LISTCONFIGS, only accept the ones it listed.
+ - When it does not, accept all configs. -}
+strictRemoteConfigParser :: External -> Annex RemoteConfigParser
+strictRemoteConfigParser external = listConfigs external >>= \case
+	Nothing -> return lenientRemoteConfigParser
+	Just l -> do
+		let s = S.fromList (map fst l)
+		let listed f = S.member (fromProposedAccepted f) s
+		return $ lenientRemoteConfigParser
+			{ remoteConfigRestPassthrough = listed }
+
+listConfigs :: External -> Annex (Maybe [(Setting, Description)])
+listConfigs external = handleRequest external LISTCONFIGS Nothing (collect [])
+  where
+	collect l req = case req of
+		CONFIG s d -> Just $ return $
+			GetNextMessage $ collect ((s, d) : l)
+		CONFIGEND -> result (Just (reverse l))
+		UNSUPPORTED_REQUEST -> result Nothing
+		_ -> Nothing
+
+remoteConfigParser :: RemoteConfig -> Annex RemoteConfigParser
+remoteConfigParser c
+	-- No need to ask when there is no config to parse.
+	| M.null c = return lenientRemoteConfigParser
+	| otherwise = case parseRemoteConfig c lenientRemoteConfigParser of
+		Left _ -> return lenientRemoteConfigParser
+		Right pc -> case (getRemoteConfigValue externaltypeField pc, getRemoteConfigValue readonlyField pc) of
+			(Nothing, _) -> return lenientRemoteConfigParser
+			(_, Just True) -> return lenientRemoteConfigParser
+			(Just externaltype, _) -> do
+				external <- newExternal externaltype Nothing pc Nothing Nothing
+				strictRemoteConfigParser external
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@ -28,6 +28,7 @@ module Remote.External.Types (
 	AsyncMessage(..),
 	ErrorMsg,
 	Setting,
+	Description,
 	ProtocolVersion,
 	supportedProtocolVersions,
 ) where
@ -51,17 +52,17 @@ import Data.Char

 data External = External
 	{ externalType :: ExternalType
-	, externalUUID :: UUID
+	, externalUUID :: Maybe UUID
 	, externalState :: TVar [ExternalState]
 	-- ^ Contains states for external special remote processes
 	-- that are not currently in use.
 	, externalLastPid :: TVar PID
 	, externalDefaultConfig :: ParsedRemoteConfig
-	, externalGitConfig :: RemoteGitConfig
+	, externalGitConfig :: Maybe RemoteGitConfig
 	, externalRemoteStateHandle :: Maybe RemoteStateHandle
 	}

-newExternal :: ExternalType -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> Maybe RemoteStateHandle -> Annex External
+newExternal :: ExternalType -> Maybe UUID -> ParsedRemoteConfig -> Maybe RemoteGitConfig -> Maybe RemoteStateHandle -> Annex External
 newExternal externaltype u c gc rs = liftIO $ External
 	<$> pure externaltype
 	<*> pure u
@ -131,6 +132,7 @@ data Request
 	| CHECKPRESENT SafeKey
 	| REMOVE SafeKey
 	| WHEREIS SafeKey
+	| LISTCONFIGS
 	| GETINFO
 	| EXPORTSUPPORTED
 	| EXPORT ExportLocation
@ -147,6 +149,7 @@ needsPREPARE PREPARE = False
 needsPREPARE (EXTENSIONS _) = False
 needsPREPARE INITREMOTE = False
 needsPREPARE EXPORTSUPPORTED = False
+needsPREPARE LISTCONFIGS = False
 needsPREPARE _ = True

 instance Proto.Sendable Request where
@ -167,6 +170,7 @@ instance Proto.Sendable Request where
 		[ "CHECKPRESENT", Proto.serialize key ]
 	formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ]
 	formatMessage (WHEREIS key) = [ "WHEREIS", Proto.serialize key ]
+	formatMessage LISTCONFIGS = [ "LISTCONFIGS" ]
 	formatMessage GETINFO = [ "GETINFO" ]
 	formatMessage EXPORTSUPPORTED = ["EXPORTSUPPORTED"]
 	formatMessage (EXPORT loc) = [ "EXPORT", Proto.serialize loc ]
@ -211,6 +215,8 @@ data Response
 	| CHECKURL_FAILURE ErrorMsg
 	| WHEREIS_SUCCESS String
 	| WHEREIS_FAILURE
+	| CONFIG Setting Description
+	| CONFIGEND
 	| INFOFIELD String
 	| INFOVALUE String
 	| INFOEND
@ -245,6 +251,8 @@ instance Proto.Receivable Response where
 	parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE
 	parseCommand "WHEREIS-SUCCESS" = Just . WHEREIS_SUCCESS
 	parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE
+	parseCommand "CONFIG" = Proto.parse2 CONFIG
+	parseCommand "CONFIGEND" = Proto.parse0 CONFIGEND
 	parseCommand "INFOFIELD" = Proto.parse1 INFOFIELD
 	parseCommand "INFOVALUE" = Proto.parse1 INFOVALUE
 	parseCommand "INFOEND" = Proto.parse0 INFOEND
@ -332,6 +340,7 @@ instance Proto.Receivable AsyncMessage where
 -- All are serializable.
 type ErrorMsg = String
 type Setting = String
+type Description = String
 type ProtocolVersion = Int
 type Size = Maybe Integer

--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@ -107,7 +107,7 @@ gen baser u c gc rs = do
 			(Just remotename, Just c') -> do
 				pc <- either giveup return
 					. parseRemoteConfig c'
-					=<< configParser remote
+					=<< configParser remote c'
 				setGcryptEncryption pc remotename
 				storeUUIDIn (remoteConfig baser "uuid") u'
 				setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid
@ -217,7 +217,7 @@ gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c
 				| otherwise -> error "Another remote with the same name already exists."		

 		pc <- either giveup return . parseRemoteConfig c'
-			=<< configParser remote
+			=<< configParser remote c'
 		setGcryptEncryption pc remotename

 		{- Run a git fetch and a push to the git repo in order to get
--- a/Remote/GitLFS.hs
+++ b/Remote/GitLFS.hs
@ -134,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 c'
 	case (isEncrypted pc, Git.GCrypt.urlPrefix `isPrefixOf` url) of
 		(False, False) -> noop
 		(True, True) -> Remote.GCrypt.setGcryptEncryption pc remotename
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@ -116,7 +116,8 @@ glacierSetup' ss u mcreds c gc = do
 	(c', encsetup) <- encryptionSetup c gc
 	c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
 	let fullconfig = c'' `M.union` defaults
-	pc <- either giveup return . parseRemoteConfig fullconfig =<< configParser remote
+	pc <- either giveup return . parseRemoteConfig fullconfig
+		=<< configParser remote fullconfig
 	case ss of
 		Init -> genVault pc gc u
 		_ -> return ()
--- a/Remote/Helper/ExportImport.hs
+++ b/Remote/Helper/ExportImport.hs
@ -77,10 +77,10 @@ adjustExportImportRemoteType rt = rt
 	, configParser = configparser
 	}
  where
-	configparser = addRemoteConfigParser exportImportConfigParsers 
-		<$> configParser rt
+	configparser c = addRemoteConfigParser exportImportConfigParsers 
+		<$> configParser rt c
 	setup' st mu cp c gc = do
-		pc <- either giveup return . parseRemoteConfig c =<< configparser
+		pc <- either giveup return . parseRemoteConfig c =<< configparser c
 		let checkconfig supported configured configfield cont =
 			ifM (supported rt pc gc)
 				( case st of
@ -89,7 +89,7 @@ adjustExportImportRemoteType rt = rt
 							giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield
 						| otherwise -> cont
 					Enable oldc -> do
-						oldpc <- either mempty id . parseRemoteConfig oldc <$> configparser
+						oldpc <- either mempty id . parseRemoteConfig oldc <$> configparser oldc
 						if configured pc /= configured oldpc
 							then giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote"
 							else cont
--- a/Remote/Helper/Special.hs
+++ b/Remote/Helper/Special.hs
@ -30,6 +30,7 @@ module Remote.Helper.Special (
 	checkPresentDummy,
 	SpecialRemoteCfg(..),
 	specialRemoteCfg,
+	specialRemoteConfigParsers,
 	specialRemoteType,
 	specialRemote,
 	specialRemote',
@ -169,8 +170,8 @@ specialRemoteCfg c = SpecialRemoteCfg (getChunkConfig c) True
 -- Modifies a base RemoteType to support chunking and encryption configs.
 specialRemoteType :: RemoteType -> RemoteType
 specialRemoteType r = r 
-	{ configParser = addRemoteConfigParser specialRemoteConfigParsers
-		<$> configParser r
+	{ configParser = \c -> addRemoteConfigParser specialRemoteConfigParsers
+		<$> configParser r c
 	}

 specialRemoteConfigParsers :: [RemoteConfigFieldParser]
--- a/Remote/List.hs
+++ b/Remote/List.hs
@ -110,10 +110,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
-	pc <- if null c
-		then pure mempty
-		else either (const mempty) id . parseRemoteConfig c
-			<$> configParser t
+	pc <- either (const mempty) id . parseRemoteConfig c <$> configParser t c
 	generate t g u pc gc rs >>= \case
 		Nothing -> return Nothing
 		Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@ -73,7 +73,7 @@ remote = specialRemoteType $ RemoteType
 	{ typename = "S3"
 	, enumerate = const (findSpecialRemotes "s3")
 	, generate = gen
-	, configParser = pure $ RemoteConfigParser
+	, configParser = const $ pure $ RemoteConfigParser
 		{ remoteConfigFieldParsers = 
 			[ optionalStringParser bucketField
 			, optionalStringParser hostField
@ -230,7 +230,8 @@ s3Setup' ss u mcreds c gc
 		(c', encsetup) <- encryptionSetup c gc
 		c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
 		let fullconfig = c'' `M.union` defaults
-		pc <- either giveup return . parseRemoteConfig fullconfig =<< configParser remote
+		pc <- either giveup return . parseRemoteConfig fullconfig
+			=<< configParser remote fullconfig
 		info <- extractS3Info pc
 		checkexportimportsafe pc info
 		case ss of
@ -255,7 +256,8 @@ s3Setup' ss u mcreds c gc
 			M.union c' $
 			-- special constraints on key names
 			M.insert mungekeysField (Proposed "ia") defaults
-		pc <- either giveup return . parseRemoteConfig archiveconfig =<< configParser remote
+		pc <- either giveup return . parseRemoteConfig archiveconfig
+			=<< configParser remote archiveconfig
 		info <- extractS3Info pc
 		checkexportimportsafe pc info
 		hdl <- mkS3HandleVar pc gc u
@ -1234,7 +1236,7 @@ enableBucketVersioning ss info _ _ _ = do
 		Enable oldc -> do
 			oldpc <- either (const mempty) id
 				. parseRemoteConfig oldc 
-				<$> configParser remote
+				<$> configParser remote oldc
 			oldinfo <- extractS3Info oldpc
 			when (versioning info /= versioning oldinfo) $
 				giveup "Cannot change versioning= of existing S3 remote."
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@ -121,7 +121,7 @@ tahoeSetup _ mu _ c _ = do
 	scs <- liftIO $ tahoeConfigure configdir
 		(fromProposedAccepted furl)
 		(fromProposedAccepted <$> (M.lookup scsField c))
-	pc <- either giveup return . parseRemoteConfig c =<< configParser remote
+	pc <- either giveup return . parseRemoteConfig c =<< configParser remote c
 	let c' = if embedCreds pc
 		then flip M.union c $ M.fromList
 			[ (furlField, furl)
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@ -123,7 +123,7 @@ webdavSetup _ mu mcreds c gc = do
 		(return . fromProposedAccepted)
 		(M.lookup urlField c)
 	(c', encsetup) <- encryptionSetup c gc
-	pc <- either giveup return . parseRemoteConfig c' =<< configParser remote
+	pc <- either giveup return . parseRemoteConfig c' =<< configParser remote c'
 	creds <- maybe (getCreds pc gc u) (return . Just) mcreds
 	testDav url creds
 	gitConfigSpecialRemote u c' [("webdav", "true")]