plumb RemoteGitConfig through to setRemoteCredPair
This commit is contained in:
parent
91df4c6b53
commit
22c174158c
5 changed files with 11 additions and 14 deletions
14
Creds.hs
14
Creds.hs
|
@ -51,10 +51,10 @@ data CredPairStorage = CredPairStorage
|
|||
- if that's going to be done, so that the creds can be encrypted using the
|
||||
- cipher. The EncryptionIsSetup phantom type ensures that is the case.
|
||||
-}
|
||||
setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
|
||||
setRemoteCredPair encsetup c storage mcreds = case mcreds of
|
||||
Nothing -> maybe (return c) (setRemoteCredPair encsetup c storage . Just)
|
||||
=<< getRemoteCredPair c nogitconfig storage
|
||||
setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
|
||||
setRemoteCredPair encsetup c gc storage mcreds = case mcreds of
|
||||
Nothing -> maybe (return c) (setRemoteCredPair encsetup c gc storage . Just)
|
||||
=<< getRemoteCredPair c gc storage
|
||||
Just creds
|
||||
| embedCreds c -> case credPairRemoteKey storage of
|
||||
Nothing -> localcache creds
|
||||
|
@ -67,16 +67,12 @@ setRemoteCredPair encsetup c storage mcreds = case mcreds of
|
|||
|
||||
storeconfig creds key (Just cipher) = do
|
||||
cmd <- gpgCmd <$> Annex.getGitConfig
|
||||
s <- liftIO $ encrypt cmd (c, nogitconfig) cipher
|
||||
s <- liftIO $ encrypt cmd (c, gc) cipher
|
||||
(feedBytes $ L.pack $ encodeCredPair creds)
|
||||
(readBytes $ return . L.unpack)
|
||||
return $ M.insert key (toB64 s) c
|
||||
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
|
||||
|
|
|
@ -241,7 +241,8 @@ handleRequest' lck external req mp responsehandler
|
|||
send $ VALUE value
|
||||
handleRemoteRequest (SETCREDS setting login password) = do
|
||||
c <- liftIO $ atomically $ readTMVar $ externalConfig external
|
||||
c' <- setRemoteCredPair encryptionAlreadySetup c (credstorage setting) $
|
||||
gc <- liftIO $ atomically $ readTMVar $ externalGitConfig external
|
||||
c' <- setRemoteCredPair encryptionAlreadySetup c gc (credstorage setting) $
|
||||
Just (login, password)
|
||||
void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
|
||||
handleRemoteRequest (GETCREDS setting) = do
|
||||
|
|
|
@ -85,7 +85,7 @@ glacierSetup mu mcreds c gc = do
|
|||
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
|
||||
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
|
||||
let fullconfig = c'' `M.union` defaults
|
||||
unless enabling $
|
||||
genVault fullconfig gc u
|
||||
|
|
|
@ -124,7 +124,7 @@ s3Setup' new u mcreds c gc
|
|||
|
||||
defaulthost = do
|
||||
(c', encsetup) <- encryptionSetup c
|
||||
c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
|
||||
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
|
||||
let fullconfig = c'' `M.union` defaults
|
||||
when new $
|
||||
genBucket fullconfig gc u
|
||||
|
@ -132,7 +132,7 @@ s3Setup' new u mcreds c gc
|
|||
|
||||
archiveorg = do
|
||||
showNote "Internet Archive mode"
|
||||
c' <- setRemoteCredPair noEncryptionUsed c (AWS.creds u) mcreds
|
||||
c' <- setRemoteCredPair noEncryptionUsed c gc (AWS.creds u) mcreds
|
||||
-- Ensure user enters a valid bucket name, since
|
||||
-- this determines the name of the archive.org item.
|
||||
let validbucket = replace " " "-" $
|
||||
|
|
|
@ -91,7 +91,7 @@ webdavSetup mu mcreds c gc = do
|
|||
creds <- maybe (getCreds c' gc u) (return . Just) mcreds
|
||||
testDav url creds
|
||||
gitConfigSpecialRemote u c' "webdav" "true"
|
||||
c'' <- setRemoteCredPair encsetup c' (davCreds u) creds
|
||||
c'' <- setRemoteCredPair encsetup c' gc (davCreds u) creds
|
||||
return (c'', u)
|
||||
|
||||
-- Opens a http connection to the DAV server, which will be reused
|
||||
|
|
Loading…
Reference in a new issue