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:
Joey Hess
parent
1ce722d86f
commit
99cb3e75f1
20 changed files with 158 additions and 76 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue