209 lines
7.9 KiB
Haskell
209 lines
7.9 KiB
Haskell
{- common functions for encryptable remotes
|
|
-
|
|
- Copyright 2011 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Remote.Helper.Encryptable (
|
|
EncryptionIsSetup,
|
|
encryptionSetup,
|
|
noEncryptionUsed,
|
|
encryptionAlreadySetup,
|
|
remoteCipher,
|
|
remoteCipher',
|
|
embedCreds,
|
|
cipherKey,
|
|
extractCipher,
|
|
isEncrypted,
|
|
describeEncryption,
|
|
) where
|
|
|
|
import qualified Data.Map as M
|
|
import qualified "sandi" Codec.Binary.Base64 as B64
|
|
import qualified Data.ByteString as B
|
|
|
|
import Annex.Common
|
|
import Types.Remote
|
|
import Config
|
|
import Crypto
|
|
import Types.Crypto
|
|
import qualified Annex
|
|
import Annex.SpecialRemote.Config
|
|
|
|
-- 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
|
|
|
|
{- 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
|
|
cmd <- gpgCmd <$> Annex.getGitConfig
|
|
maybe (genCipher cmd) (updateCipher cmd) (extractCipher c)
|
|
where
|
|
-- The type of encryption
|
|
encryption = M.lookup encryptionField c
|
|
-- Generate a new cipher, depending on the chosen encryption scheme
|
|
genCipher cmd = case encryption of
|
|
_ | hasEncryptionConfig c -> cannotchange
|
|
Just "none" -> return (c, NoEncryption)
|
|
Just "shared" -> encsetup $ genSharedCipher cmd
|
|
-- hybrid encryption is the default when a keyid is
|
|
-- specified but no encryption
|
|
_ | maybe (M.member "keyid" c) (== "hybrid") encryption ->
|
|
encsetup $ genEncryptedCipher cmd (c, gc) key Hybrid
|
|
Just "pubkey" -> encsetup $ genEncryptedCipher cmd (c, gc) key PubKey
|
|
Just "sharedpubkey" -> encsetup $ genSharedPubKeyCipher cmd key
|
|
_ -> giveup $ "Specify " ++ intercalate " or "
|
|
(map ((encryptionField ++ "=") ++)
|
|
["none","shared","hybrid","pubkey", "sharedpubkey"])
|
|
++ "."
|
|
key = fromMaybe (giveup "Specify keyid=...") $ M.lookup "keyid" c
|
|
newkeys = maybe [] (\k -> [(True,k)]) (M.lookup "keyid+" c) ++
|
|
maybe [] (\k -> [(False,k)]) (M.lookup "keyid-" c)
|
|
cannotchange = giveup "Cannot set encryption type of existing remotes."
|
|
-- Update an existing cipher if possible.
|
|
updateCipher cmd v = case v of
|
|
SharedCipher _ | maybe True (== "shared") encryption -> return (c', EncryptionIsSetup)
|
|
EncryptedCipher _ variant _
|
|
| maybe True (== if variant == Hybrid then "hybrid" else "pubkey") encryption -> do
|
|
use "encryption update" $ updateCipherKeyIds cmd (c, gc) newkeys v
|
|
SharedPubKeyCipher _ _ ->
|
|
use "encryption update" $ updateCipherKeyIds cmd (c, gc) newkeys v
|
|
_ -> cannotchange
|
|
encsetup a = use "encryption setup" . a =<< highRandomQuality
|
|
use m a = do
|
|
showNote m
|
|
cipher <- liftIO a
|
|
showNote (describeCipher cipher)
|
|
return (storeCipher cipher c', EncryptionIsSetup)
|
|
highRandomQuality =
|
|
(&&) (maybe True ( /= "false") $ M.lookup "highRandomQuality" c)
|
|
<$> fmap not (Annex.getState Annex.fast)
|
|
c' = foldr M.delete c
|
|
-- git-annex 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).
|
|
[ "keyid", "keyid+", "keyid-", "highRandomQuality" ]
|
|
|
|
remoteCipher :: RemoteConfig -> 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' :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, StorableCipher))
|
|
remoteCipher' c gc = go $ extractCipher c
|
|
where
|
|
go Nothing = return Nothing
|
|
go (Just encipher) = do
|
|
cache <- Annex.getState Annex.ciphers
|
|
case M.lookup encipher cache of
|
|
Just cipher -> return $ Just (cipher, encipher)
|
|
Nothing -> do
|
|
cmd <- gpgCmd <$> Annex.getGitConfig
|
|
cipher <- liftIO $ decryptCipher cmd (c, gc) encipher
|
|
Annex.changeState (\s -> s { Annex.ciphers = 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 :: RemoteConfig -> Bool
|
|
embedCreds c = case yesNo =<< M.lookup "embedcreds" c of
|
|
Just v -> v
|
|
Nothing -> isJust (M.lookup cipherkeysField c) && isJust (M.lookup cipherField c)
|
|
|
|
{- Gets encryption Cipher, and key encryptor. -}
|
|
cipherKey :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey))
|
|
cipherKey c gc = fmap make <$> remoteCipher c gc
|
|
where
|
|
make ciphertext = (ciphertext, encryptKey mac ciphertext)
|
|
mac = fromMaybe defaultMac $ M.lookup macField c >>= readMac
|
|
|
|
{- 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 (toB64bs t)
|
|
storekeys (KeyIds l) n = M.insert n (intercalate "," l)
|
|
|
|
{- Extracts an StorableCipher from a remote's configuration. -}
|
|
extractCipher :: RemoteConfig -> Maybe StorableCipher
|
|
extractCipher c = case (M.lookup cipherField c,
|
|
M.lookup cipherkeysField c <|> M.lookup pubkeysField c,
|
|
M.lookup encryptionField c) of
|
|
(Just t, Just ks, encryption) | maybe True (== "hybrid") encryption ->
|
|
Just $ EncryptedCipher (fromB64bs t) Hybrid (readkeys ks)
|
|
(Just t, Just ks, Just "pubkey") ->
|
|
Just $ EncryptedCipher (fromB64bs t) PubKey (readkeys ks)
|
|
(Just t, Just ks, Just "sharedpubkey") ->
|
|
Just $ SharedPubKeyCipher (fromB64bs t) (readkeys ks)
|
|
(Just t, Nothing, encryption) | maybe True (== "shared") encryption ->
|
|
Just $ SharedCipher (fromB64bs t)
|
|
_ -> Nothing
|
|
where
|
|
readkeys = KeyIds . splitc ','
|
|
|
|
isEncrypted :: RemoteConfig -> Bool
|
|
isEncrypted c = case M.lookup encryptionField c of
|
|
Just "none" -> False
|
|
Just _ -> True
|
|
Nothing -> hasEncryptionConfig c
|
|
|
|
hasEncryptionConfig :: RemoteConfig -> Bool
|
|
hasEncryptionConfig c = M.member cipherField c
|
|
|| M.member cipherkeysField c
|
|
|| M.member pubkeysField c
|
|
|
|
describeEncryption :: RemoteConfig -> 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
|
|
|
|
{- Not using Utility.Base64 because these "Strings" are really
|
|
- bags of bytes and that would convert to unicode and not round-trip
|
|
- cleanly. -}
|
|
toB64bs :: String -> String
|
|
toB64bs = w82s . B.unpack . B64.encode . B.pack . s2w8
|
|
|
|
fromB64bs :: String -> String
|
|
fromB64bs s = either (const bad) (w82s . B.unpack) (B64.decode $ B.pack $ s2w8 s)
|
|
where
|
|
bad = error "bad base64 encoded data"
|