aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex/SpecialRemote.hs4
-rw-r--r--Assistant/MakeRemote.hs16
-rw-r--r--Command/EnableRemote.hs2
-rw-r--r--Command/InitRemote.hs2
-rw-r--r--Remote/Bup.hs4
-rw-r--r--Remote/Ddar.hs4
-rw-r--r--Remote/Directory.hs4
-rw-r--r--Remote/External.hs4
-rw-r--r--Remote/GCrypt.hs4
-rw-r--r--Remote/Git.hs11
-rw-r--r--Remote/Glacier.hs12
-rw-r--r--Remote/Hook.hs4
-rw-r--r--Remote/Rsync.hs4
-rw-r--r--Remote/S3.hs12
-rw-r--r--Remote/Tahoe.hs4
-rw-r--r--Remote/WebDAV.hs4
-rw-r--r--Types/Remote.hs9
17 files changed, 56 insertions, 48 deletions
diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs
index 0fd24f023..3e2b1da0a 100644
--- a/Annex/SpecialRemote.hs
+++ b/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 ()
diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs
index a5972b0d8..6d0377206 100644
--- a/Assistant/MakeRemote.hs
+++ b/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' 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) $
diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs
index 61cd543e6..96efce39c 100644
--- a/Command/EnableRemote.hs
+++ b/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
diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs
index e5d7a9039..4a89bed7c 100644
--- a/Command/InitRemote.hs
+++ b/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
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 75b379558..9bdb22edd 100644
--- a/Remote/Bup.hs
+++ b/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 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
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index dcb16f5dd..603eccd5e 100644
--- a/Remote/Ddar.hs
+++ b/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 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
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 248e5d49f..2452c42e2 100644
--- a/Remote/Directory.hs
+++ b/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 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=") $
diff --git a/Remote/External.hs b/Remote/External.hs
index 7091a657c..b66e102a4 100644
--- a/Remote/External.hs
+++ b/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 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
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 78ab6ed79..78b1eed3c 100644
--- a/Remote/GCrypt.hs
+++ b/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 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="
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 5eb6fbc9e..a0b590654 100644
--- a/Remote/Git.hs
+++ b/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 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.
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 77a907b97..c2f9bcf12 100644
--- a/Remote/Glacier.hs
+++ b/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 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)
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 6abffe117..0ebbf9139 100644
--- a/Remote/Hook.hs
+++ b/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 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
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 22ef0b2cf..dbaf2acc9 100644
--- a/Remote/Rsync.hs
+++ b/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 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=") $
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 43d07230e..341b66d1a 100644
--- a/Remote/S3.hs
+++ b/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 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
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index c29cfb438..e4686f2f2 100644
--- a/Remote/Tahoe.hs
+++ b/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 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
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 14947f1e9..2c4d24c35 100644
--- a/Remote/WebDAV.hs
+++ b/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 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="
diff --git a/Types/Remote.hs b/Types/Remote.hs
index dd4c7d2e5..bd75840b3 100644
--- a/Types/Remote.hs
+++ b/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
- 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-12 12:23:22 +0000