Skip to content
Snippets Groups Projects
Crypto.hs 9.93 KiB
Newer Older
Joey Hess's avatar
add
Joey Hess committed
{- git-annex crypto
 -
 - Currently using gpg; could later be modified to support different
 - crypto backends if necessary.
Joey Hess's avatar
add
Joey Hess committed
 -
 - Copyright 2011-2022 Joey Hess <id@joeyh.name>
Joey Hess's avatar
add
Joey Hess committed
 -
 - Licensed under the GNU AGPL version 3 or higher.
Joey Hess's avatar
add
Joey Hess committed
 -}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
Joey Hess's avatar
Joey Hess committed
{-# LANGUAGE Rank2Types #-}
Joey Hess's avatar
add
Joey Hess committed
module Crypto (
	EncryptionMethod(..),
Joey Hess's avatar
Joey Hess committed
	KeyIds(..),
	StorableCipher(..),
	genEncryptedCipher,
	genSharedCipher,
	genSharedPubKeyCipher,
	updateCipherKeyIds,
	decryptCipher,
	decryptCipher',
Joey Hess's avatar
add
Joey Hess committed
	encryptKey,
	isEncKey,
	feedFile,
	feedBytes,
	readBytes,
Joey Hess's avatar
Joey Hess committed
	readBytesStrictly,
	prop_HmacSha1WithCipher_sane
Joey Hess's avatar
add
Joey Hess committed
) where

import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.UTF8 (fromString)
Joey Hess's avatar
Joey Hess committed
import Control.Monad.IO.Class
Joey Hess's avatar
add
Joey Hess committed

import qualified Utility.Gpg as Gpg
import Types.Crypto
import Types.Remote
Joey Hess's avatar
Joey Hess committed
import Types.Key
import Annex.SpecialRemote.Config
import qualified Data.ByteString.Short as S (toShort)
Joey Hess's avatar
add
Joey Hess committed

{- The beginning of a Cipher is used for MAC'ing; the remainder is used
 - as the GPG symmetric encryption passphrase when using the hybrid
 - scheme. Note that the cipher itself is base-64 encoded, hence the
 - string is longer than 'cipherSize': 683 characters, padded to 684.
 - The 256 first characters that feed the MAC represent at best 192
 - bytes of entropy.  However that's more than enough for both the
 - default MAC algorithm, namely HMAC-SHA1, and the "strongest"
Joey Hess's avatar
Joey Hess committed
 - currently supported, namely HMAC-SHA512, which respectively need
 - (ideally) 64 and 128 bytes of entropy.
Joey Hess's avatar
Joey Hess committed
 - The remaining characters (320 bytes of entropy) is enough for GnuPG's
 - symmetric cipher; unlike weaker public key crypto, the key does not
 - need to be too large.
cipherBeginning :: Int
cipherBeginning = 256

cipherPassphrase :: Cipher -> String
cipherPassphrase (Cipher c) = drop cipherBeginning c
cipherPassphrase (MacOnlyCipher _) = giveup "MAC-only cipher"
cipherMac :: Cipher -> String
cipherMac (Cipher c) = take cipherBeginning c
cipherMac (MacOnlyCipher c) = c
{- Creates a new Cipher, encrypted to the specified key id. -}
genEncryptedCipher :: LensGpgEncParams c => Gpg.GpgCmd -> c -> Gpg.KeyId -> EncryptedCipherVariant -> Bool -> IO StorableCipher
genEncryptedCipher cmd c keyid variant highQuality = do
Joey Hess's avatar
Joey Hess committed
	ks <- Gpg.findPubKeys cmd keyid
	random <- Gpg.genRandom cmd highQuality size
	encryptCipher cmd c (mkCipher random) variant ks
	(mkCipher, size) = case variant of
Joey Hess's avatar
Joey Hess committed
		Hybrid -> (Cipher, cipherSize) -- used for MAC + symmetric
		PubKey -> (MacOnlyCipher, cipherBeginning) -- only used for MAC

{- Creates a new, shared Cipher. -}
Joey Hess's avatar
Joey Hess committed
genSharedCipher :: Gpg.GpgCmd -> Bool -> IO StorableCipher
genSharedCipher cmd highQuality =
	SharedCipher <$> Gpg.genRandom cmd highQuality cipherSize
{- Creates a new, shared Cipher, and looks up the gpg public key that will
 - be used for encrypting content. -}
genSharedPubKeyCipher :: Gpg.GpgCmd -> Gpg.KeyId -> Bool -> IO StorableCipher
genSharedPubKeyCipher cmd keyid highQuality = do
	ks <- Gpg.findPubKeys cmd keyid
	random <- Gpg.genRandom cmd highQuality cipherSize
	return $ SharedPubKeyCipher random ks

{- Updates an existing Cipher, making changes to its keyids.
 -
 - When the Cipher is encrypted, re-encrypts it. -}
updateCipherKeyIds :: LensGpgEncParams encparams => Gpg.GpgCmd -> encparams -> [(Bool, Gpg.KeyId)] -> StorableCipher -> IO StorableCipher
updateCipherKeyIds _ _ _ SharedCipher{} = giveup "Cannot update shared cipher"
updateCipherKeyIds _ _ [] c = return c
updateCipherKeyIds cmd encparams changes encipher@(EncryptedCipher _ variant ks) = do
	ks' <- updateCipherKeyIds' cmd changes ks
	cipher <- decryptCipher cmd encparams encipher
	encryptCipher cmd encparams cipher variant ks'
updateCipherKeyIds cmd _ changes (SharedPubKeyCipher cipher ks) =
	SharedPubKeyCipher cipher <$> updateCipherKeyIds' cmd changes ks

updateCipherKeyIds' :: Gpg.GpgCmd -> [(Bool, Gpg.KeyId)] -> KeyIds -> IO KeyIds
updateCipherKeyIds' cmd changes (KeyIds ks) = do
	dropkeys <- listKeyIds [ k | (False, k) <- changes ]
	forM_ dropkeys $ \k -> unless (k `elem` ks) $
		giveup $ "Key " ++ k ++ " was not present; cannot remove."
	addkeys <- listKeyIds [ k | (True, k) <- changes ]
	let ks' = (addkeys ++ ks) \\ dropkeys
Joey Hess's avatar
Joey Hess committed
	when (null ks') $
		giveup "Cannot remove the last key."
Joey Hess's avatar
Joey Hess committed
	listKeyIds = concat <$$> mapM (keyIds <$$> Gpg.findPubKeys cmd)
Joey Hess's avatar
add
Joey Hess committed

{- Encrypts a Cipher to the specified KeyIds. -}
encryptCipher :: LensGpgEncParams c => Gpg.GpgCmd -> c -> Cipher -> EncryptedCipherVariant -> KeyIds -> IO StorableCipher
encryptCipher cmd c cip variant (KeyIds ks) = do
Joey Hess's avatar
Joey Hess committed
	-- gpg complains about duplicate recipient keyids
	let ks' = nub $ sort ks
	let params = concat
		[ getGpgEncParamsBase c
		, Gpg.pkEncTo ks'
		, Gpg.stdEncryptionParams False
		]
Joey Hess's avatar
Joey Hess committed
	encipher <- Gpg.pipeStrict cmd params cipher
	return $ EncryptedCipher encipher variant (KeyIds ks')
	cipher = case cip of
		Cipher x -> x
		MacOnlyCipher x -> x
Joey Hess's avatar
add
Joey Hess committed

{- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -}
decryptCipher :: LensGpgEncParams c => Gpg.GpgCmd -> c -> StorableCipher -> IO Cipher
decryptCipher cmd c cip = decryptCipher' cmd Nothing c cip

decryptCipher' :: LensGpgEncParams c => Gpg.GpgCmd -> Maybe [(String, String)] -> c -> StorableCipher -> IO Cipher
decryptCipher' _ _ _ (SharedCipher t) = return $ Cipher t
decryptCipher' _ _ _ (SharedPubKeyCipher t _) = return $ MacOnlyCipher t
decryptCipher' cmd environ c (EncryptedCipher t variant _) =
	mkCipher <$> Gpg.pipeStrict' cmd params environ t
  where
	mkCipher = case variant of
Joey Hess's avatar
Joey Hess committed
		Hybrid -> Cipher
		PubKey -> MacOnlyCipher
	params = Param "--decrypt" : getGpgDecParams c
Joey Hess's avatar
add
Joey Hess committed

{- Generates an encrypted form of a Key. The encryption does not need to be
 - reversible, nor does it need to be the same type of encryption used
 - on content. It does need to be repeatable. -}
encryptKey :: Mac -> Cipher -> EncKey
encryptKey mac c k = mkKey $ \d -> d
	{ keyName = S.toShort $ encodeBS $ macWithCipher mac c (serializeKey k)
	, keyVariety = OtherKey $
		encryptedBackendNamePrefix <> encodeBS (showMac mac)
Joey Hess's avatar
add
Joey Hess committed

encryptedBackendNamePrefix :: S.ByteString
encryptedBackendNamePrefix = "GPG"

isEncKey :: Key -> Bool
isEncKey k = case fromKey keyVariety k of
	OtherKey s -> encryptedBackendNamePrefix `S.isPrefixOf` s
Joey Hess's avatar
Joey Hess committed
	_ -> False
type Feeder = Handle -> IO ()
Joey Hess's avatar
Joey Hess committed
type Reader m a = Handle -> m a

feedFile :: FilePath -> Feeder
feedFile f h = L.hPut h =<< L.readFile f

feedBytes :: L.ByteString -> Feeder
feedBytes = flip L.hPut

Joey Hess's avatar
Joey Hess committed
readBytes :: (MonadIO m) => (L.ByteString -> m a) -> Reader m a
readBytes a h = liftIO (L.hGetContents h) >>= a
Joey Hess's avatar
Joey Hess committed
readBytesStrictly :: (MonadIO m) => (S.ByteString -> m a) -> Reader m a
readBytesStrictly a h = liftIO (S.hGetContents h) >>= a


{- Runs a Feeder action, that generates content that is symmetrically
 - encrypted with the Cipher (unless it is empty, in which case
 - public-key encryption is used) using the given gpg options, and then
Joey Hess's avatar
Joey Hess committed
 - read by the Reader action. 
 -
 - Note that the Reader must fully consume gpg's input before returning.
 -}
encrypt :: (MonadIO m, MonadMask m, LensGpgEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a
encrypt cmd c cipher = case cipher of
Joey Hess's avatar
Joey Hess committed
	Cipher{} -> Gpg.feedRead cmd (params ++ Gpg.stdEncryptionParams True) $
			cipherPassphrase cipher
Joey Hess's avatar
Joey Hess committed
	MacOnlyCipher{} -> Gpg.feedRead' cmd $ params ++ Gpg.stdEncryptionParams False

{- Runs a Feeder action, that generates content that is decrypted with the
 - Cipher (or using a private key if the Cipher is empty), and read by the
Joey Hess's avatar
Joey Hess committed
 - Reader action.
 -
 - Note that the Reader must fully consume gpg's input before returning.
 - -}
decrypt :: (MonadIO m, MonadMask m, LensGpgEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a
decrypt cmd c cipher = case cipher of
Joey Hess's avatar
Joey Hess committed
	Cipher{} -> Gpg.feedRead cmd params $ cipherPassphrase cipher
Joey Hess's avatar
Joey Hess committed
	MacOnlyCipher{} -> Gpg.feedRead' cmd params
Joey Hess's avatar
Joey Hess committed
	params = Param "--decrypt" : getGpgDecParams c
Joey Hess's avatar
add
Joey Hess committed

macWithCipher :: Mac -> Cipher -> String -> String
macWithCipher mac c = macWithCipher' mac (cipherMac c)
macWithCipher' :: Mac -> String -> String -> String
macWithCipher' mac c s = calcMac mac (fromString c) (fromString s)
{- Ensure that macWithCipher' returns the same thing forevermore. -}
prop_HmacSha1WithCipher_sane :: Bool
prop_HmacSha1WithCipher_sane = known_good == macWithCipher' HmacSha1 "foo" "bar"
  where
	known_good = "46b4ec586117154dacd49d664e5d63fdc88efb51"
class LensGpgEncParams a where
	{- Base parameters for encrypting. Does not include specification
	 - of recipient keys. -}
	getGpgEncParamsBase :: a -> [CommandParam]
	{- Parameters for encrypting. When the remote is configured to use
	 - public-key encryption, includes specification of recipient keys. -}
	getGpgEncParams :: a -> [CommandParam]
	{- Parameters for decrypting. -}
	getGpgDecParams :: a -> [CommandParam]

{- Extract the GnuPG options from a pair of a Remote Config and a Remote
instance LensGpgEncParams (ParsedRemoteConfig, RemoteGitConfig) where
	getGpgEncParamsBase (_c,gc) = map Param (remoteAnnexGnupgOptions gc)
	getGpgEncParams (c,gc) = getGpgEncParamsBase (c,gc) ++
 		{- When the remote is configured to use public-key encryption,
		 - look up the recipient keys and add them to the option list. -}
		case getRemoteConfigValue encryptionField c of
			Just PubKeyEncryption -> 
				Gpg.pkEncTo $ maybe [] (splitc ',') $
					getRemoteConfigValue cipherkeysField c
			Just SharedPubKeyEncryption ->
				Gpg.pkEncTo $ maybe [] (splitc ',') $
					getRemoteConfigValue pubkeysField c
			_ -> []
	getGpgDecParams (_c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc)

{- Extract the GnuPG options from a Remote. -}
instance LensGpgEncParams (RemoteA a) where
	getGpgEncParamsBase r = getGpgEncParamsBase (config r, gitconfig r)
	getGpgEncParams r = getGpgEncParams (config r, gitconfig r)
	getGpgDecParams r = getGpgDecParams (config r, gitconfig r)