summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
Diffstat (limited to 'Remote')
-rw-r--r--Remote/Bup.hs2
-rw-r--r--Remote/Ddar.hs2
-rw-r--r--Remote/Directory.hs2
-rw-r--r--Remote/External.hs4
-rw-r--r--Remote/GCrypt.hs2
-rw-r--r--Remote/Glacier.hs12
-rw-r--r--Remote/Helper/Encryptable.hs35
-rw-r--r--Remote/Hook.hs2
-rw-r--r--Remote/Rsync.hs2
-rw-r--r--Remote/S3.hs13
-rw-r--r--Remote/WebDAV.hs4
11 files changed, 53 insertions, 27 deletions
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 0de0e2946..cc64d6ff5 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -94,7 +94,7 @@ bupSetup mu _ c = do
-- verify configuration is sane
let buprepo = fromMaybe (error "Specify buprepo=") $
M.lookup "buprepo" c
- c' <- encryptionSetup c
+ (c', _encsetup) <- encryptionSetup c
-- bup init will create the repository.
-- (If the repository already exists, bup init again appears safe.)
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index fc226ddff..1db482b47 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -84,7 +84,7 @@ ddarSetup mu _ c = do
-- verify configuration is sane
let ddarrepo = fromMaybe (error "Specify ddarrepo=") $
M.lookup "ddarrepo" c
- c' <- encryptionSetup c
+ (c', _encsetup) <- encryptionSetup c
-- The ddarrepo is stored in git config, as well as this repo's
-- persistant state, so it can vary between hosts.
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 3137c9534..fa4d027ae 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -81,7 +81,7 @@ directorySetup mu _ c = do
absdir <- liftIO $ absPath dir
liftIO $ unlessM (doesDirectoryExist absdir) $
error $ "Directory does not exist: " ++ absdir
- c' <- encryptionSetup c
+ (c', _encsetup) <- encryptionSetup c
-- The directory is stored in git config, not in this remote's
-- persistant state, so it can vary between hosts.
diff --git a/Remote/External.hs b/Remote/External.hs
index 6ba0e2f3a..c3ea7e1db 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -77,7 +77,7 @@ externalSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
let externaltype = fromMaybe (error "Specify externaltype=") $
M.lookup "externaltype" c
- c' <- encryptionSetup c
+ (c', _encsetup) <- encryptionSetup c
external <- newExternal externaltype u c'
handleRequest external INITREMOTE Nothing $ \resp -> case resp of
@@ -191,7 +191,7 @@ handleRequest' lck external req mp responsehandler
send $ VALUE value
handleRemoteRequest (SETCREDS setting login password) = do
c <- liftIO $ atomically $ readTMVar $ externalConfig external
- c' <- setRemoteCredPair c (credstorage setting) $
+ c' <- setRemoteCredPair encryptionAlreadySetup c (credstorage setting) $
Just (login, password)
void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
handleRemoteRequest (GETCREDS setting) = do
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index a95f21669..f1d561d23 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -168,7 +168,7 @@ gCryptSetup mu _ c = go $ M.lookup "gitrepo" c
remotename = fromJust (M.lookup "name" c)
go Nothing = error "Specify gitrepo="
go (Just gitrepo) = do
- c' <- encryptionSetup c
+ (c', _encsetup) <- encryptionSetup c
inRepo $ Git.Command.run
[ Params "remote add"
, Param remotename
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 18038a79c..ba3cc558f 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -76,12 +76,12 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
glacierSetup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu
- c' <- setRemoteCredPair c (AWS.creds u) mcreds
- glacierSetup' (isJust mu) u c'
-glacierSetup' :: Bool -> UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
-glacierSetup' enabling u c = do
- c' <- encryptionSetup c
- let fullconfig = c' `M.union` defaults
+ glacierSetup' (isJust mu) u mcreds c
+glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
+glacierSetup' enabling u mcreds c = do
+ (c', encsetup) <- encryptionSetup c
+ c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
+ let fullconfig = c'' `M.union` defaults
unless enabling $
genVault fullconfig u
gitConfigSpecialRemote u fullconfig "glacier" "true"
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
index dd032ce33..e8e9d3bf1 100644
--- a/Remote/Helper/Encryptable.hs
+++ b/Remote/Helper/Encryptable.hs
@@ -5,7 +5,17 @@
- Licensed under the GNU GPL version 3 or higher.
-}
-module Remote.Helper.Encryptable where
+module Remote.Helper.Encryptable (
+ EncryptionIsSetup,
+ encryptionSetup,
+ noEncryptionUsed,
+ encryptionAlreadySetup,
+ remoteCipher,
+ embedCreds,
+ cipherKey,
+ storeCipher,
+ extractCipher,
+) where
import qualified Data.Map as M
@@ -16,11 +26,26 @@ import Types.Crypto
import qualified Annex
import Utility.Base64
+-- Used to ensure that encryption has been set up before trying to
+-- eg, store creds in the remote config that would need to use the
+-- encryption setup.
+data EncryptionIsSetup = EncryptionIsSetup | NoEncryption
+
+-- Remotes that don't use encryption can use this instead of
+-- encryptionSetup.
+noEncryptionUsed :: EncryptionIsSetup
+noEncryptionUsed = NoEncryption
+
+-- Using this avoids the type-safe check, so you'd better be sure
+-- of what you're doing.
+encryptionAlreadySetup :: EncryptionIsSetup
+encryptionAlreadySetup = EncryptionIsSetup
+
{- Encryption setup for a remote. The user must specify whether to use
- an encryption key, or not encrypt. An encrypted cipher is created, or is
- updated to be accessible to an additional encryption key. Or the user
- could opt to use a shared cipher, which is stored unencrypted. -}
-encryptionSetup :: RemoteConfig -> Annex RemoteConfig
+encryptionSetup :: RemoteConfig -> Annex (RemoteConfig, EncryptionIsSetup)
encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
where
-- The type of encryption
@@ -28,7 +53,7 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
-- Generate a new cipher, depending on the chosen encryption scheme
genCipher = case encryption of
_ | M.member "cipher" c || M.member "cipherkeys" c -> cannotchange
- Just "none" -> return c
+ Just "none" -> return (c, NoEncryption)
Just "shared" -> use "encryption setup" . genSharedCipher
=<< highRandomQuality
-- hybrid encryption is the default when a keyid is
@@ -48,7 +73,7 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
cannotchange = error "Cannot set encryption type of existing remotes."
-- Update an existing cipher if possible.
updateCipher v = case v of
- SharedCipher _ | maybe True (== "shared") encryption -> return c'
+ SharedCipher _ | maybe True (== "shared") encryption -> return (c', EncryptionIsSetup)
EncryptedCipher _ variant _
| maybe True (== if variant == Hybrid then "hybrid" else "pubkey") encryption ->
use "encryption update" $ updateEncryptedCipher newkeys v
@@ -57,7 +82,7 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
showNote m
cipher <- liftIO a
showNote $ describeCipher cipher
- return $ storeCipher c' cipher
+ return (storeCipher c' cipher, EncryptionIsSetup)
highRandomQuality =
(&&) (maybe True ( /= "false") $ M.lookup "highRandomQuality" c)
<$> fmap not (Annex.getState Annex.fast)
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 8e6ac439d..45a0ae742 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -70,7 +70,7 @@ hookSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
let hooktype = fromMaybe (error "Specify hooktype=") $
M.lookup "hooktype" c
- c' <- encryptionSetup c
+ (c', _encsetup) <- encryptionSetup c
gitConfigSpecialRemote u c' "hooktype" hooktype
return (c', u)
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 698d733e6..643411149 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -138,7 +138,7 @@ rsyncSetup mu _ c = do
-- verify configuration is sane
let url = fromMaybe (error "Specify rsyncurl=") $
M.lookup "rsyncurl" c
- c' <- encryptionSetup c
+ (c', _encsetup) <- encryptionSetup c
-- The rsyncurl is stored in git config, not only in this remote's
-- persistant state, so it can vary between hosts.
diff --git a/Remote/S3.hs b/Remote/S3.hs
index ae1acd531..90eb8c691 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -77,10 +77,9 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu
- c' <- setRemoteCredPair c (AWS.creds u) mcreds
- s3Setup' u c'
-s3Setup' :: UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
-s3Setup' u c = if isIA c then archiveorg else defaulthost
+ s3Setup' u mcreds c
+s3Setup' :: UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
+s3Setup' u mcreds c = if isIA c then archiveorg else defaulthost
where
remotename = fromJust (M.lookup "name" c)
defbucket = remotename ++ "-" ++ fromUUID u
@@ -97,13 +96,15 @@ s3Setup' u c = if isIA c then archiveorg else defaulthost
return (fullconfig, u)
defaulthost = do
- c' <- encryptionSetup c
- let fullconfig = c' `M.union` defaults
+ (c', encsetup) <- encryptionSetup c
+ c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
+ let fullconfig = c'' `M.union` defaults
genBucket fullconfig u
use fullconfig
archiveorg = do
showNote "Internet Archive mode"
+ void $ setRemoteCredPair noEncryptionUsed c (AWS.creds u) mcreds
-- Ensure user enters a valid bucket name, since
-- this determines the name of the archive.org item.
let bucket = replace " " "-" $ map toLower $
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index d427d67a9..d90686608 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -81,11 +81,11 @@ webdavSetup mu mcreds c = do
url <- case M.lookup "url" c of
Nothing -> error "Specify url="
Just url -> return url
- c' <- encryptionSetup c
+ (c', encsetup) <- encryptionSetup c
creds <- maybe (getCreds c' u) (return . Just) mcreds
testDav url creds
gitConfigSpecialRemote u c' "webdav" "true"
- c'' <- setRemoteCredPair c' (davCreds u) creds
+ c'' <- setRemoteCredPair encsetup c' (davCreds u) creds
return (c'', u)
-- Opens a http connection to the DAV server, which will be reused
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-09 23:43:22 +0000