mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

add SetupStage parameter to RemoteType.setup

Browse source 
Most remotes have an idempotent setup that can be reused for
enableremote, but in a few cases, it needs to tell which, and whether
a UUID was provided to setup was used.

This is groundwork for making initremote be able to provide a UUID.
It should not change any behavior.

Note that it would be nice to make the UUID always be provided to setup,
and make setup not need to generate and return a UUID. What prevented
this simplification is Remote.Git.gitSetup, which needs to reuse the
UUID of the git remote when setting it up, and so has to return that
UUID.

This commit was sponsored by Thom May on Patreon.
This commit is contained in:
Joey Hess 2017-02-07 14:35:58 -04:00
parent 7487b4da47
commit 5c804cf42e
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
17 changed files with 56 additions and 48 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Annex/SpecialRemote.hs
View file

@ -9,7 +9,7 @@ module Annex.SpecialRemote where
import Annex.Common
import Remote (remoteTypes, remoteMap)
import Types.Remote (RemoteConfig, RemoteConfigKey, typename, setup)
import Types.Remote (RemoteConfig, RemoteConfigKey, SetupStage(..), typename, setup)
import Logs.Remote
import Logs.Trust
import qualified Git.Config
@ -79,7 +79,7 @@ autoEnable = do
case (M.lookup nameKey c, findType c) of
(Just name, Right t) -> whenM (canenable u) $ do
showSideAction $ "Auto enabling special remote " ++ name
res <- tryNonAsync $ setup t (Just u) Nothing c def
res <- tryNonAsync $ setup t Enable (Just u) Nothing c def
case res of
Left e -> warning (show e)
Right _ -> return ()

16
Assistant/MakeRemote.hs
View file

