add SetupStage parameter to RemoteType.setup

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.

Annex/SpecialRemote.hs

@@ -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 ()

Assistant/MakeRemote.hs

@@ -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' :: Bool -> RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Annex RemoteName
-setupSpecialRemote' setdesc name remotetype config mcreds (mu, c) = do
+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) $

Command/EnableRemote.hs

@@ -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

Command/InitRemote.hs

@@ -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

Remote/Bup.hs

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

Remote/Ddar.hs

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

Remote/Directory.hs

@@ -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 :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-directorySetup mu _ c gc = do
+directorySetup _ mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
 	-- verify configuration is sane
 	let dir = fromMaybe (giveup "Specify directory=") $

Remote/External.hs

@@ -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 :: 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
 	let externaltype = fromMaybe (giveup "Specify externaltype=") $
 		M.lookup "externaltype" c

Remote/GCrypt.hs

@@ -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 :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-gCryptSetup mu _ c gc = go $ M.lookup "gitrepo" c
+gCryptSetup _ mu _ c gc = go $ M.lookup "gitrepo" c
   where
 	remotename = fromJust (M.lookup "name" c)
 	go Nothing = giveup "Specify gitrepo="

Remote/Git.hs

@@ -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 :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-gitSetup Nothing _ c _ = do
+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)
+	if isNothing mu || mu == Just u
-gitSetup (Just u) _ c _ = do
+		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.

Remote/Glacier.hs

@@ -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 :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-glacierSetup mu mcreds c gc = do
+glacierSetup ss mu mcreds c gc = do
 	u <- maybe (liftIO genUUID) return mu
-	glacierSetup' (isJust mu) u mcreds c gc
+	glacierSetup' ss u mcreds c gc
-glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+glacierSetup' :: SetupStage -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-glacierSetup' enabling u mcreds c gc = do
+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)

Remote/Hook.hs

@@ -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 :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-hookSetup mu _ c gc = do
+hookSetup _ mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
 	let hooktype = fromMaybe (giveup "Specify hooktype=") $
 		M.lookup "hooktype" c

Remote/Rsync.hs

@@ -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 :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-rsyncSetup mu _ c gc = do
+rsyncSetup _ mu _ c gc = do
 	u <- maybe (liftIO genUUID) return mu
 	-- verify configuration is sane
 	let url = fromMaybe (giveup "Specify rsyncurl=") $

Remote/S3.hs

@@ -106,12 +106,12 @@ gen r u c gc = do
 			, checkUrl = Nothing
 			}
 
-s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+s3Setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-s3Setup mu mcreds c gc = do
+s3Setup ss mu mcreds c gc = do
 	u <- maybe (liftIO genUUID) return mu
-	s3Setup' (isNothing mu) u mcreds c gc
+	s3Setup' ss u mcreds c gc
-s3Setup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+s3Setup' :: SetupStage -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-s3Setup' new u mcreds c gc
+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
 

Remote/Tahoe.hs

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

Remote/WebDAV.hs

@@ -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 :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
-webdavSetup mu mcreds c gc = do
+webdavSetup _ mu mcreds c gc = do
 	u <- maybe (liftIO genUUID) return mu
 	url <- case M.lookup "url" c of
 		Nothing -> giveup "Specify url="

Types/Remote.hs

@@ -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
+	-- initializes or enables a remote
-	setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
+	setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
 }
 
 instance Eq (RemoteTypeA a) where