322 lines
12 KiB
Haskell
322 lines
12 KiB
Haskell
{- common functions for encryptable remotes
|
|
-
|
|
- Copyright 2011-2021 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, PackageImports #-}
|
|
|
|
module Remote.Helper.Encryptable (
|
|
EncryptionIsSetup,
|
|
encryptionSetup,
|
|
noEncryptionUsed,
|
|
encryptionAlreadySetup,
|
|
encryptionConfigParsers,
|
|
parseEncryptionConfig,
|
|
remoteCipher,
|
|
remoteCipher',
|
|
embedCreds,
|
|
cipherKey,
|
|
extractCipher,
|
|
isEncrypted,
|
|
encryptionIsEnabled,
|
|
describeEncryption,
|
|
encryptionField,
|
|
highRandomQualityField
|
|
) where
|
|
|
|
import qualified Data.Map as M
|
|
import qualified Data.Set as S
|
|
import Control.Concurrent.STM
|
|
|
|
import Annex.Common
|
|
import Types.Remote
|
|
import Crypto
|
|
import Types.Crypto
|
|
import Types.ProposedAccepted
|
|
import qualified Annex
|
|
import Annex.SpecialRemote.Config
|
|
import Utility.Base64
|
|
|
|
-- Used to ensure that encryption has been set up before trying to
|
|
-- eg, store creds in the remote config that would need to use the
|
|
-- encryption setup.
|
|
data EncryptionIsSetup = EncryptionIsSetup | NoEncryption
|
|
|
|
-- Remotes that don't use encryption can use this instead of
|
|
-- encryptionSetup.
|
|
noEncryptionUsed :: EncryptionIsSetup
|
|
noEncryptionUsed = NoEncryption
|
|
|
|
-- Using this avoids the type-safe check, so you'd better be sure
|
|
-- of what you're doing.
|
|
encryptionAlreadySetup :: EncryptionIsSetup
|
|
encryptionAlreadySetup = EncryptionIsSetup
|
|
|
|
encryptionConfigParsers :: [RemoteConfigFieldParser]
|
|
encryptionConfigParsers =
|
|
[ encryptionFieldParser
|
|
, optionalStringParser cipherField HiddenField
|
|
, optionalStringParser cipherkeysField HiddenField
|
|
, optionalStringParser pubkeysField HiddenField
|
|
, yesNoParser embedCredsField Nothing
|
|
(FieldDesc "embed credentials into git repository")
|
|
, macFieldParser
|
|
, optionalStringParser (Accepted "keyid")
|
|
(FieldDesc "gpg key id")
|
|
, optionalStringParser (Accepted "keyid+")
|
|
(FieldDesc "add additional gpg key")
|
|
, optionalStringParser (Accepted "keyid-")
|
|
(FieldDesc "remove gpg key")
|
|
, highRandomQualityFieldParser
|
|
]
|
|
|
|
encryptionConfigs :: S.Set RemoteConfigField
|
|
encryptionConfigs = S.fromList (map parserForField encryptionConfigParsers)
|
|
|
|
-- Parse only encryption fields, ignoring all others.
|
|
parseEncryptionConfig :: RemoteConfig -> Either String ParsedRemoteConfig
|
|
parseEncryptionConfig c = parseRemoteConfig
|
|
(M.restrictKeys c encryptionConfigs)
|
|
(RemoteConfigParser encryptionConfigParsers Nothing)
|
|
|
|
encryptionFieldParser :: RemoteConfigFieldParser
|
|
encryptionFieldParser = RemoteConfigFieldParser
|
|
{ parserForField = encryptionField
|
|
, valueParser = \v c -> Just . RemoteConfigValue
|
|
<$> parseEncryptionMethod (fmap fromProposedAccepted v) c
|
|
, fieldDesc = FieldDesc "how to encrypt data stored in the special remote"
|
|
, valueDesc = Just $ ValueDesc $
|
|
intercalate " or " (M.keys encryptionMethods)
|
|
}
|
|
|
|
encryptionMethods :: M.Map String EncryptionMethod
|
|
encryptionMethods = M.fromList
|
|
[ ("none", NoneEncryption)
|
|
, ("shared", SharedEncryption)
|
|
, ("hybrid", HybridEncryption)
|
|
, ("pubkey", PubKeyEncryption)
|
|
, ("sharedpubkey", SharedPubKeyEncryption)
|
|
]
|
|
|
|
parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod
|
|
parseEncryptionMethod (Just s) _ = case M.lookup s encryptionMethods of
|
|
Just em -> Right em
|
|
Nothing -> Left badEncryptionMethod
|
|
-- Hybrid encryption is the default when a keyid is specified without
|
|
-- an encryption field, or when there's a cipher already but no encryption
|
|
-- field.
|
|
parseEncryptionMethod Nothing c
|
|
| M.member (Accepted "keyid") c || M.member cipherField c = Right HybridEncryption
|
|
| otherwise = Left badEncryptionMethod
|
|
|
|
badEncryptionMethod :: String
|
|
badEncryptionMethod = "Specify " ++ intercalate " or "
|
|
(map ((fromProposedAccepted encryptionField ++ "=") ++)
|
|
(M.keys encryptionMethods))
|
|
++ "."
|
|
|
|
highRandomQualityField :: RemoteConfigField
|
|
highRandomQualityField = Accepted "highRandomQuality"
|
|
|
|
highRandomQualityFieldParser :: RemoteConfigFieldParser
|
|
highRandomQualityFieldParser = RemoteConfigFieldParser
|
|
{ parserForField = highRandomQualityField
|
|
, valueParser = \v _c -> Just . RemoteConfigValue
|
|
<$> parseHighRandomQuality (fmap fromProposedAccepted v)
|
|
, fieldDesc = HiddenField
|
|
, valueDesc = Nothing
|
|
}
|
|
|
|
parseHighRandomQuality :: Maybe String -> Either String Bool
|
|
parseHighRandomQuality Nothing = Right True
|
|
parseHighRandomQuality (Just "false") = Right False
|
|
parseHighRandomQuality (Just "true") = Right True
|
|
parseHighRandomQuality _ = Left "expected highRandomQuality=true/false"
|
|
|
|
macFieldParser :: RemoteConfigFieldParser
|
|
macFieldParser = RemoteConfigFieldParser
|
|
{ parserForField = macField
|
|
, valueParser = \v _c -> Just . RemoteConfigValue <$> parseMac v
|
|
, fieldDesc = FieldDesc "how to encrypt filenames used on the remote"
|
|
, valueDesc = Just $ ValueDesc $
|
|
intercalate " or " (M.keys macMap)
|
|
}
|
|
|
|
parseMac :: Maybe (ProposedAccepted String) -> Either String Mac
|
|
parseMac Nothing = Right defaultMac
|
|
parseMac (Just (Accepted s)) = Right $ fromMaybe defaultMac (readMac s)
|
|
parseMac (Just (Proposed s)) = case readMac s of
|
|
Just mac -> Right mac
|
|
Nothing -> Left "bad mac value"
|
|
|
|
{- Encryption setup for a remote. The user must specify whether to use
|
|
- an encryption key, or not encrypt. An encrypted cipher is created, or is
|
|
- updated to be accessible to an additional encryption key. Or the user
|
|
- could opt to use a shared cipher, which is stored unencrypted. -}
|
|
encryptionSetup :: RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, EncryptionIsSetup)
|
|
encryptionSetup c gc = do
|
|
pc <- either giveup return $ parseEncryptionConfig c
|
|
gpgcmd <- gpgCmd <$> Annex.getGitConfig
|
|
maybe (genCipher pc gpgcmd) (updateCipher pc gpgcmd) (extractCipher pc)
|
|
where
|
|
-- The type of encryption
|
|
encryption = parseEncryptionMethod (fromProposedAccepted <$> M.lookup encryptionField c) c
|
|
-- Generate a new cipher, depending on the chosen encryption scheme
|
|
genCipher pc gpgcmd = case encryption of
|
|
Right NoneEncryption -> return (c, NoEncryption)
|
|
Right SharedEncryption -> encsetup $ genSharedCipher gpgcmd
|
|
Right HybridEncryption -> encsetup $ genEncryptedCipher gpgcmd (pc, gc) key Hybrid
|
|
Right PubKeyEncryption -> encsetup $ genEncryptedCipher gpgcmd (pc, gc) key PubKey
|
|
Right SharedPubKeyEncryption -> encsetup $ genSharedPubKeyCipher gpgcmd key
|
|
Left err -> giveup err
|
|
key = maybe (giveup "Specify keyid=...") fromProposedAccepted $
|
|
M.lookup (Accepted "keyid") c
|
|
newkeys = maybe [] (\k -> [(True,fromProposedAccepted k)]) (M.lookup (Accepted "keyid+") c) ++
|
|
maybe [] (\k -> [(False,fromProposedAccepted k)]) (M.lookup (Accepted "keyid-") c)
|
|
cannotchange = giveup "Cannot set encryption type of existing remotes."
|
|
-- Update an existing cipher if possible.
|
|
updateCipher pc gpgcmd v = case v of
|
|
SharedCipher _ | encryption == Right SharedEncryption ->
|
|
return (c', EncryptionIsSetup)
|
|
EncryptedCipher _ variant _ | sameasencryption variant ->
|
|
use "encryption update" $ updateCipherKeyIds gpgcmd (pc, gc) newkeys v
|
|
SharedPubKeyCipher _ _ ->
|
|
use "encryption update" $ updateCipherKeyIds gpgcmd (pc, gc) newkeys v
|
|
_ -> cannotchange
|
|
sameasencryption variant = case encryption of
|
|
Right HybridEncryption -> variant == Hybrid
|
|
Right PubKeyEncryption -> variant == PubKey
|
|
Right _ -> False
|
|
Left _ -> True
|
|
encsetup a = use "encryption setup" . a =<< highRandomQuality
|
|
use m a = do
|
|
showNote (UnquotedString m)
|
|
cipher <- liftIO a
|
|
showNote (UnquotedString (describeCipher cipher))
|
|
return (storeCipher cipher c', EncryptionIsSetup)
|
|
highRandomQuality = ifM (Annex.getRead Annex.fast)
|
|
( return False
|
|
, case parseHighRandomQuality (fromProposedAccepted <$> M.lookup highRandomQualityField c) of
|
|
Left err -> giveup err
|
|
Right v -> return v
|
|
)
|
|
c' = foldr M.delete c
|
|
-- Remove configs that are only used in here to generate
|
|
-- the encryption keys, and should not be stored in
|
|
-- remote.log.
|
|
-- Older versions used to remove 'encryption' as well, since
|
|
-- it was redundant; we now need to keep it for
|
|
-- public-key encryption, hence we leave it on newer
|
|
-- remotes (while being backward-compatible).
|
|
(map Accepted ["keyid", "keyid+", "keyid-", "highRandomQuality"])
|
|
|
|
remoteCipher :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe Cipher)
|
|
remoteCipher c gc = fmap fst <$> remoteCipher' c gc
|
|
|
|
{- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex
|
|
- state. -}
|
|
remoteCipher' :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, StorableCipher))
|
|
remoteCipher' c gc = case extractCipher c of
|
|
Nothing -> return Nothing
|
|
Just encipher -> do
|
|
cachev <- Annex.getRead Annex.ciphers
|
|
cachedciper <- liftIO $ atomically $
|
|
M.lookup encipher <$> readTMVar cachev
|
|
case cachedciper of
|
|
Just cipher -> return $ Just (cipher, encipher)
|
|
-- Not cached; decrypt it, making sure
|
|
-- to only decrypt one at a time. Avoids
|
|
-- prompting for decrypting the same thing twice
|
|
-- when this is run concurrently.
|
|
Nothing -> bracketOnError
|
|
(liftIO $ atomically $ takeTMVar cachev)
|
|
(liftIO . atomically . putTMVar cachev)
|
|
(go cachev encipher)
|
|
where
|
|
go cachev encipher cache = do
|
|
gpgcmd <- gpgCmd <$> Annex.getGitConfig
|
|
cipher <- liftIO $ decryptCipher gpgcmd (c, gc) encipher
|
|
liftIO $ atomically $ putTMVar cachev $
|
|
M.insert encipher cipher cache
|
|
return $ Just (cipher, encipher)
|
|
|
|
{- Checks if the remote's config allows storing creds in the remote's config.
|
|
-
|
|
- embedcreds=yes allows this, and embedcreds=no prevents it.
|
|
-
|
|
- If not set, the default is to only store creds when it's surely safe:
|
|
- When gpg encryption is used and the creds are encrypted using it.
|
|
- Not when a shared cipher is used.
|
|
-}
|
|
embedCreds :: ParsedRemoteConfig -> Bool
|
|
embedCreds c = case getRemoteConfigValue embedCredsField c of
|
|
Just v -> v
|
|
Nothing -> case (getRemoteConfigValue cipherkeysField c, getRemoteConfigValue cipherField c) of
|
|
(Just (_ :: String), Just (_ :: String)) -> True
|
|
_ -> False
|
|
|
|
{- Gets encryption Cipher, and key encryptor. -}
|
|
cipherKey :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey))
|
|
cipherKey c gc = fmap make <$> remoteCipher c gc
|
|
where
|
|
make ciphertext = (ciphertext, encryptKey mac ciphertext)
|
|
mac = fromMaybe defaultMac $ getRemoteConfigValue macField c
|
|
|
|
{- Stores an StorableCipher in a remote's configuration. -}
|
|
storeCipher :: StorableCipher -> RemoteConfig -> RemoteConfig
|
|
storeCipher cip = case cip of
|
|
(SharedCipher t) -> addcipher t
|
|
(EncryptedCipher t _ ks) -> addcipher t . storekeys ks cipherkeysField
|
|
(SharedPubKeyCipher t ks) -> addcipher t . storekeys ks pubkeysField
|
|
where
|
|
addcipher t = M.insert cipherField (Accepted (decodeBS (toB64 t)))
|
|
storekeys (KeyIds l) n = M.insert n (Accepted (intercalate "," l))
|
|
|
|
{- Extracts an StorableCipher from a remote's configuration. -}
|
|
extractCipher :: ParsedRemoteConfig -> Maybe StorableCipher
|
|
extractCipher c = case (getRemoteConfigValue cipherField c,
|
|
(getRemoteConfigValue cipherkeysField c <|> getRemoteConfigValue pubkeysField c),
|
|
getRemoteConfigValue encryptionField c) of
|
|
(Just t, Just ks, Just HybridEncryption) ->
|
|
Just $ EncryptedCipher (fromB64 (encodeBS t)) Hybrid (readkeys ks)
|
|
(Just t, Just ks, Just PubKeyEncryption) ->
|
|
Just $ EncryptedCipher (fromB64 (encodeBS t)) PubKey (readkeys ks)
|
|
(Just t, Just ks, Just SharedPubKeyEncryption) ->
|
|
Just $ SharedPubKeyCipher (fromB64 (encodeBS t)) (readkeys ks)
|
|
(Just t, Nothing, Just SharedEncryption) ->
|
|
Just $ SharedCipher (fromB64 (encodeBS t))
|
|
_ -> Nothing
|
|
where
|
|
readkeys = KeyIds . splitc ','
|
|
|
|
isEncrypted :: ParsedRemoteConfig -> Bool
|
|
isEncrypted = isJust . extractCipher
|
|
|
|
-- Check if encryption is enabled. This can be done before encryption
|
|
-- is fully set up yet, so the cipher might not be present yet.
|
|
encryptionIsEnabled :: ParsedRemoteConfig -> Bool
|
|
encryptionIsEnabled c = case getRemoteConfigValue encryptionField c of
|
|
Nothing -> False
|
|
Just NoneEncryption -> False
|
|
Just _ -> True
|
|
|
|
describeEncryption :: ParsedRemoteConfig -> String
|
|
describeEncryption c = case extractCipher c of
|
|
Nothing -> "none"
|
|
Just cip -> nameCipher cip ++ " (" ++ describeCipher cip ++ ")"
|
|
|
|
nameCipher :: StorableCipher -> String
|
|
nameCipher (SharedCipher _) = "shared"
|
|
nameCipher (EncryptedCipher _ PubKey _) = "pubkey"
|
|
nameCipher (EncryptedCipher _ Hybrid _) = "hybrid"
|
|
nameCipher (SharedPubKeyCipher _ _) = "sharedpubkey"
|
|
|
|
describeCipher :: StorableCipher -> String
|
|
describeCipher c = case c of
|
|
(SharedCipher _) -> "encryption key stored in git repository"
|
|
(EncryptedCipher _ _ ks) -> showkeys ks
|
|
(SharedPubKeyCipher _ ks) -> showkeys ks
|
|
where
|
|
showkeys (KeyIds { keyIds = ks }) = "to gpg keys: " ++ unwords ks
|