From 465ec9dcd72c9bf13f272b70958155820c5d0269 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 15 Jan 2020 13:01:22 -0400 Subject: [PATCH] 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 | 23 +++++++++++---- Remote/External.hs | 64 +++++++++++++++++++++++++++++----------- Remote/External/Types.hs | 12 ++++---- Remote/List.hs | 4 --- 4 files changed, 72 insertions(+), 31 deletions(-) diff --git a/Creds.hs b/Creds.hs index 52db539843..ef05982ca6 100644 --- a/Creds.hs +++ b/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 - Nothing -> maybe (return c) (setRemoteCredPair encsetup c gc storage . Just) +setRemoteCredPair = setRemoteCredPair' id + (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 diff --git a/Remote/External.hs b/Remote/External.hs index 501feb8e3a..16edec7f8d 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -1,6 +1,6 @@ {- External special remote interface. - - - Copyright 2013-2018 Joey Hess + - Copyright 2013-2020 Joey Hess - - 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 $ - M.lookup (Accepted "externaltype") c + pc <- either giveup return $ parseRemoteConfig c remoteConfigParser + 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 - Left err -> giveup err - Right (Just True) -> do + c'' <- case getRemoteConfigValue readonlyField pc of + 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 $ - liftIO . atomically . readTVar . externalConfig + -- Any config changes the external made before + -- 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) $ - M.insert (Accepted setting) (Accepted value) + liftIO $ atomically $ do + 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 diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs index b9785cb140..0e2f62f219 100644 --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -1,6 +1,6 @@ {- External special remote data types. - - - Copyright 2013-2018 Joey Hess + - Copyright 2013-2020 Joey Hess - - 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 diff --git a/Remote/List.hs b/Remote/List.hs index 921431b201..de30320554 100644 --- a/Remote/List.hs +++ b/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.