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.
This commit is contained in:
Joey Hess
parent
6a982e38eb
commit
465ec9dcd7
4 changed files with 72 additions and 31 deletions
23
Creds.hs
23
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
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
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
|
||||
|
|
|
|||
12
Remote/External/Types.hs
vendored
12
Remote/External/Types.hs
vendored
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue