git-annex/Creds.hs

203 lines
6.9 KiB
Haskell
Raw Normal View History

2012-11-14 23:32:27 +00:00
{- Credentials storage
-
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
2012-11-14 23:32:27 +00:00
-
- Licensed under the GNU AGPL version 3 or higher.
2012-11-14 23:32:27 +00:00
-}
module Creds (
module Types.Creds,
CredPairStorage(..),
setRemoteCredPair,
getRemoteCredPair,
getRemoteCredPairFor,
missingCredPairFor,
getEnvCredPair,
writeCreds,
readCreds,
credsFile,
removeCreds,
includeCredsInfo,
) where
2012-11-14 23:32:27 +00:00
import Annex.Common
import qualified Annex
import Types.Creds
2012-11-14 23:32:27 +00:00
import Annex.Perms
import Utility.FileMode
import Crypto
import Types.Remote (RemoteConfig, RemoteConfigField)
import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher)
import Utility.Env (getEnv)
2012-11-14 23:32:27 +00:00
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import Utility.Base64
{- A CredPair can be stored in a file, or in the environment, or
2012-11-14 23:32:27 +00:00
- in a remote's configuration. -}
data CredPairStorage = CredPairStorage
{ credPairFile :: FilePath
, credPairEnvironment :: (String, String)
, credPairRemoteField :: RemoteConfigField
2012-11-14 23:32:27 +00:00
}
{- Stores creds in a remote's configuration, if the remote allows
- that. Also caches them locally.
-
- The creds are found from the CredPairStorage storage if not provided,
- so may be provided by an environment variable etc.
glacier, S3: Fix bug that caused embedded creds to not be encypted using the remote's key. encryptionSetup must be called before setRemoteCredPair. Otherwise, the RemoteConfig doesn't have the cipher in it, and so no cipher is used to encrypt the embedded creds. This is a security fix for non-shared encryption methods! For encryption=shared, there's no security problem, just an inconsistentency in whether the embedded creds are encrypted. This is very important to get right, so used some types to help ensure that setRemoteCredPair is only run after encryptionSetup. Note that the external special remote bypasses the type safety, since creds can be set after the initial remote config, if the external special remote program requests it. Also note that IA remotes never use encryption, so encryptionSetup is not run for them at all, and again the type safety is bypassed. This leaves two open questions: 1. What to do about S3 and glacier remotes that were set up using encryption=pubkey/hybrid with embedcreds? Such a git repo has a security hole embedded in it, and this needs to be communicated to the user. Is the changelog enough? 2. enableremote won't work in such a repo, because git-annex will try to decrypt the embedded creds, which are not encrypted, so fails. This needs to be dealt with, especially for ecryption=shared repos, which are not really broken, just inconsistently configured. Noticing that problem for encryption=shared is what led to commit fbdeeeed5fa276d94be587c8916d725eddcaf546, which tried to fix the problem by not decrypting the embedded creds. This commit was sponsored by Josh Taylor.
2014-09-18 21:07:17 +00:00
-
- The remote's configuration should have already had a cipher stored in it
- if that's going to be done, so that the creds can be encrypted using the
2019-04-27 18:08:11 +00:00
- cipher. The EncryptionIsSetup is witness to that being the case.
glacier, S3: Fix bug that caused embedded creds to not be encypted using the remote's key. encryptionSetup must be called before setRemoteCredPair. Otherwise, the RemoteConfig doesn't have the cipher in it, and so no cipher is used to encrypt the embedded creds. This is a security fix for non-shared encryption methods! For encryption=shared, there's no security problem, just an inconsistentency in whether the embedded creds are encrypted. This is very important to get right, so used some types to help ensure that setRemoteCredPair is only run after encryptionSetup. Note that the external special remote bypasses the type safety, since creds can be set after the initial remote config, if the external special remote program requests it. Also note that IA remotes never use encryption, so encryptionSetup is not run for them at all, and again the type safety is bypassed. This leaves two open questions: 1. What to do about S3 and glacier remotes that were set up using encryption=pubkey/hybrid with embedcreds? Such a git repo has a security hole embedded in it, and this needs to be communicated to the user. Is the changelog enough? 2. enableremote won't work in such a repo, because git-annex will try to decrypt the embedded creds, which are not encrypted, so fails. This needs to be dealt with, especially for ecryption=shared repos, which are not really broken, just inconsistently configured. Noticing that problem for encryption=shared is what led to commit fbdeeeed5fa276d94be587c8916d725eddcaf546, which tried to fix the problem by not decrypting the embedded creds. This commit was sponsored by Josh Taylor.
2014-09-18 21:07:17 +00:00
-}
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 ->
let key = credPairRemoteField storage
in storeconfig creds key =<< flip remoteCipher gc =<< localcache creds
| otherwise -> localcache creds
where
localcache creds = do
writeCacheCredPair creds storage
return c
storeconfig creds key (Just cipher) = do
cmd <- gpgCmd <$> Annex.getGitConfig
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
2012-11-14 23:32:27 +00:00
{- Gets a remote's credpair, from the environment if set, otherwise
- from the cache in gitAnnexCredsDir, or failing that, from the
2012-11-14 23:32:27 +00:00
- value in RemoteConfig. -}
getRemoteCredPair :: RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)
getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv
2012-11-14 23:32:27 +00:00
where
fromenv = liftIO $ getEnvCredPair storage
fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage
fromconfig = do
let key = credPairRemoteField storage
mcipher <- remoteCipher' c gc
case (M.lookup key c, mcipher) of
(Nothing, _) -> return Nothing
(Just enccreds, Just (cipher, storablecipher)) ->
fromenccreds enccreds cipher storablecipher
(Just bcreds, Nothing) ->
fromcreds $ fromB64 bcreds
fromenccreds enccreds cipher storablecipher = do
cmd <- gpgCmd <$> Annex.getGitConfig
mcreds <- liftIO $ catchMaybeIO $ decrypt cmd (c, gc) cipher
(feedBytes $ L.pack $ fromB64 enccreds)
(readBytes $ return . L.unpack)
case mcreds of
Just creds -> fromcreds creds
Nothing -> do
-- Work around un-encrypted creds storage
-- bug in old S3 and glacier remotes.
-- Not a problem for shared cipher.
case storablecipher of
SharedCipher {} -> showLongNote "gpg error above was caused by an old git-annex bug in credentials storage. Working around it.."
_ -> giveup "*** Insecure credentials storage detected for this remote! See https://git-annex.branchable.com/upgrades/insecure_embedded_creds/"
fromcreds $ fromB64 enccreds
fromcreds creds = case decodeCredPair creds of
Just credpair -> do
writeCacheCredPair credpair storage
return $ Just credpair
2013-04-03 07:52:41 +00:00
_ -> error "bad creds"
2012-11-14 23:32:27 +00:00
getRemoteCredPairFor :: String -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)
getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage
where
go Nothing = do
warning $ missingCredPairFor this storage
return Nothing
go (Just credpair) = return $ Just credpair
missingCredPairFor :: String -> CredPairStorage -> String
missingCredPairFor this storage = unwords
[ "Set both", loginvar
, "and", passwordvar
, "to use", this
]
where
(loginvar, passwordvar) = credPairEnvironment storage
2012-11-14 23:32:27 +00:00
{- Gets a CredPair from the environment. -}
getEnvCredPair :: CredPairStorage -> IO (Maybe CredPair)
getEnvCredPair storage = liftM2 (,)
2013-09-22 18:13:31 +00:00
<$> getEnv uenv
<*> getEnv penv
2012-11-14 23:32:27 +00:00
where
(uenv, penv) = credPairEnvironment storage
{- Writes a cred pair to local cache, unless prevented by configuration. -}
2012-11-14 23:32:27 +00:00
writeCacheCredPair :: CredPair -> CredPairStorage -> Annex ()
writeCacheCredPair credpair storage =
whenM (annexCacheCreds <$> Annex.getGitConfig) $
writeCreds (encodeCredPair credpair) (credPairFile storage)
readCacheCredPair :: CredPairStorage -> Annex (Maybe CredPair)
readCacheCredPair storage = maybe Nothing decodeCredPair
<$> readCreds (credPairFile storage)
existsCacheCredPair :: CredPairStorage -> Annex Bool
existsCacheCredPair storage =
liftIO . doesFileExist =<< credsFile (credPairFile storage)
2012-11-14 23:32:27 +00:00
{- Stores the creds in a file inside gitAnnexCredsDir that only the user
- can read. -}
writeCreds :: Creds -> FilePath -> Annex ()
writeCreds creds file = do
2012-11-14 23:32:27 +00:00
d <- fromRepo gitAnnexCredsDir
createAnnexDirectory d
2013-05-09 17:57:31 +00:00
liftIO $ writeFileProtected (d </> file) creds
2012-11-14 23:32:27 +00:00
readCreds :: FilePath -> Annex (Maybe Creds)
readCreds f = liftIO . catchMaybeIO . readFileStrict =<< credsFile f
credsFile :: FilePath -> Annex FilePath
credsFile basefile = do
2012-11-14 23:32:27 +00:00
d <- fromRepo gitAnnexCredsDir
return $ d </> basefile
2012-11-14 23:32:27 +00:00
encodeCredPair :: CredPair -> Creds
encodeCredPair (l, p) = unlines [l, p]
decodeCredPair :: Creds -> Maybe CredPair
decodeCredPair creds = case lines creds of
l:p:[] -> Just (l, p)
_ -> Nothing
removeCreds :: FilePath -> Annex ()
removeCreds file = do
d <- fromRepo gitAnnexCredsDir
let f = d </> file
liftIO $ nukeFile f
includeCredsInfo :: RemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)]
includeCredsInfo c storage info = do
v <- liftIO $ getEnvCredPair storage
case v of
Just _ -> do
let (uenv, penv) = credPairEnvironment storage
ret $ "from environment variables (" ++ unwords [uenv, penv] ++ ")"
Nothing -> case (`M.lookup` c) (credPairRemoteField storage) of
Nothing -> ifM (existsCacheCredPair storage)
( ret "stored locally"
, ret "not available"
)
Just _ -> case extractCipher c of
2015-04-11 04:10:34 +00:00
Just (EncryptedCipher {}) -> ret "embedded in git repository (gpg encrypted)"
_ -> ret "embedded in git repository (not encrypted)"
where
ret s = return $ ("creds", s) : info