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.
This commit is contained in:
parent
1ce722d86f
commit
99cb3e75f1
20 changed files with 158 additions and 76 deletions
|
@ -19,7 +19,6 @@ import Logs.Trust
|
||||||
import Utility.TimeStamp
|
import Utility.TimeStamp
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import qualified Types.Remote as Remote
|
import qualified Types.Remote as Remote
|
||||||
import Config
|
|
||||||
import Config.DynamicConfig
|
import Config.DynamicConfig
|
||||||
import Annex.SpecialRemote.Config
|
import Annex.SpecialRemote.Config
|
||||||
|
|
||||||
|
|
|
@ -171,7 +171,7 @@ getEnableS3R uuid = do
|
||||||
isia <- case M.lookup uuid m of
|
isia <- case M.lookup uuid m of
|
||||||
Just c -> liftAnnex $ do
|
Just c -> liftAnnex $ do
|
||||||
pc <- either mempty id . parseRemoteConfig c
|
pc <- either mempty id . parseRemoteConfig c
|
||||||
<$> Remote.configParser S3.remote
|
<$> Remote.configParser S3.remote c
|
||||||
return $ S3.configIA pc
|
return $ S3.configIA pc
|
||||||
Nothing -> return False
|
Nothing -> return False
|
||||||
if isia
|
if isia
|
||||||
|
|
|
@ -257,7 +257,7 @@ getRepoInfo (Just r) c = case fromProposedAccepted <$> M.lookup typeField c of
|
||||||
Just "S3" -> do
|
Just "S3" -> do
|
||||||
#ifdef WITH_S3
|
#ifdef WITH_S3
|
||||||
pc <- liftAnnex $ either mempty id . parseRemoteConfig c
|
pc <- liftAnnex $ either mempty id . parseRemoteConfig c
|
||||||
<$> Remote.configParser S3.remote
|
<$> Remote.configParser S3.remote c
|
||||||
if S3.configIA pc
|
if S3.configIA pc
|
||||||
then IA.getRepoInfo c
|
then IA.getRepoInfo c
|
||||||
else AWS.getRepoInfo c
|
else AWS.getRepoInfo c
|
||||||
|
|
|
@ -63,7 +63,7 @@ postEnableWebDAVR uuid = do
|
||||||
mcreds <- liftAnnex $ do
|
mcreds <- liftAnnex $ do
|
||||||
dummycfg <- liftIO dummyRemoteGitConfig
|
dummycfg <- liftIO dummyRemoteGitConfig
|
||||||
pc <- either mempty id . parseRemoteConfig c
|
pc <- either mempty id . parseRemoteConfig c
|
||||||
<$> configParser WebDAV.remote
|
<$> configParser WebDAV.remote c
|
||||||
getRemoteCredPairFor "webdav" pc dummycfg (WebDAV.davCreds uuid)
|
getRemoteCredPairFor "webdav" pc dummycfg (WebDAV.davCreds uuid)
|
||||||
case mcreds of
|
case mcreds of
|
||||||
Just creds -> webDAVConfigurator $ liftH $
|
Just creds -> webDAVConfigurator $ liftH $
|
||||||
|
|
|
@ -10,6 +10,8 @@ git-annex (7.20191231) UNRELEASED; urgency=medium
|
||||||
foo=yes is expected
|
foo=yes is expected
|
||||||
* initremote, enableremote: Reject unknown parameters provided to these
|
* initremote, enableremote: Reject unknown parameters provided to these
|
||||||
commands.
|
commands.
|
||||||
|
* Added LISTCONFIGS to external special remote protocol. Special remote
|
||||||
|
programs that use GETCONFIG/SETCONFIG are recommended to implement it.
|
||||||
|
|
||||||
-- Joey Hess <id@joeyh.name> Wed, 01 Jan 2020 12:51:40 -0400
|
-- Joey Hess <id@joeyh.name> Wed, 01 Jan 2020 12:51:40 -0400
|
||||||
|
|
||||||
|
|
|
@ -43,27 +43,19 @@ import Control.Concurrent.STM
|
||||||
import Control.Concurrent.Async
|
import Control.Concurrent.Async
|
||||||
import System.Log.Logger (debugM)
|
import System.Log.Logger (debugM)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.Set as S
|
||||||
|
|
||||||
remote :: RemoteType
|
remote :: RemoteType
|
||||||
remote = RemoteType
|
remote = specialRemoteType $ RemoteType
|
||||||
{ typename = "external"
|
{ typename = "external"
|
||||||
, enumerate = const (findSpecialRemotes "externaltype")
|
, enumerate = const (findSpecialRemotes "externaltype")
|
||||||
, generate = gen
|
, generate = gen
|
||||||
, configParser = pure remoteConfigParser
|
, configParser = remoteConfigParser
|
||||||
, setup = externalSetup
|
, setup = externalSetup
|
||||||
, exportSupported = checkExportSupported
|
, exportSupported = checkExportSupported
|
||||||
, importSupported = importUnsupported
|
, importSupported = importUnsupported
|
||||||
}
|
}
|
||||||
|
|
||||||
remoteConfigParser :: RemoteConfigParser
|
|
||||||
remoteConfigParser = RemoteConfigParser
|
|
||||||
{ remoteConfigFieldParsers =
|
|
||||||
[ optionalStringParser externaltypeField
|
|
||||||
, trueFalseParser readonlyField False
|
|
||||||
]
|
|
||||||
, remoteConfigRestPassthrough = const True
|
|
||||||
}
|
|
||||||
|
|
||||||
externaltypeField :: RemoteConfigField
|
externaltypeField :: RemoteConfigField
|
||||||
externaltypeField = Accepted "externaltype"
|
externaltypeField = Accepted "externaltype"
|
||||||
|
|
||||||
|
@ -87,7 +79,7 @@ gen r u c gc rs
|
||||||
exportUnsupported
|
exportUnsupported
|
||||||
exportUnsupported
|
exportUnsupported
|
||||||
| otherwise = do
|
| 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
|
Annex.addCleanup (RemoteCleanup u) $ stopExternal external
|
||||||
cst <- getCost external r gc
|
cst <- getCost external r gc
|
||||||
avail <- getAvailability 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 :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||||
externalSetup _ mu _ c gc = do
|
externalSetup _ mu _ c gc = do
|
||||||
u <- maybe (liftIO genUUID) return mu
|
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=") $
|
let externaltype = fromMaybe (giveup "Specify externaltype=") $
|
||||||
getRemoteConfigValue externaltypeField pc
|
getRemoteConfigValue externaltypeField pc
|
||||||
(c', _encsetup) <- encryptionSetup c gc
|
(c', _encsetup) <- encryptionSetup c gc
|
||||||
|
@ -180,8 +172,14 @@ externalSetup _ mu _ c gc = do
|
||||||
setConfig (remoteConfig (fromJust (lookupName c)) "readonly") (boolConfig True)
|
setConfig (remoteConfig (fromJust (lookupName c)) "readonly") (boolConfig True)
|
||||||
return c'
|
return c'
|
||||||
_ -> do
|
_ -> do
|
||||||
pc' <- either giveup return $ parseRemoteConfig c' remoteConfigParser
|
pc' <- either giveup return $ parseRemoteConfig c' lenientRemoteConfigParser
|
||||||
external <- newExternal externaltype u pc' gc Nothing
|
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
|
handleRequest external INITREMOTE Nothing $ \resp -> case resp of
|
||||||
INITREMOTE_SUCCESS -> result ()
|
INITREMOTE_SUCCESS -> result ()
|
||||||
INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg
|
INITREMOTE_FAILURE errmsg -> Just $ giveup errmsg
|
||||||
|
@ -201,7 +199,7 @@ checkExportSupported c gc = do
|
||||||
let externaltype = fromMaybe (giveup "Specify externaltype=") $
|
let externaltype = fromMaybe (giveup "Specify externaltype=") $
|
||||||
remoteAnnexExternalType gc <|> getRemoteConfigValue externaltypeField c
|
remoteAnnexExternalType gc <|> getRemoteConfigValue externaltypeField c
|
||||||
checkExportSupported'
|
checkExportSupported'
|
||||||
=<< newExternal externaltype NoUUID c gc Nothing
|
=<< newExternal externaltype Nothing c (Just gc) Nothing
|
||||||
|
|
||||||
checkExportSupported' :: External -> Annex Bool
|
checkExportSupported' :: External -> Annex Bool
|
||||||
checkExportSupported' external = go `catchNonAsync` (const (return False))
|
checkExportSupported' external = go `catchNonAsync` (const (return False))
|
||||||
|
@ -423,30 +421,36 @@ handleRequest' st external req mp responsehandler
|
||||||
. getRemoteConfigPassedThrough
|
. getRemoteConfigPassedThrough
|
||||||
<$> liftIO (atomically $ readTVar $ externalConfig st)
|
<$> liftIO (atomically $ readTVar $ externalConfig st)
|
||||||
send $ VALUE value
|
send $ VALUE value
|
||||||
handleRemoteRequest (SETCREDS setting login password) = do
|
handleRemoteRequest (SETCREDS setting login password) = case (externalUUID external, externalGitConfig external) of
|
||||||
let v = externalConfig st
|
(Just u, Just gc) -> do
|
||||||
c <- liftIO $ atomically $ readTVar v
|
let v = externalConfig st
|
||||||
let gc = externalGitConfig external
|
c <- liftIO $ atomically $ readTVar v
|
||||||
c' <- setRemoteCredPair' RemoteConfigValue id encryptionAlreadySetup c gc
|
c' <- setRemoteCredPair' RemoteConfigValue id encryptionAlreadySetup c gc
|
||||||
(credstorage setting)
|
(credstorage setting u)
|
||||||
(Just (login, password))
|
(Just (login, password))
|
||||||
void $ liftIO $ atomically $ swapTVar v c'
|
void $ liftIO $ atomically $ swapTVar v c'
|
||||||
handleRemoteRequest (GETCREDS setting) = do
|
_ -> senderror "cannot send SETCREDS here"
|
||||||
c <- liftIO $ atomically $ readTVar $ externalConfig st
|
handleRemoteRequest (GETCREDS setting) = case (externalUUID external, externalGitConfig external) of
|
||||||
let gc = externalGitConfig external
|
(Just u, Just gc) -> do
|
||||||
creds <- fromMaybe ("", "") <$>
|
c <- liftIO $ atomically $ readTVar $ externalConfig st
|
||||||
getRemoteCredPair c gc (credstorage setting)
|
creds <- fromMaybe ("", "") <$>
|
||||||
send $ CREDS (fst creds) (snd creds)
|
getRemoteCredPair c gc (credstorage setting u)
|
||||||
handleRemoteRequest GETUUID = send $
|
send $ CREDS (fst creds) (snd creds)
|
||||||
VALUE $ fromUUID $ externalUUID external
|
_ -> 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 =
|
handleRemoteRequest GETGITDIR =
|
||||||
send . VALUE . fromRawFilePath =<< fromRepo Git.localGitDir
|
send . VALUE . fromRawFilePath =<< fromRepo Git.localGitDir
|
||||||
handleRemoteRequest (SETWANTED expr) =
|
handleRemoteRequest (SETWANTED expr) = case externalUUID external of
|
||||||
preferredContentSet (externalUUID external) expr
|
Just u -> preferredContentSet u expr
|
||||||
handleRemoteRequest GETWANTED = do
|
Nothing -> senderror "cannot send SETWANTED here"
|
||||||
expr <- fromMaybe "" . M.lookup (externalUUID external)
|
handleRemoteRequest GETWANTED = case externalUUID external of
|
||||||
<$> preferredContentMapRaw
|
Just u -> do
|
||||||
send $ VALUE expr
|
expr <- fromMaybe "" . M.lookup u
|
||||||
|
<$> preferredContentMapRaw
|
||||||
|
send $ VALUE expr
|
||||||
|
Nothing -> senderror "cannot send GETWANTED here"
|
||||||
handleRemoteRequest (SETSTATE key state) =
|
handleRemoteRequest (SETSTATE key state) =
|
||||||
case externalRemoteStateHandle external of
|
case externalRemoteStateHandle external of
|
||||||
Just h -> setRemoteState h key state
|
Just h -> setRemoteState h key state
|
||||||
|
@ -478,13 +482,13 @@ handleRequest' st external req mp responsehandler
|
||||||
send = sendMessage st external
|
send = sendMessage st external
|
||||||
senderror = sendMessage st external . ERROR
|
senderror = sendMessage st external . ERROR
|
||||||
|
|
||||||
credstorage setting = CredPairStorage
|
credstorage setting u = CredPairStorage
|
||||||
{ credPairFile = base
|
{ credPairFile = base
|
||||||
, credPairEnvironment = (base ++ "login", base ++ "password")
|
, credPairEnvironment = (base ++ "login", base ++ "password")
|
||||||
, credPairRemoteField = Accepted setting
|
, credPairRemoteField = Accepted setting
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
base = replace "/" "_" $ fromUUID (externalUUID external) ++ "-" ++ setting
|
base = replace "/" "_" $ fromUUID u ++ "-" ++ setting
|
||||||
|
|
||||||
withurl mk uri = handleRemoteRequest $ mk $
|
withurl mk uri = handleRemoteRequest $ mk $
|
||||||
setDownloader (show uri) OtherDownloader
|
setDownloader (show uri) OtherDownloader
|
||||||
|
@ -777,3 +781,48 @@ getInfoM external = (++)
|
||||||
INFOVALUE v -> Just $ return $
|
INFOVALUE v -> Just $ return $
|
||||||
GetNextMessage $ collect ((f, v) : l)
|
GetNextMessage $ collect ((f, v) : l)
|
||||||
_ -> Nothing
|
_ -> 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
|
||||||
|
|
15
Remote/External/Types.hs
vendored
15
Remote/External/Types.hs
vendored
|
@ -28,6 +28,7 @@ module Remote.External.Types (
|
||||||
AsyncMessage(..),
|
AsyncMessage(..),
|
||||||
ErrorMsg,
|
ErrorMsg,
|
||||||
Setting,
|
Setting,
|
||||||
|
Description,
|
||||||
ProtocolVersion,
|
ProtocolVersion,
|
||||||
supportedProtocolVersions,
|
supportedProtocolVersions,
|
||||||
) where
|
) where
|
||||||
|
@ -51,17 +52,17 @@ import Data.Char
|
||||||
|
|
||||||
data External = External
|
data External = External
|
||||||
{ externalType :: ExternalType
|
{ externalType :: ExternalType
|
||||||
, externalUUID :: UUID
|
, externalUUID :: Maybe UUID
|
||||||
, externalState :: TVar [ExternalState]
|
, externalState :: TVar [ExternalState]
|
||||||
-- ^ Contains states for external special remote processes
|
-- ^ Contains states for external special remote processes
|
||||||
-- that are not currently in use.
|
-- that are not currently in use.
|
||||||
, externalLastPid :: TVar PID
|
, externalLastPid :: TVar PID
|
||||||
, externalDefaultConfig :: ParsedRemoteConfig
|
, externalDefaultConfig :: ParsedRemoteConfig
|
||||||
, externalGitConfig :: RemoteGitConfig
|
, externalGitConfig :: Maybe RemoteGitConfig
|
||||||
, externalRemoteStateHandle :: Maybe RemoteStateHandle
|
, 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
|
newExternal externaltype u c gc rs = liftIO $ External
|
||||||
<$> pure externaltype
|
<$> pure externaltype
|
||||||
<*> pure u
|
<*> pure u
|
||||||
|
@ -131,6 +132,7 @@ data Request
|
||||||
| CHECKPRESENT SafeKey
|
| CHECKPRESENT SafeKey
|
||||||
| REMOVE SafeKey
|
| REMOVE SafeKey
|
||||||
| WHEREIS SafeKey
|
| WHEREIS SafeKey
|
||||||
|
| LISTCONFIGS
|
||||||
| GETINFO
|
| GETINFO
|
||||||
| EXPORTSUPPORTED
|
| EXPORTSUPPORTED
|
||||||
| EXPORT ExportLocation
|
| EXPORT ExportLocation
|
||||||
|
@ -147,6 +149,7 @@ needsPREPARE PREPARE = False
|
||||||
needsPREPARE (EXTENSIONS _) = False
|
needsPREPARE (EXTENSIONS _) = False
|
||||||
needsPREPARE INITREMOTE = False
|
needsPREPARE INITREMOTE = False
|
||||||
needsPREPARE EXPORTSUPPORTED = False
|
needsPREPARE EXPORTSUPPORTED = False
|
||||||
|
needsPREPARE LISTCONFIGS = False
|
||||||
needsPREPARE _ = True
|
needsPREPARE _ = True
|
||||||
|
|
||||||
instance Proto.Sendable Request where
|
instance Proto.Sendable Request where
|
||||||
|
@ -167,6 +170,7 @@ instance Proto.Sendable Request where
|
||||||
[ "CHECKPRESENT", Proto.serialize key ]
|
[ "CHECKPRESENT", Proto.serialize key ]
|
||||||
formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ]
|
formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ]
|
||||||
formatMessage (WHEREIS key) = [ "WHEREIS", Proto.serialize key ]
|
formatMessage (WHEREIS key) = [ "WHEREIS", Proto.serialize key ]
|
||||||
|
formatMessage LISTCONFIGS = [ "LISTCONFIGS" ]
|
||||||
formatMessage GETINFO = [ "GETINFO" ]
|
formatMessage GETINFO = [ "GETINFO" ]
|
||||||
formatMessage EXPORTSUPPORTED = ["EXPORTSUPPORTED"]
|
formatMessage EXPORTSUPPORTED = ["EXPORTSUPPORTED"]
|
||||||
formatMessage (EXPORT loc) = [ "EXPORT", Proto.serialize loc ]
|
formatMessage (EXPORT loc) = [ "EXPORT", Proto.serialize loc ]
|
||||||
|
@ -211,6 +215,8 @@ data Response
|
||||||
| CHECKURL_FAILURE ErrorMsg
|
| CHECKURL_FAILURE ErrorMsg
|
||||||
| WHEREIS_SUCCESS String
|
| WHEREIS_SUCCESS String
|
||||||
| WHEREIS_FAILURE
|
| WHEREIS_FAILURE
|
||||||
|
| CONFIG Setting Description
|
||||||
|
| CONFIGEND
|
||||||
| INFOFIELD String
|
| INFOFIELD String
|
||||||
| INFOVALUE String
|
| INFOVALUE String
|
||||||
| INFOEND
|
| INFOEND
|
||||||
|
@ -245,6 +251,8 @@ instance Proto.Receivable Response where
|
||||||
parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE
|
parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE
|
||||||
parseCommand "WHEREIS-SUCCESS" = Just . WHEREIS_SUCCESS
|
parseCommand "WHEREIS-SUCCESS" = Just . WHEREIS_SUCCESS
|
||||||
parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE
|
parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE
|
||||||
|
parseCommand "CONFIG" = Proto.parse2 CONFIG
|
||||||
|
parseCommand "CONFIGEND" = Proto.parse0 CONFIGEND
|
||||||
parseCommand "INFOFIELD" = Proto.parse1 INFOFIELD
|
parseCommand "INFOFIELD" = Proto.parse1 INFOFIELD
|
||||||
parseCommand "INFOVALUE" = Proto.parse1 INFOVALUE
|
parseCommand "INFOVALUE" = Proto.parse1 INFOVALUE
|
||||||
parseCommand "INFOEND" = Proto.parse0 INFOEND
|
parseCommand "INFOEND" = Proto.parse0 INFOEND
|
||||||
|
@ -332,6 +340,7 @@ instance Proto.Receivable AsyncMessage where
|
||||||
-- All are serializable.
|
-- All are serializable.
|
||||||
type ErrorMsg = String
|
type ErrorMsg = String
|
||||||
type Setting = String
|
type Setting = String
|
||||||
|
type Description = String
|
||||||
type ProtocolVersion = Int
|
type ProtocolVersion = Int
|
||||||
type Size = Maybe Integer
|
type Size = Maybe Integer
|
||||||
|
|
||||||
|
|
|
@ -107,7 +107,7 @@ gen baser u c gc rs = do
|
||||||
(Just remotename, Just c') -> do
|
(Just remotename, Just c') -> do
|
||||||
pc <- either giveup return
|
pc <- either giveup return
|
||||||
. parseRemoteConfig c'
|
. parseRemoteConfig c'
|
||||||
=<< configParser remote
|
=<< configParser remote c'
|
||||||
setGcryptEncryption pc remotename
|
setGcryptEncryption pc remotename
|
||||||
storeUUIDIn (remoteConfig baser "uuid") u'
|
storeUUIDIn (remoteConfig baser "uuid") u'
|
||||||
setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid
|
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."
|
| otherwise -> error "Another remote with the same name already exists."
|
||||||
|
|
||||||
pc <- either giveup return . parseRemoteConfig c'
|
pc <- either giveup return . parseRemoteConfig c'
|
||||||
=<< configParser remote
|
=<< configParser remote c'
|
||||||
setGcryptEncryption pc remotename
|
setGcryptEncryption pc remotename
|
||||||
|
|
||||||
{- Run a git fetch and a push to the git repo in order to get
|
{- Run a git fetch and a push to the git repo in order to get
|
||||||
|
|
|
@ -134,7 +134,7 @@ mySetup _ mu _ c gc = do
|
||||||
u <- maybe (liftIO genUUID) return mu
|
u <- maybe (liftIO genUUID) return mu
|
||||||
|
|
||||||
(c', _encsetup) <- encryptionSetup c gc
|
(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
|
case (isEncrypted pc, Git.GCrypt.urlPrefix `isPrefixOf` url) of
|
||||||
(False, False) -> noop
|
(False, False) -> noop
|
||||||
(True, True) -> Remote.GCrypt.setGcryptEncryption pc remotename
|
(True, True) -> Remote.GCrypt.setGcryptEncryption pc remotename
|
||||||
|
|
|
@ -116,7 +116,8 @@ glacierSetup' ss u mcreds c gc = do
|
||||||
(c', encsetup) <- encryptionSetup c gc
|
(c', encsetup) <- encryptionSetup c gc
|
||||||
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
|
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
|
||||||
let fullconfig = c'' `M.union` defaults
|
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
|
case ss of
|
||||||
Init -> genVault pc gc u
|
Init -> genVault pc gc u
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
|
|
@ -77,10 +77,10 @@ adjustExportImportRemoteType rt = rt
|
||||||
, configParser = configparser
|
, configParser = configparser
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
configparser = addRemoteConfigParser exportImportConfigParsers
|
configparser c = addRemoteConfigParser exportImportConfigParsers
|
||||||
<$> configParser rt
|
<$> configParser rt c
|
||||||
setup' st mu cp c gc = do
|
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 =
|
let checkconfig supported configured configfield cont =
|
||||||
ifM (supported rt pc gc)
|
ifM (supported rt pc gc)
|
||||||
( case st of
|
( case st of
|
||||||
|
@ -89,7 +89,7 @@ adjustExportImportRemoteType rt = rt
|
||||||
giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield
|
giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield
|
||||||
| otherwise -> cont
|
| otherwise -> cont
|
||||||
Enable oldc -> do
|
Enable oldc -> do
|
||||||
oldpc <- either mempty id . parseRemoteConfig oldc <$> configparser
|
oldpc <- either mempty id . parseRemoteConfig oldc <$> configparser oldc
|
||||||
if configured pc /= configured oldpc
|
if configured pc /= configured oldpc
|
||||||
then giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote"
|
then giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote"
|
||||||
else cont
|
else cont
|
||||||
|
|
|
@ -30,6 +30,7 @@ module Remote.Helper.Special (
|
||||||
checkPresentDummy,
|
checkPresentDummy,
|
||||||
SpecialRemoteCfg(..),
|
SpecialRemoteCfg(..),
|
||||||
specialRemoteCfg,
|
specialRemoteCfg,
|
||||||
|
specialRemoteConfigParsers,
|
||||||
specialRemoteType,
|
specialRemoteType,
|
||||||
specialRemote,
|
specialRemote,
|
||||||
specialRemote',
|
specialRemote',
|
||||||
|
@ -169,8 +170,8 @@ specialRemoteCfg c = SpecialRemoteCfg (getChunkConfig c) True
|
||||||
-- Modifies a base RemoteType to support chunking and encryption configs.
|
-- Modifies a base RemoteType to support chunking and encryption configs.
|
||||||
specialRemoteType :: RemoteType -> RemoteType
|
specialRemoteType :: RemoteType -> RemoteType
|
||||||
specialRemoteType r = r
|
specialRemoteType r = r
|
||||||
{ configParser = addRemoteConfigParser specialRemoteConfigParsers
|
{ configParser = \c -> addRemoteConfigParser specialRemoteConfigParsers
|
||||||
<$> configParser r
|
<$> configParser r c
|
||||||
}
|
}
|
||||||
|
|
||||||
specialRemoteConfigParsers :: [RemoteConfigFieldParser]
|
specialRemoteConfigParsers :: [RemoteConfigFieldParser]
|
||||||
|
|
|
@ -110,10 +110,7 @@ remoteGen m t g = do
|
||||||
let cu = fromMaybe u $ remoteAnnexConfigUUID gc
|
let cu = fromMaybe u $ remoteAnnexConfigUUID gc
|
||||||
let rs = RemoteStateHandle cu
|
let rs = RemoteStateHandle cu
|
||||||
let c = fromMaybe M.empty $ M.lookup cu m
|
let c = fromMaybe M.empty $ M.lookup cu m
|
||||||
pc <- if null c
|
pc <- either (const mempty) id . parseRemoteConfig c <$> configParser t c
|
||||||
then pure mempty
|
|
||||||
else either (const mempty) id . parseRemoteConfig c
|
|
||||||
<$> configParser t
|
|
||||||
generate t g u pc gc rs >>= \case
|
generate t g u pc gc rs >>= \case
|
||||||
Nothing -> return Nothing
|
Nothing -> return Nothing
|
||||||
Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs
|
Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs
|
||||||
|
|
10
Remote/S3.hs
10
Remote/S3.hs
|
@ -73,7 +73,7 @@ remote = specialRemoteType $ RemoteType
|
||||||
{ typename = "S3"
|
{ typename = "S3"
|
||||||
, enumerate = const (findSpecialRemotes "s3")
|
, enumerate = const (findSpecialRemotes "s3")
|
||||||
, generate = gen
|
, generate = gen
|
||||||
, configParser = pure $ RemoteConfigParser
|
, configParser = const $ pure $ RemoteConfigParser
|
||||||
{ remoteConfigFieldParsers =
|
{ remoteConfigFieldParsers =
|
||||||
[ optionalStringParser bucketField
|
[ optionalStringParser bucketField
|
||||||
, optionalStringParser hostField
|
, optionalStringParser hostField
|
||||||
|
@ -230,7 +230,8 @@ s3Setup' ss u mcreds c gc
|
||||||
(c', encsetup) <- encryptionSetup c gc
|
(c', encsetup) <- encryptionSetup c gc
|
||||||
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
|
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
|
||||||
let fullconfig = c'' `M.union` defaults
|
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
|
info <- extractS3Info pc
|
||||||
checkexportimportsafe pc info
|
checkexportimportsafe pc info
|
||||||
case ss of
|
case ss of
|
||||||
|
@ -255,7 +256,8 @@ s3Setup' ss u mcreds c gc
|
||||||
M.union c' $
|
M.union c' $
|
||||||
-- special constraints on key names
|
-- special constraints on key names
|
||||||
M.insert mungekeysField (Proposed "ia") defaults
|
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
|
info <- extractS3Info pc
|
||||||
checkexportimportsafe pc info
|
checkexportimportsafe pc info
|
||||||
hdl <- mkS3HandleVar pc gc u
|
hdl <- mkS3HandleVar pc gc u
|
||||||
|
@ -1234,7 +1236,7 @@ enableBucketVersioning ss info _ _ _ = do
|
||||||
Enable oldc -> do
|
Enable oldc -> do
|
||||||
oldpc <- either (const mempty) id
|
oldpc <- either (const mempty) id
|
||||||
. parseRemoteConfig oldc
|
. parseRemoteConfig oldc
|
||||||
<$> configParser remote
|
<$> configParser remote oldc
|
||||||
oldinfo <- extractS3Info oldpc
|
oldinfo <- extractS3Info oldpc
|
||||||
when (versioning info /= versioning oldinfo) $
|
when (versioning info /= versioning oldinfo) $
|
||||||
giveup "Cannot change versioning= of existing S3 remote."
|
giveup "Cannot change versioning= of existing S3 remote."
|
||||||
|
|
|
@ -121,7 +121,7 @@ tahoeSetup _ mu _ c _ = do
|
||||||
scs <- liftIO $ tahoeConfigure configdir
|
scs <- liftIO $ tahoeConfigure configdir
|
||||||
(fromProposedAccepted furl)
|
(fromProposedAccepted furl)
|
||||||
(fromProposedAccepted <$> (M.lookup scsField c))
|
(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
|
let c' = if embedCreds pc
|
||||||
then flip M.union c $ M.fromList
|
then flip M.union c $ M.fromList
|
||||||
[ (furlField, furl)
|
[ (furlField, furl)
|
||||||
|
|
|
@ -123,7 +123,7 @@ webdavSetup _ mu mcreds c gc = do
|
||||||
(return . fromProposedAccepted)
|
(return . fromProposedAccepted)
|
||||||
(M.lookup urlField c)
|
(M.lookup urlField c)
|
||||||
(c', encsetup) <- encryptionSetup c gc
|
(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
|
creds <- maybe (getCreds pc gc u) (return . Just) mcreds
|
||||||
testDav url creds
|
testDav url creds
|
||||||
gitConfigSpecialRemote u c' [("webdav", "true")]
|
gitConfigSpecialRemote u c' [("webdav", "true")]
|
||||||
|
|
|
@ -60,7 +60,7 @@ data RemoteTypeA a = RemoteType
|
||||||
-- generates a remote of this type
|
-- generates a remote of this type
|
||||||
, generate :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))
|
, generate :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))
|
||||||
-- parse configs of remotes of this type
|
-- parse configs of remotes of this type
|
||||||
, configParser :: a RemoteConfigParser
|
, configParser :: RemoteConfig -> a RemoteConfigParser
|
||||||
-- initializes or enables a remote
|
-- initializes or enables a remote
|
||||||
, setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
|
, setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
|
||||||
-- check if a remote of this type is able to support export
|
-- check if a remote of this type is able to support export
|
||||||
|
|
|
@ -44,8 +44,8 @@ data RemoteConfigParser = RemoteConfigParser
|
||||||
, remoteConfigRestPassthrough :: RemoteConfigField -> Bool
|
, remoteConfigRestPassthrough :: RemoteConfigField -> Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
mkRemoteConfigParser :: Monad m => [RemoteConfigFieldParser] -> m RemoteConfigParser
|
mkRemoteConfigParser :: Monad m => [RemoteConfigFieldParser] -> RemoteConfig -> m RemoteConfigParser
|
||||||
mkRemoteConfigParser l = pure (RemoteConfigParser l (const False))
|
mkRemoteConfigParser l _ = pure (RemoteConfigParser l (const False))
|
||||||
|
|
||||||
addRemoteConfigParser :: [RemoteConfigFieldParser] -> RemoteConfigParser -> RemoteConfigParser
|
addRemoteConfigParser :: [RemoteConfigFieldParser] -> RemoteConfigParser -> RemoteConfigParser
|
||||||
addRemoteConfigParser l rpc = rpc { remoteConfigFieldParsers = remoteConfigFieldParsers rpc ++ l }
|
addRemoteConfigParser l rpc = rpc { remoteConfigFieldParsers = remoteConfigFieldParsers rpc ++ l }
|
||||||
|
|
|
@ -54,8 +54,9 @@ could have its own protocol extension details, but none are currently used.
|
||||||
EXTENSIONS
|
EXTENSIONS
|
||||||
|
|
||||||
Next, git-annex will generally send a message telling the special
|
Next, git-annex will generally send a message telling the special
|
||||||
remote to start up. (Or it might send an INITREMOTE or EXPORTSUPPORTED,
|
remote to start up. (Or it might send an INITREMOTE or EXPORTSUPPORTED or
|
||||||
or perhaps other things in the future, so don't hardcode this order.)
|
LISTCONFIGS, or perhaps other things in the future, so don't hardcode this
|
||||||
|
order.)
|
||||||
|
|
||||||
PREPARE
|
PREPARE
|
||||||
|
|
||||||
|
@ -116,9 +117,9 @@ The following requests *must* all be supported by the special remote.
|
||||||
Indicates that INITREMOTE failed.
|
Indicates that INITREMOTE failed.
|
||||||
* `PREPARE`
|
* `PREPARE`
|
||||||
Tells the remote that it's time to prepare itself to be used.
|
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.
|
Only a few requests for details about the remote can come before this
|
||||||
Those include EXTENSIONS, INITREMOTE, and EXPORTSUPPORTED, but others
|
(EXTENSIONS, INITREMOTE, EXPORTSUPPORTED, and LISTCONFIGS,
|
||||||
may be added later.
|
but others may be added later).
|
||||||
* `PREPARE-SUCCESS`
|
* `PREPARE-SUCCESS`
|
||||||
Sent as a response to PREPARE once the special remote is ready for use.
|
Sent as a response to PREPARE once the special remote is ready for use.
|
||||||
* `PREPARE-FAILURE ErrorMsg`
|
* `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
|
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
|
protocol extensions that the special remote uses, but there are currently
|
||||||
no such extensions.
|
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`
|
* `GETCOST`
|
||||||
Requests the remote to return a use cost. Higher costs are more expensive.
|
Requests the remote to return a use cost. Higher costs are more expensive.
|
||||||
(See Config/Cost.hs for some standard costs.)
|
(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
|
Gets one of the special remote's configuration settings, which can have
|
||||||
been passed by the user when running `git annex initremote`, or
|
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.
|
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
|
(git-annex replies with VALUE followed by the value. If the setting is
|
||||||
not set, the value will be empty.)
|
not set, the value will be empty.)
|
||||||
* `SETCREDS Setting User Password`
|
* `SETCREDS Setting User Password`
|
||||||
|
|
8
doc/special_remotes/external/example.sh
vendored
8
doc/special_remotes/external/example.sh
vendored
|
@ -137,7 +137,7 @@ doremove () {
|
||||||
local loc="$2"
|
local loc="$2"
|
||||||
|
|
||||||
# Note that it's not a failure to remove a
|
# 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 [ -e "$loc" ]; then
|
||||||
if runcmd rm -f "$loc"; then
|
if runcmd rm -f "$loc"; then
|
||||||
echo REMOVE-SUCCESS "$key"
|
echo REMOVE-SUCCESS "$key"
|
||||||
|
@ -155,6 +155,12 @@ echo VERSION 1
|
||||||
while read line; do
|
while read line; do
|
||||||
set -- $line
|
set -- $line
|
||||||
case "$1" in
|
case "$1" in
|
||||||
|
LISTCONFIGS)
|
||||||
|
# One CONFIG line for each setting that we GETCONFIG
|
||||||
|
# later.
|
||||||
|
echo CONFIG directory store data here
|
||||||
|
echo CONFIGEND
|
||||||
|
;;
|
||||||
INITREMOTE)
|
INITREMOTE)
|
||||||
# Do anything necessary to create resources
|
# Do anything necessary to create resources
|
||||||
# used by the remote. Try to be idempotent.
|
# used by the remote. Try to be idempotent.
|
||||||
|
|
Loading…
Add table
Reference in a new issue