Pass the various gnupg-options configs to gpg in several cases where they were not before.

Removed the instance LensGpgEncParams RemoteConfig because it encouraged
code that does not take the RemoteGitConfig into account.

RemoteType's setup was changed to take a RemoteGitConfig,
although the only place that is able to provide a non-empty one is
enableremote, when it's changing an existing remote. This led to several
folow-on changes, and got RemoteGitConfig plumbed through.
This commit is contained in:
Joey Hess 2016-05-23 17:03:20 -04:00
parent 16efe45a35
commit 91df4c6b53
Failed to extract signature
24 changed files with 140 additions and 126 deletions

View file

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

View file

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

View file

@ -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=") $

View file

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

View file

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

View file

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

View file

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

View file

@ -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 = ([], [])

View file

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

View file

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

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 -> 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=") $

View file

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

View file

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

View file

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