aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex/SpecialRemote.hs2
-rw-r--r--Assistant/MakeRemote.hs6
-rw-r--r--Command/EnableRemote.hs10
-rw-r--r--Command/InitRemote.hs2
-rw-r--r--Creds.hs38
-rw-r--r--Crypto.hs41
-rw-r--r--Remote.hs6
-rw-r--r--Remote/Bup.hs4
-rw-r--r--Remote/Ddar.hs4
-rw-r--r--Remote/Directory.hs4
-rw-r--r--Remote/External.hs11
-rw-r--r--Remote/External/Types.hs7
-rw-r--r--Remote/GCrypt.hs4
-rw-r--r--Remote/Git.hs6
-rw-r--r--Remote/Glacier.hs38
-rw-r--r--Remote/Helper/Special.hs17
-rw-r--r--Remote/Hook.hs4
-rw-r--r--Remote/Rsync.hs4
-rw-r--r--Remote/S3.hs36
-rw-r--r--Remote/Tahoe.hs4
-rw-r--r--Remote/WebDAV.hs12
-rw-r--r--Types/Remote.hs2
-rw-r--r--debian/changelog2
23 files changed, 139 insertions, 125 deletions
diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs
index 8a2345830..02799db85 100644
--- a/Annex/SpecialRemote.hs
+++ b/Annex/SpecialRemote.hs
@@ -80,7 +80,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
+ res <- tryNonAsync $ setup t (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 8a70e30c2..a5972b0d8 100644
--- a/Assistant/MakeRemote.hs
+++ b/Assistant/MakeRemote.hs
@@ -101,8 +101,8 @@ setupSpecialRemote' setdesc name remotetype config mcreds (mu, c) = do
- 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. -}
- (c', u) <- R.setup remotetype mu mcreds $
- M.insert "highRandomQuality" "false" $ M.union config c
+ let weakc = M.insert "highRandomQuality" "false" $ M.union config c
+ (c', u) <- R.setup remotetype mu mcreds weakc def
configSet u c'
when setdesc $
whenM (isNothing . M.lookup u <$> uuidMap) $
@@ -168,4 +168,4 @@ previouslyUsedCredPair getstorage remotetype criteria =
sametype r = R.typename (R.remotetype r) == R.typename remotetype
fromstorage r = do
let storage = getstorage (R.uuid r)
- getRemoteCredPair (R.config r) storage
+ getRemoteCredPair (R.config r) (R.gitconfig r) storage
diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs
index 182527095..be20ea049 100644
--- a/Command/EnableRemote.hs
+++ b/Command/EnableRemote.hs
@@ -12,6 +12,7 @@ import qualified Logs.Remote
import qualified Types.Remote as R
import qualified Annex.SpecialRemote
import qualified Remote
+import qualified Types.Remote as Remote
import Logs.UUID
import qualified Data.Map as M
@@ -43,7 +44,8 @@ start (name:ws) = go =<< Annex.SpecialRemote.findExisting name
let fullconfig = config `M.union` c
t <- either error return (Annex.SpecialRemote.findType fullconfig)
showStart "enableremote" name
- next $ perform t u fullconfig
+ gc <- maybe def Remote.gitconfig <$> Remote.byUUID u
+ next $ perform t u fullconfig gc
unknownNameError :: String -> Annex a
unknownNameError prefix = do
@@ -56,9 +58,9 @@ unknownNameError prefix = do
descm (M.keys m)
error $ prefix ++ "\n" ++ msg
-perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
-perform t u c = do
- (c', u') <- R.setup t (Just u) Nothing c
+perform :: RemoteType -> UUID -> R.RemoteConfig -> RemoteGitConfig -> CommandPerform
+perform t u c gc = do
+ (c', u') <- R.setup t (Just u) Nothing c gc
next $ cleanup u' c'
cleanup :: UUID -> R.RemoteConfig -> CommandCleanup
diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs
index 1f3d63dbd..05717bc60 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
+ (c', u) <- R.setup t Nothing Nothing c def
next $ cleanup u name c'
cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup
diff --git a/Creds.hs b/Creds.hs
index 6a2eaafd5..a72c704e8 100644
--- a/Creds.hs
+++ b/Creds.hs
@@ -52,33 +52,37 @@ data CredPairStorage = CredPairStorage
- cipher. The EncryptionIsSetup phantom type ensures that is the case.
-}
setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
-setRemoteCredPair encsetup c storage Nothing =
- maybe (return c) (setRemoteCredPair encsetup c storage . Just)
- =<< getRemoteCredPair c storage
-setRemoteCredPair _ c storage (Just creds)
- | embedCreds c = case credPairRemoteKey storage of
- Nothing -> localcache
- Just key -> storeconfig key =<< remoteCipher =<< localcache
- | otherwise = localcache
+setRemoteCredPair encsetup c storage mcreds = case mcreds of
+ Nothing -> maybe (return c) (setRemoteCredPair encsetup c storage . Just)
+ =<< getRemoteCredPair c nogitconfig storage
+ Just creds
+ | embedCreds c -> case credPairRemoteKey storage of
+ Nothing -> localcache creds
+ Just key -> storeconfig creds key =<< remoteCipher =<< localcache creds
+ | otherwise -> localcache creds
where
- localcache = do
+ localcache creds = do
writeCacheCredPair creds storage
return c
- storeconfig key (Just cipher) = do
+ storeconfig creds key (Just cipher) = do
cmd <- gpgCmd <$> Annex.getGitConfig
- s <- liftIO $ encrypt cmd (getGpgEncParams c) cipher
+ s <- liftIO $ encrypt cmd (c, nogitconfig) cipher
(feedBytes $ L.pack $ encodeCredPair creds)
(readBytes $ return . L.unpack)
return $ M.insert key (toB64 s) c
- storeconfig key Nothing =
+ storeconfig creds key Nothing =
return $ M.insert key (toB64 $ encodeCredPair creds) c
+ -- This is used before a remote is set up typically, so
+ -- use a default RemoteGitConfig
+ nogitconfig :: RemoteGitConfig
+ nogitconfig = def
{- Gets a remote's credpair, from the environment if set, otherwise
- from the cache in gitAnnexCredsDir, or failing that, from the
- value in RemoteConfig. -}
-getRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair)
-getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv
+getRemoteCredPair :: RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)
+getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv
where
fromenv = liftIO $ getEnvCredPair storage
fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage
@@ -94,7 +98,7 @@ getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv
Nothing -> return Nothing
fromenccreds enccreds cipher storablecipher = do
cmd <- gpgCmd <$> Annex.getGitConfig
- mcreds <- liftIO $ catchMaybeIO $ decrypt cmd (getGpgDecParams c) cipher
+ mcreds <- liftIO $ catchMaybeIO $ decrypt cmd (c, gc) cipher
(feedBytes $ L.pack $ fromB64 enccreds)
(readBytes $ return . L.unpack)
case mcreds of
@@ -114,8 +118,8 @@ getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv
return $ Just credpair
_ -> error "bad creds"
-getRemoteCredPairFor :: String -> RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair)
-getRemoteCredPairFor this c storage = go =<< getRemoteCredPair c storage
+getRemoteCredPairFor :: String -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)
+getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage
where
go Nothing = do
warnMissingCredPairFor this storage
diff --git a/Crypto.hs b/Crypto.hs
index 62c807f8e..91efd71c6 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -28,8 +28,7 @@ module Crypto (
readBytes,
encrypt,
decrypt,
- getGpgEncParams,
- getGpgDecParams,
+ LensGpgEncParams(..),
prop_HmacSha1WithCipher_sane
) where
@@ -179,24 +178,24 @@ readBytes a h = liftIO (L.hGetContents h) >>= a
{- Runs a Feeder action, that generates content that is symmetrically
- encrypted with the Cipher (unless it is empty, in which case
- public-key encryption is used) using the given gpg options, and then
- - read by the Reader action. Note: For public-key encryption,
- - recipients MUST be included in 'params' (for instance using
- - 'getGpgEncParams'). -}
-encrypt :: (MonadIO m, MonadMask m) => Gpg.GpgCmd -> [CommandParam] -> Cipher -> Feeder -> Reader m a -> m a
-encrypt cmd params cipher = case cipher of
+ - read by the Reader action. -}
+encrypt :: (MonadIO m, MonadMask m, LensGpgEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a
+encrypt cmd c cipher = case cipher of
Cipher{} -> Gpg.feedRead cmd (params ++ Gpg.stdEncryptionParams True) $
cipherPassphrase cipher
MacOnlyCipher{} -> Gpg.pipeLazy cmd $ params ++ Gpg.stdEncryptionParams False
+ where
+ params = getGpgEncParams c
{- Runs a Feeder action, that generates content that is decrypted with the
- Cipher (or using a private key if the Cipher is empty), and read by the
- Reader action. -}
-decrypt :: (MonadIO m, MonadMask m) => Gpg.GpgCmd -> [CommandParam] -> Cipher -> Feeder -> Reader m a -> m a
-decrypt cmd params cipher = case cipher of
+decrypt :: (MonadIO m, MonadMask m, LensGpgEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a
+decrypt cmd c cipher = case cipher of
Cipher{} -> Gpg.feedRead cmd params' $ cipherPassphrase cipher
MacOnlyCipher{} -> Gpg.pipeLazy cmd params'
where
- params' = Param "--decrypt" : params
+ params' = Param "--decrypt" : getGpgDecParams c
macWithCipher :: Mac -> Cipher -> String -> String
macWithCipher mac c = macWithCipher' mac (cipherMac c)
@@ -218,20 +217,14 @@ class LensGpgEncParams a where
{- Extract the GnuPG options from a pair of a Remote Config and a Remote
- Git Config. -}
instance LensGpgEncParams (RemoteConfig, RemoteGitConfig) where
- getGpgEncParams (c,gc) = map Param (remoteAnnexGnupgOptions gc) ++ getGpgEncParams c
- getGpgDecParams (c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc) ++ getGpgDecParams c
-
-{- Extract the GnuPG options from a Remote Config, ignoring any
- - git config settings. (Which is ok if the remote is just being set up
- - and so doesn't have any.) -}
-instance LensGpgEncParams RemoteConfig where
- {- If the remote is configured to use public-key encryption,
- - look up the recipient keys and add them to the option list. -}
- getGpgEncParams c = case M.lookup "encryption" c of
- Just "pubkey" -> Gpg.pkEncTo $ maybe [] (split ",") $ M.lookup "cipherkeys" c
- Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (split ",") $ M.lookup "pubkeys" c
- _ -> []
- getGpgDecParams _ = []
+ getGpgEncParams (c,gc) = map Param (remoteAnnexGnupgOptions gc) ++
+ {- When the remote is configured to use public-key encryption,
+ - look up the recipient keys and add them to the option list. -}
+ case M.lookup "encryption" c of
+ Just "pubkey" -> Gpg.pkEncTo $ maybe [] (split ",") $ M.lookup "cipherkeys" c
+ Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (split ",") $ M.lookup "pubkeys" c
+ _ -> []
+ getGpgDecParams (_c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc)
{- Extract the GnuPG options from a Remote. -}
instance LensGpgEncParams (RemoteA a) where
diff --git a/Remote.hs b/Remote.hs
index 0dd8b0ace..79059df99 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -31,6 +31,7 @@ module Remote (
byNameOrGroup,
byNameOnly,
byNameWithUUID,
+ byUUID,
byCost,
prettyPrintUUIDs,
prettyPrintUUIDsDescs,
@@ -98,6 +99,11 @@ addName desc n
| desc == n || null desc = "[" ++ n ++ "]"
| otherwise = desc ++ " [" ++ n ++ "]"
+byUUID :: UUID -> Annex (Maybe Remote)
+byUUID u = headMaybe . filter matching <$> remoteList
+ where
+ matching r = uuid r == u
+
{- When a name is specified, looks up the remote matching that name.
- (Or it can be a UUID.)
-
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index a481504a0..eda1950d3 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 -> Annex (RemoteConfig, UUID)
-bupSetup mu _ c = do
+bupSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+bupSetup mu _ c _ = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index 8758949c9..3d0ad53b2 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 -> Annex (RemoteConfig, UUID)
-ddarSetup mu _ c = do
+ddarSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+ddarSetup mu _ c _ = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 190008078..d7c5696a9 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -77,8 +77,8 @@ gen r u c gc = do
where
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
-directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-directorySetup mu _ c = do
+directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+directorySetup mu _ c _ = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
let dir = fromMaybe (error "Specify directory=") $
diff --git a/Remote/External.hs b/Remote/External.hs
index 54db82d1f..04834c78f 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -59,7 +59,7 @@ gen r u c gc
Nothing
Nothing
| otherwise = do
- external <- newExternal externaltype u c
+ external <- newExternal externaltype u c gc
Annex.addCleanup (RemoteCleanup u) $ stopExternal external
cst <- getCost external r gc
avail <- getAvailability external r gc
@@ -108,8 +108,8 @@ gen r u c gc
rmt
externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
-externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-externalSetup mu _ c = do
+externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+externalSetup mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
let externaltype = fromMaybe (error "Specify externaltype=") $
M.lookup "externaltype" c
@@ -120,7 +120,7 @@ externalSetup mu _ c = do
setConfig (remoteConfig (fromJust (M.lookup "name" c)) "readonly") (boolConfig True)
return c'
_ -> do
- external <- newExternal externaltype u c'
+ external <- newExternal externaltype u c' gc
handleRequest external INITREMOTE Nothing $ \resp -> case resp of
INITREMOTE_SUCCESS -> Just noop
INITREMOTE_FAILURE errmsg -> Just $ error errmsg
@@ -246,8 +246,9 @@ handleRequest' lck external req mp responsehandler
void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
handleRemoteRequest (GETCREDS setting) = do
c <- liftIO $ atomically $ readTMVar $ externalConfig external
+ gc <- liftIO $ atomically $ readTMVar $ externalGitConfig external
creds <- fromMaybe ("", "") <$>
- getRemoteCredPair c (credstorage setting)
+ getRemoteCredPair c gc (credstorage setting)
send $ CREDS (fst creds) (snd creds)
handleRemoteRequest GETUUID = send $
VALUE $ fromUUID $ externalUUID external
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index 2ce498341..66a285535 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -54,15 +54,18 @@ data External = External
, externalLock :: TMVar ExternalLock
-- Never left empty.
, externalConfig :: TMVar RemoteConfig
+ -- Never left empty.
+ , externalGitConfig :: TMVar RemoteGitConfig
}
-newExternal :: ExternalType -> UUID -> RemoteConfig -> Annex External
-newExternal externaltype u c = liftIO $ External
+newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex External
+newExternal externaltype u c gc = liftIO $ External
<$> pure externaltype
<*> pure u
<*> atomically newEmptyTMVar
<*> atomically (newTMVar ExternalLock)
<*> atomically (newTMVar c)
+ <*> atomically (newTMVar gc)
type ExternalType = String
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 38b85d91b..c35f17920 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -169,8 +169,8 @@ noCrypto = error "cannot use gcrypt remote without encryption enabled"
unsupportedUrl :: a
unsupportedUrl = error "using non-ssh remote repo url with gcrypt is not supported"
-gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-gCryptSetup mu _ c = go $ M.lookup "gitrepo" c
+gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+gCryptSetup mu _ c _ = go $ M.lookup "gitrepo" c
where
remotename = fromJust (M.lookup "name" c)
go Nothing = error "Specify gitrepo="
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 627a6066b..0528f9f88 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -93,8 +93,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 -> Annex (RemoteConfig, UUID)
-gitSetup Nothing _ c = do
+gitSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+gitSetup Nothing _ c _ = do
let location = fromMaybe (error "Specify location=url") $
Url.parseURIRelaxed =<< M.lookup "location" c
g <- Annex.gitRepo
@@ -103,7 +103,7 @@ gitSetup Nothing _ c = do
[] -> error "could not find existing git remote with specified location"
_ -> error "found multiple git remotes with specified location"
return (c, u)
-gitSetup (Just u) _ c = do
+gitSetup (Just u) _ c _ = do
inRepo $ Git.Command.run
[ Param "remote"
, Param "add"
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 6ba36ccd2..800b16875 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -78,17 +78,17 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
{ chunkConfig = NoChunks
}
-glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-glacierSetup mu mcreds c = do
+glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+glacierSetup mu mcreds c gc = do
u <- maybe (liftIO genUUID) return mu
- glacierSetup' (isJust mu) u mcreds c
-glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-glacierSetup' enabling u mcreds c = do
+ glacierSetup' (isJust mu) u mcreds c gc
+glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+glacierSetup' enabling u mcreds c gc = do
(c', encsetup) <- encryptionSetup c
c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
let fullconfig = c'' `M.union` defaults
unless enabling $
- genVault fullconfig u
+ genVault fullconfig gc u
gitConfigSpecialRemote u fullconfig "glacier" "true"
return (fullconfig, u)
where
@@ -110,9 +110,10 @@ nonEmpty k
| otherwise = return True
store :: Remote -> Key -> L.ByteString -> MeterUpdate -> Annex Bool
-store r k b p = go =<< glacierEnv c u
+store r k b p = go =<< glacierEnv c gc u
where
c = config r
+ gc = gitconfig r
u = uuid r
params = glacierParams c
[ Param "archive"
@@ -133,9 +134,10 @@ prepareRetrieve :: Remote -> Preparer Retriever
prepareRetrieve = simplyPrepare . byteRetriever . retrieve
retrieve :: Remote -> Key -> (L.ByteString -> Annex Bool) -> Annex Bool
-retrieve r k sink = go =<< glacierEnv c u
+retrieve r k sink = go =<< glacierEnv c gc u
where
c = config r
+ gc = gitconfig r
u = uuid r
params = glacierParams c
[ Param "archive"
@@ -178,7 +180,7 @@ remove r k = glacierAction r
checkKey :: Remote -> CheckPresent
checkKey r k = do
showChecking r
- go =<< glacierEnv (config r) (uuid r)
+ go =<< glacierEnv (config r) (gitconfig r) (uuid r)
where
go Nothing = error "cannot check glacier"
go (Just e) = do
@@ -207,10 +209,10 @@ checkKey r k = do
]
glacierAction :: Remote -> [CommandParam] -> Annex Bool
-glacierAction r = runGlacier (config r) (uuid r)
+glacierAction r = runGlacier (config r) (gitconfig r) (uuid r)
-runGlacier :: RemoteConfig -> UUID -> [CommandParam] -> Annex Bool
-runGlacier c u params = go =<< glacierEnv c u
+runGlacier :: RemoteConfig -> RemoteGitConfig -> UUID -> [CommandParam] -> Annex Bool
+runGlacier c gc u params = go =<< glacierEnv c gc u
where
go Nothing = return False
go (Just e) = liftIO $
@@ -223,10 +225,10 @@ glacierParams c params = datacenter:params
fromMaybe (error "Missing datacenter configuration")
(M.lookup "datacenter" c)
-glacierEnv :: RemoteConfig -> UUID -> Annex (Maybe [(String, String)])
-glacierEnv c u = do
+glacierEnv :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe [(String, String)])
+glacierEnv c gc u = do
liftIO checkSaneGlacierCommand
- go =<< getRemoteCredPairFor "glacier" c creds
+ go =<< getRemoteCredPairFor "glacier" c gc creds
where
go Nothing = return Nothing
go (Just (user, pass)) = do
@@ -245,8 +247,8 @@ archive r k = fileprefix ++ key2file k
where
fileprefix = M.findWithDefault "" "fileprefix" $ config r
-genVault :: RemoteConfig -> UUID -> Annex ()
-genVault c u = unlessM (runGlacier c u params) $
+genVault :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
+genVault c gc u = unlessM (runGlacier c gc u params) $
error "Failed creating glacier vault."
where
params =
@@ -266,7 +268,7 @@ genVault c u = unlessM (runGlacier c u params) $
- not supported.
-}
jobList :: Remote -> [Key] -> Annex ([Key], [Key])
-jobList r keys = go =<< glacierEnv (config r) (uuid r)
+jobList r keys = go =<< glacierEnv (config r) (gitconfig r) (uuid r)
where
params = [ Param "job", Param "list" ]
nada = ([], [])
diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs
index cf0524dc4..48cf09867 100644
--- a/Remote/Helper/Special.hs
+++ b/Remote/Helper/Special.hs
@@ -178,8 +178,6 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
}
cip = cipherKey c
isencrypted = isJust (extractCipher c)
- gpgencopts = getGpgEncParams encr
- gpgdecopts = getGpgDecParams encr
safely a = catchNonAsync a (\e -> warning (show e) >> return False)
@@ -201,7 +199,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
storechunk (Just (cipher, enck)) storer k content p = do
cmd <- gpgCmd <$> Annex.getGitConfig
withBytes content $ \b ->
- encrypt cmd gpgencopts cipher (feedBytes b) $
+ encrypt cmd encr cipher (feedBytes b) $
readBytes $ \encb ->
storer (enck k) (ByteContent encb) p
@@ -211,7 +209,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
where
go (Just retriever) = displayprogress p k $ \p' ->
retrieveChunks retriever (uuid baser) chunkconfig
- enck k dest p' (sink dest enc gpgdecopts)
+ enck k dest p' (sink dest enc encr)
go Nothing = return False
enck = maybe id snd enc
@@ -244,26 +242,27 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
- into place. (And it may even already be in the right place..)
-}
sink
- :: FilePath
+ :: LensGpgEncParams c
+ => FilePath
-> Maybe (Cipher, EncKey)
- -> [CommandParam]
+ -> c
-> Maybe Handle
-> Maybe MeterUpdate
-> ContentSource
-> Annex Bool
-sink dest enc gpgdecopts mh mp content = do
+sink dest enc c mh mp content = do
case (enc, mh, content) of
(Nothing, Nothing, FileContent f)
| f == dest -> noop
| otherwise -> liftIO $ moveFile f dest
(Just (cipher, _), _, ByteContent b) -> do
cmd <- gpgCmd <$> Annex.getGitConfig
- decrypt cmd gpgdecopts cipher (feedBytes b) $
+ decrypt cmd c cipher (feedBytes b) $
readBytes write
(Just (cipher, _), _, FileContent f) -> do
cmd <- gpgCmd <$> Annex.getGitConfig
withBytes content $ \b ->
- decrypt cmd gpgdecopts cipher (feedBytes b) $
+ decrypt cmd c cipher (feedBytes b) $
readBytes write
liftIO $ nukeFile f
(Nothing, _, FileContent f) -> do
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index fb5afcadb..20f5e5164 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -70,8 +70,8 @@ gen r u c gc = do
where
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
-hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-hookSetup mu _ c = do
+hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+hookSetup mu _ c _ = do
u <- maybe (liftIO genUUID) return mu
let hooktype = fromMaybe (error "Specify hooktype=") $
M.lookup "hooktype" c
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index a0e30c7f7..28709bdab 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 -> Annex (RemoteConfig, UUID)
-rsyncSetup mu _ c = do
+rsyncSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+rsyncSetup mu _ c _ = do
u <- maybe (liftIO genUUID) return mu
-- verify configuration is sane
let url = fromMaybe (error "Specify rsyncurl=") $
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 1635d22bb..cf662c3d1 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -99,12 +99,14 @@ gen r u c gc = do
, checkUrl = Nothing
}
-s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-s3Setup mu mcreds c = do
+s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+s3Setup mu mcreds c gc = do
u <- maybe (liftIO genUUID) return mu
- s3Setup' (isNothing mu) u mcreds c
-s3Setup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost
+ s3Setup' (isNothing mu) u mcreds c gc
+s3Setup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
+s3Setup' new u mcreds c gc
+ | configIA c = archiveorg
+ | otherwise = defaulthost
where
remotename = fromJust (M.lookup "name" c)
defbucket = remotename ++ "-" ++ fromUUID u
@@ -125,7 +127,7 @@ s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost
c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
let fullconfig = c'' `M.union` defaults
when new $
- genBucket fullconfig u
+ genBucket fullconfig gc u
use fullconfig
archiveorg = do
@@ -146,7 +148,7 @@ s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost
-- special constraints on key names
M.insert "mungekeys" "ia" defaults
info <- extractS3Info archiveconfig
- withS3Handle archiveconfig u $
+ withS3Handle archiveconfig gc u $
writeUUIDFile archiveconfig u info
use archiveconfig
@@ -154,12 +156,12 @@ s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost
-- http connections to be reused across calls to the helper.
prepareS3Handle :: Remote -> (S3Handle -> helper) -> Preparer helper
prepareS3Handle r = resourcePrepare $ const $
- withS3Handle (config r) (uuid r)
+ withS3Handle (config r) (gitconfig r) (uuid r)
-- Allows for read-only actions, which can be run without a S3Handle.
prepareS3HandleMaybe :: Remote -> (Maybe S3Handle -> helper) -> Preparer helper
prepareS3HandleMaybe r = resourcePrepare $ const $
- withS3HandleMaybe (config r) (uuid r)
+ withS3HandleMaybe (config r) (gitconfig r) (uuid r)
store :: Remote -> S3Info -> S3Handle -> Storer
store _r info h = fileStorer $ \k f p -> do
@@ -311,11 +313,11 @@ checkKey r info Nothing k = case getpublicurl info of
- so first check if the UUID file already exists and we can skip doing
- anything.
-}
-genBucket :: RemoteConfig -> UUID -> Annex ()
-genBucket c u = do
+genBucket :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
+genBucket c gc u = do
showAction "checking bucket"
info <- extractS3Info c
- withS3Handle c u $ \h ->
+ withS3Handle c gc u $ \h ->
go info h =<< checkUUIDFile c u info h
where
go _ _ (Right True) = noop
@@ -408,16 +410,16 @@ sendS3Handle'
-> ResourceT IO a
sendS3Handle' h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r
-withS3Handle :: RemoteConfig -> UUID -> (S3Handle -> Annex a) -> Annex a
-withS3Handle c u a = withS3HandleMaybe c u $ \mh -> case mh of
+withS3Handle :: RemoteConfig -> RemoteGitConfig -> UUID -> (S3Handle -> Annex a) -> Annex a
+withS3Handle c gc u a = withS3HandleMaybe c gc u $ \mh -> case mh of
Just h -> a h
Nothing -> do
warnMissingCredPairFor "S3" (AWS.creds u)
error "No S3 credentials configured"
-withS3HandleMaybe :: RemoteConfig -> UUID -> (Maybe S3Handle -> Annex a) -> Annex a
-withS3HandleMaybe c u a = do
- mcreds <- getRemoteCredPair c (AWS.creds u)
+withS3HandleMaybe :: RemoteConfig -> RemoteGitConfig -> UUID -> (Maybe S3Handle -> Annex a) -> Annex a
+withS3HandleMaybe c gc u a = do
+ mcreds <- getRemoteCredPair c gc (AWS.creds u)
case mcreds of
Just creds -> do
awscreds <- liftIO $ genCredentials creds
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index aff1aaee0..05b120d46 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 -> Annex (RemoteConfig, UUID)
-tahoeSetup mu _ c = do
+tahoeSetup :: 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 a135be466..08b1a5496 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -81,14 +81,14 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
}
chunkconfig = getChunkConfig c
-webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
-webdavSetup mu mcreds c = do
+webdavSetup :: 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 -> error "Specify url="
Just url -> return url
(c', encsetup) <- encryptionSetup c
- creds <- maybe (getCreds c' u) (return . Just) mcreds
+ creds <- maybe (getCreds c' gc u) (return . Just) mcreds
testDav url creds
gitConfigSpecialRemote u c' "webdav" "true"
c'' <- setRemoteCredPair encsetup c' (davCreds u) creds
@@ -234,8 +234,8 @@ mkColRecursive d = go =<< existsDAV d
inLocation d mkCol
)
-getCreds :: RemoteConfig -> UUID -> Annex (Maybe CredPair)
-getCreds c u = getRemoteCredPairFor "webdav" c (davCreds u)
+getCreds :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair)
+getCreds c gc u = getRemoteCredPairFor "webdav" c gc (davCreds u)
davCreds :: UUID -> CredPairStorage
davCreds u = CredPairStorage
@@ -291,7 +291,7 @@ data DavHandle = DavHandle DAVContext DavUser DavPass URLString
withDAVHandle :: Remote -> (Maybe DavHandle -> Annex a) -> Annex a
withDAVHandle r a = do
- mcreds <- getCreds (config r) (uuid r)
+ mcreds <- getCreds (config r) (gitconfig r) (uuid r)
case (mcreds, configUrl r) of
(Just (user, pass), Just baseurl) ->
withDAVContext baseurl $ \ctx ->
diff --git a/Types/Remote.hs b/Types/Remote.hs
index a39324163..dd4c7d2e5 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -50,7 +50,7 @@ data RemoteTypeA a = RemoteType {
-- 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 -> a (RemoteConfig, UUID)
+ setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
}
instance Eq (RemoteTypeA a) where
diff --git a/debian/changelog b/debian/changelog
index 1c520cf5c..f5e8b0073 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -20,6 +20,8 @@ git-annex (6.20160512) UNRELEASED; urgency=medium
* Fix crash when entering/changing view in a subdirectory of a repo that
has a dotfile in its root.
* Support building with ghc 8.0.1.
+ * Pass the various gnupg-options configs to gpg in several cases where
+ they were not before.
-- Joey Hess <id@joeyh.name> Wed, 11 May 2016 16:08:38 -0400
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-10 17:14:00 +0000