@ -49,9 +49,9 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $
go =<< Annex.SpecialRemote.findExisting name
where
go Nothing = setupSpecialRemote name Rsync.remote config Nothing
(Nothing, Annex.SpecialRemote.newConfig name)
(Nothing, R.Init, Annex.SpecialRemote.newConfig name)
go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing
(Just u, c)
(Just u, R.Enable, c)
config = M.fromList
[ ("encryption", "shared")
, ("rsyncurl", location)
@ -81,7 +81,7 @@ initSpecialRemote name remotetype mcreds config = go 0
r <- Annex.SpecialRemote.findExisting fullname
case r of
Nothing -> setupSpecialRemote fullname remotetype config mcreds
(Nothing, Annex.SpecialRemote.newConfig fullname)
(Nothing, R.Init, Annex.SpecialRemote.newConfig fullname)
Just _ -> go (n + 1)
{- Enables an existing special remote. -}
@ -90,19 +90,19 @@ enableSpecialRemote name remotetype mcreds config = do
r <- Annex.SpecialRemote.findExisting name
case r of
Nothing -> error $ "Cannot find a special remote named " ++ name
Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, c)
Just (u, c) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable, c)
setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote = setupSpecialRemote' True
setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote' setdesc name remotetype config mcreds (mu, c) = do
setupSpecialRemote' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Annex RemoteName
setupSpecialRemote' setdesc name remotetype config mcreds (mu, ss, c) = do
{- Currently, only 'weak' ciphers can be generated from the
- assistant, because otherwise GnuPG may block once the entropy
- pool is drained, and as of now there's no way to tell the user
- to perform IO actions to refill the pool. -}
let weakc = M.insert "highRandomQuality" "false" $ M.union config c
(c', u) <- R.setup remotetype mu mcreds weakc def
(c', u) <- R.setup remotetype ss mu mcreds weakc def
configSet u c'
when setdesc $
whenM (isNothing . M.lookup u <$> uuidMap) $

2
Command/EnableRemote.hs
View file

@ -69,7 +69,7 @@ startSpecialRemote name config (Just (u, c)) = do
performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> RemoteGitConfig -> CommandPerform
performSpecialRemote t u c gc = do
(c', u') <- R.setup t (Just u) Nothing c gc
(c', u') <- R.setup t R.Enable (Just u) Nothing c gc
next $ cleanupSpecialRemote u' c'
cleanupSpecialRemote :: UUID -> R.RemoteConfig -> CommandCleanup

2
Command/InitRemote.hs
View file

@ -46,7 +46,7 @@ start (name:ws) = ifM (isJust <$> findExisting name)
perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform
perform t name c = do
(c', u) <- R.setup t Nothing Nothing c def
(c', u) <- R.setup t R.Init Nothing Nothing c def
next $ cleanup u name c'
cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup

4
Remote/Bup.hs
View file

@ -90,8 +90,8 @@ gen r u c gc = do
{ chunkConfig = NoChunks
}
bupSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
bupSetup mu _ c gc = do
bupSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
bupSetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane

4
Remote/Ddar.hs
View file

@ -82,8 +82,8 @@ gen r u c gc = do
{ chunkConfig = NoChunks
}
ddarSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
ddarSetup mu _ c gc = do
ddarSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
ddarSetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane

4
Remote/Directory.hs
View file

@ -77,8 +77,8 @@ gen r u c gc = do
where
dir = fromMaybe (giveup "missing directory") $ remoteAnnexDirectory gc
directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
directorySetup mu _ c gc = do
directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
directorySetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
let dir = fromMaybe (giveup "Specify directory=") $

4
Remote/External.hs
View file

@ -109,8 +109,8 @@ gen r u c gc
rmt
externaltype = fromMaybe (giveup "missing externaltype") (remoteAnnexExternalType gc)
externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
externalSetup mu _ c gc = do
externalSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
externalSetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
let externaltype = fromMaybe (giveup "Specify externaltype=") $
M.lookup "externaltype" c

4
Remote/GCrypt.hs
View file

@ -169,8 +169,8 @@ noCrypto = giveup "cannot use gcrypt remote without encryption enabled"
unsupportedUrl :: a
unsupportedUrl = giveup "using non-ssh remote repo url with gcrypt is not supported"
gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
gCryptSetup mu _ c gc = go $ M.lookup "gitrepo" c
gCryptSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
gCryptSetup _ mu _ c gc = go $ M.lookup "gitrepo" c
where
remotename = fromJust (M.lookup "name" c)
go Nothing = giveup "Specify gitrepo="

11
Remote/Git.hs
View file

@ -96,8 +96,8 @@ list autoinit = do
- No attempt is made to make the remote be accessible via ssh key setup,
- etc.
-}
gitSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
gitSetup Nothing _ c _ = do
gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
gitSetup Init mu _ c _ = do
let location = fromMaybe (giveup "Specify location=url") $
Url.parseURIRelaxed =<< M.lookup "location" c
g <- Annex.gitRepo
@ -105,8 +105,10 @@ gitSetup Nothing _ c _ = do
[r] -> getRepoUUID r
[] -> giveup "could not find existing git remote with specified location"
_ -> giveup "found multiple git remotes with specified location"
return (c, u)
gitSetup (Just u) _ c _ = do
if isNothing mu || mu == Just u
then return (c, u)
else error "git remote did not have specified uuid"
gitSetup Enable (Just u) _ c _ = do
inRepo $ Git.Command.run
[ Param "remote"
, Param "add"
@ -114,6 +116,7 @@ gitSetup (Just u) _ c _ = do
, Param $ fromMaybe (giveup "no location") (M.lookup "location" c)
]
return (c, u)
gitSetup Enable Nothing _ _ _ = error "unable to enable git remote with no specified uuid"
{- It's assumed to be cheap to read the config of non-URL remotes, so this is
- done each time git-annex is run in a way that uses remotes.

12
Remote/Glacier.hs
View file

@ -78,16 +78,16 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
{ chunkConfig = NoChunks
}
glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
glacierSetup mu mcreds c gc = do
glacierSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
glacierSetup ss mu mcreds c gc = do
u <- maybe (liftIO genUUID) return mu
glacierSetup' (isJust mu) u mcreds c gc
glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
glacierSetup' enabling u mcreds c gc = do
glacierSetup' ss u mcreds c gc
glacierSetup' :: SetupStage -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
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
unless enabling $
when (ss == Init) $
genVault fullconfig gc u
gitConfigSpecialRemote u fullconfig "glacier" "true"
return (fullconfig, u)

4
Remote/Hook.hs
View file

@ -70,8 +70,8 @@ gen r u c gc = do
where
hooktype = fromMaybe (giveup "missing hooktype") $ remoteAnnexHookType gc
hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
hookSetup mu _ c gc = do
hookSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
hookSetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
let hooktype = fromMaybe (giveup "Specify hooktype=") $
M.lookup "hooktype" c

4
Remote/Rsync.hs
View file

@ -137,8 +137,8 @@ rsyncTransport gc url
loginopt = maybe [] (\l -> ["-l",l]) login
fromNull as xs = if null xs then as else xs
rsyncSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
rsyncSetup mu _ c gc = do
rsyncSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
rsyncSetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
let url = fromMaybe (giveup "Specify rsyncurl=") $

12
Remote/S3.hs
View file

@ -106,12 +106,12 @@ gen r u c gc = do
, checkUrl = Nothing
}
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
s3Setup mu mcreds c gc = do
s3Setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
s3Setup ss mu mcreds c gc = do
u <- maybe (liftIO genUUID) return mu
s3Setup' (isNothing mu) u mcreds c gc
s3Setup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
s3Setup' new u mcreds c gc
s3Setup' ss u mcreds c gc
s3Setup' :: SetupStage -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
s3Setup' ss u mcreds c gc
| configIA c = archiveorg
| otherwise = defaulthost
where
@ -133,7 +133,7 @@ s3Setup' new u mcreds c gc
(c', encsetup) <- encryptionSetup c gc
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
let fullconfig = c'' `M.union` defaults
when new $
when (ss == Init) $
genBucket fullconfig gc u
use fullconfig

4
Remote/Tahoe.hs
View file

@ -91,8 +91,8 @@ gen r u c gc = do
, checkUrl = Nothing
}
tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
tahoeSetup mu _ c _ = do
tahoeSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
tahoeSetup _ mu _ c _ = do
furl <- fromMaybe (fromMaybe missingfurl $ M.lookup furlk c)
<$> liftIO (getEnv "TAHOE_FURL")
u <- maybe (liftIO genUUID) return mu

4
Remote/WebDAV.hs
View file

@ -86,8 +86,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
}
chunkconfig = getChunkConfig c
webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
webdavSetup mu mcreds c gc = do
webdavSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
webdavSetup _ mu mcreds c gc = do
u <- maybe (liftIO genUUID) return mu
url <- case M.lookup "url" c of
Nothing -> giveup "Specify url="

9
Types/Remote.hs
View file

@ -14,6 +14,7 @@ module Types.Remote
, RemoteConfig
, RemoteTypeA(..)
, RemoteA(..)
, SetupStage(..)
, Availability(..)
, Verification(..)
, unVerified
@ -38,8 +39,12 @@ import Utility.SafeCommand
import Utility.Url
type RemoteConfigKey = String
type RemoteConfig = M.Map RemoteConfigKey String
data SetupStage = Init | Enable
deriving (Eq)
{- There are different types of remotes. -}
data RemoteTypeA a = RemoteType {
-- human visible type name
@ -49,8 +54,8 @@ data RemoteTypeA a = RemoteType {
enumerate :: Bool -> a [Git.Repo],
-- generates a remote of this type
generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)),
-- initializes or changes a remote
setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
-- initializes or enables a remote
setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
}
instance Eq (RemoteTypeA a) where