refactor
Wow, triple monadic lift!
This commit is contained in:
parent
0ad5d8168f
commit
b9b72d22a9
1 changed files with 20 additions and 17 deletions
37
Remote/S3.hs
37
Remote/S3.hs
|
@ -272,26 +272,29 @@ s3Connection c = do
|
||||||
{- S3 creds come from the environment if set.
|
{- S3 creds come from the environment if set.
|
||||||
- Otherwise, might be stored encrypted in the remote's config. -}
|
- Otherwise, might be stored encrypted in the remote's config. -}
|
||||||
s3GetCreds :: RemoteConfig -> Annex (Maybe (String, String))
|
s3GetCreds :: RemoteConfig -> Annex (Maybe (String, String))
|
||||||
s3GetCreds c = do
|
s3GetCreds c = maybe fromconfig (return . Just) =<< liftIO getenv
|
||||||
ak <- getEnvKey s3AccessKey
|
where
|
||||||
sk <- getEnvKey s3SecretKey
|
getenv = liftM2 (,)
|
||||||
if null ak || null sk
|
<$> get s3AccessKey
|
||||||
then do
|
<*> get s3SecretKey
|
||||||
mcipher <- remoteCipher c
|
where
|
||||||
case (M.lookup "s3creds" c, mcipher) of
|
get = catchMaybeIO . getEnv
|
||||||
(Just encrypted, Just cipher) -> do
|
setenv (ak, sk) = do
|
||||||
s <- liftIO $ withDecryptedContent cipher
|
|
||||||
(return $ L.pack $ fromB64 encrypted)
|
|
||||||
(return . L.unpack)
|
|
||||||
let [ak', sk', _rest] = lines s
|
|
||||||
liftIO $ do
|
|
||||||
setEnv s3AccessKey ak True
|
setEnv s3AccessKey ak True
|
||||||
setEnv s3SecretKey sk True
|
setEnv s3SecretKey sk True
|
||||||
return $ Just (ak', sk')
|
fromconfig = do
|
||||||
|
mcipher <- remoteCipher c
|
||||||
|
case (M.lookup "s3creds" c, mcipher) of
|
||||||
|
(Just s3creds, Just cipher) ->
|
||||||
|
liftIO $ decrypt s3creds cipher
|
||||||
_ -> return Nothing
|
_ -> return Nothing
|
||||||
else return $ Just (ak, sk)
|
decrypt s3creds cipher = do
|
||||||
where
|
[ak, sk, _rest] <- lines <$>
|
||||||
getEnvKey s = liftIO $ catchDefaultIO (getEnv s) ""
|
withDecryptedContent cipher
|
||||||
|
(return $ L.pack $ fromB64 s3creds)
|
||||||
|
(return . L.unpack)
|
||||||
|
setenv (ak, sk)
|
||||||
|
return $ Just (ak, sk)
|
||||||
|
|
||||||
{- Stores S3 creds encrypted in the remote's config if possible. -}
|
{- Stores S3 creds encrypted in the remote's config if possible. -}
|
||||||
s3SetCreds :: RemoteConfig -> Annex RemoteConfig
|
s3SetCreds :: RemoteConfig -> Annex RemoteConfig
|
||||||
|
|
Loading…
Add table
Reference in a new issue