From 99cb3e75f1f03eaab44173eafa4eeeb2b8f79120 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 17 Jan 2020 15:30:14 -0400 Subject: [PATCH] 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. --- Assistant/DaemonStatus.hs | 1 - Assistant/WebApp/Configurators/AWS.hs | 2 +- Assistant/WebApp/Configurators/Edit.hs | 2 +- Assistant/WebApp/Configurators/WebDAV.hs | 2 +- CHANGELOG | 2 + Remote/External.hs | 129 ++++++++++++------ Remote/External/Types.hs | 15 +- Remote/GCrypt.hs | 4 +- Remote/GitLFS.hs | 2 +- Remote/Glacier.hs | 3 +- Remote/Helper/ExportImport.hs | 8 +- Remote/Helper/Special.hs | 5 +- Remote/List.hs | 5 +- Remote/S3.hs | 10 +- Remote/Tahoe.hs | 2 +- Remote/WebDAV.hs | 2 +- Types/Remote.hs | 2 +- Types/RemoteConfig.hs | 4 +- .../external_special_remote_protocol.mdwn | 26 +++- doc/special_remotes/external/example.sh | 8 +- 20 files changed, 158 insertions(+), 76 deletions(-) diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index cbf3231965..4f3c2effb0 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -19,7 +19,6 @@ import Logs.Trust import Utility.TimeStamp import qualified Remote import qualified Types.Remote as Remote -import Config import Config.DynamicConfig import Annex.SpecialRemote.Config diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index fd0a4b6de0..92717bfe64 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -171,7 +171,7 @@ getEnableS3R uuid = do isia <- case M.lookup uuid m of Just c -> liftAnnex $ do pc <- either mempty id . parseRemoteConfig c - <$> Remote.configParser S3.remote + <$> Remote.configParser S3.remote c return $ S3.configIA pc Nothing -> return False if isia diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index cbb9ccb966..93a45ef7a9 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -257,7 +257,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 + <$> Remote.configParser S3.remote c if S3.configIA pc then IA.getRepoInfo c else AWS.getRepoInfo c diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index 2cdcdc0f2c..37ff804557 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -63,7 +63,7 @@ postEnableWebDAVR uuid = do mcreds <- liftAnnex $ do dummycfg <- liftIO dummyRemoteGitConfig pc <- either mempty id . parseRemoteConfig c - <$> configParser WebDAV.remote + <$> configParser WebDAV.remote c getRemoteCredPairFor "webdav" pc dummycfg (WebDAV.davCreds uuid) case mcreds of Just creds -> webDAVConfigurator $ liftH $ diff --git a/CHANGELOG b/CHANGELOG index 04d41e91f3..84689b4e74 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -10,6 +10,8 @@ git-annex (7.20191231) UNRELEASED; urgency=medium foo=yes is expected * initremote, enableremote: Reject unknown parameters provided to these commands. + * Added LISTCONFIGS to external special remote protocol. Special remote + programs that use GETCONFIG/SETCONFIG are recommended to implement it. -- Joey Hess Wed, 01 Jan 2020 12:51:40 -0400 diff --git a/Remote/External.hs b/Remote/External.hs index 16edec7f8d..e63d78d1b9 100644 --- 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 diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs index 0e2f62f219..461a4b5258 100644 --- 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 diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 497c967e0a..2a3f251c72 100644 --- 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 diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index 0f99ddb507..ab69cb6a5c 100644 --- 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 diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 6fc1e6aa4c..359fa21612 100644 --- 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 () diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs index 2db7deb14f..da58d58de1 100644 --- 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 diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index f4e53a1fd8..7c788875a4 100644 --- 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] diff --git a/Remote/List.hs b/Remote/List.hs index 19123cf5fb..4619df6345 100644 --- 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 diff --git a/Remote/S3.hs b/Remote/S3.hs index 2c3369f03c..166f8daf5e 100644 --- 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." diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index b5ebd5ec55..f755282228 100644 --- 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) diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 583a0017be..4978754c41 100644 --- 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")] diff --git a/Types/Remote.hs b/Types/Remote.hs index d56fa6fd25..12a37a618c 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 :: a RemoteConfigParser + , configParser :: RemoteConfig -> 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 7b0b51ee5b..daf7f31902 100644 --- a/Types/RemoteConfig.hs +++ b/Types/RemoteConfig.hs @@ -44,8 +44,8 @@ data RemoteConfigParser = RemoteConfigParser , remoteConfigRestPassthrough :: RemoteConfigField -> Bool } -mkRemoteConfigParser :: Monad m => [RemoteConfigFieldParser] -> m RemoteConfigParser -mkRemoteConfigParser l = pure (RemoteConfigParser l (const False)) +mkRemoteConfigParser :: Monad m => [RemoteConfigFieldParser] -> RemoteConfig -> m RemoteConfigParser +mkRemoteConfigParser l _ = pure (RemoteConfigParser l (const False)) addRemoteConfigParser :: [RemoteConfigFieldParser] -> RemoteConfigParser -> RemoteConfigParser addRemoteConfigParser l rpc = rpc { remoteConfigFieldParsers = remoteConfigFieldParsers rpc ++ l } diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn index ddaad9ae63..9b69300d8f 100644 --- a/doc/design/external_special_remote_protocol.mdwn +++ b/doc/design/external_special_remote_protocol.mdwn @@ -54,8 +54,9 @@ could have its own protocol extension details, but none are currently used. EXTENSIONS Next, git-annex will generally send a message telling the special -remote to start up. (Or it might send an INITREMOTE or EXPORTSUPPORTED, -or perhaps other things in the future, so don't hardcode this order.) +remote to start up. (Or it might send an INITREMOTE or EXPORTSUPPORTED or +LISTCONFIGS, or perhaps other things in the future, so don't hardcode this +order.) PREPARE @@ -116,9 +117,9 @@ The following requests *must* all be supported by the special remote. Indicates that INITREMOTE failed. * `PREPARE` Tells the remote that it's time to prepare itself to be used. - Only a few requests for details about the remote can come before this. - Those include EXTENSIONS, INITREMOTE, and EXPORTSUPPORTED, but others - may be added later. + Only a few requests for details about the remote can come before this + (EXTENSIONS, INITREMOTE, EXPORTSUPPORTED, and LISTCONFIGS, + but others may be added later). * `PREPARE-SUCCESS` Sent as a response to PREPARE once the special remote is ready for use. * `PREPARE-FAILURE ErrorMsg` @@ -173,6 +174,19 @@ the special remote can reply with `UNSUPPORTED-REQUEST`. Sent in response to a EXTENSIONS request, the List could be used to indicate protocol extensions that the special remote uses, but there are currently no such extensions. +* `LISTCONFIGS` + Requests the remote to return a list of settings it uses (with + `GETCONFIG` and `SETCONFIG`). Providing a list makes `git annex initremote` + work better, because it can check the user's input, and can also display + a list of settings with descriptions. Note that the user is not required + to provided all the settings listed here. A block of responses + can be made to this, which must always end with `CONFIGSEND`. + * `CONFIG Name Description` + Indicates the name and description of a config setting. The description + should be reasonably short. Example: + "CONFIG directory store data here" + * `CONFIGEND` + Indicates the end of the response block. * `GETCOST` Requests the remote to return a use cost. Higher costs are more expensive. (See Config/Cost.hs for some standard costs.) @@ -283,6 +297,8 @@ handling a request. Gets one of the special remote's configuration settings, which can have been passed by the user when running `git annex initremote`, or can have been set by a previous SETCONFIG. Can be run at any time. + It's recommended that special remotes that use this implement + LISTCONFIGS. (git-annex replies with VALUE followed by the value. If the setting is not set, the value will be empty.) * `SETCREDS Setting User Password` diff --git a/doc/special_remotes/external/example.sh b/doc/special_remotes/external/example.sh index fe1d9380ec..cfae74ae25 100755 --- a/doc/special_remotes/external/example.sh +++ b/doc/special_remotes/external/example.sh @@ -137,7 +137,7 @@ doremove () { local loc="$2" # Note that it's not a failure to remove a - # fike that is not present. + # file that is not present. if [ -e "$loc" ]; then if runcmd rm -f "$loc"; then echo REMOVE-SUCCESS "$key" @@ -155,6 +155,12 @@ echo VERSION 1 while read line; do set -- $line case "$1" in + LISTCONFIGS) + # One CONFIG line for each setting that we GETCONFIG + # later. + echo CONFIG directory store data here + echo CONFIGEND + ;; INITREMOTE) # Do anything necessary to create resources # used by the remote. Try to be idempotent.