diff options
author | Joey Hess <joeyh@joeyh.name> | 2016-05-23 17:03:20 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2016-05-23 17:03:20 -0400 |
commit | d5f672ddd59b43cb9b1bac8f836864165c8931f2 (patch) | |
tree | 6a020605b69d22252d2b9d619115326848a779c1 /Remote/Glacier.hs | |
parent | 7e637c86630b65621d301afb174cd95efe567130 (diff) |
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.
Diffstat (limited to 'Remote/Glacier.hs')
-rw-r--r-- | Remote/Glacier.hs | 38 |
1 files changed, 20 insertions, 18 deletions
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 = ([], []) |