path: root/Crypto.hs

{- git-annex crypto
 -
 - Currently using gpg; could later be modified to support different
 - crypto backends if neccessary.
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Crypto (
	Cipher,
	EncryptedCipher,
	genCipher,
	updateCipher,
	describeCipher,
	storeCipher,
	extractCipher,
	decryptCipher,		
	encryptKey,
	withEncryptedHandle,
	withDecryptedHandle,
	withEncryptedContent,
	withDecryptedContent,

	prop_hmacWithCipher_sane
) where

import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import Data.ByteString.Lazy.UTF8 (fromString)
import Data.Digest.Pure.SHA
import System.Posix.Types
import Control.Applicative
import Control.Concurrent
import Control.Exception (finally)
import System.Exit
import System.Environment

import Common.Annex
import Types.Key
import Types.Remote
import Utility.Base64
import Types.Crypto

{- The first half of a Cipher is used for HMAC; the remainder
 - is used as the GPG symmetric encryption passphrase.
 -
 - HMAC SHA1 needs only 64 bytes. The remainder is for expansion,
 - perhaps to HMAC SHA512, which needs 128 bytes (ideally).
 -
 - 256 is enough for gpg's symetric cipher; unlike weaker public key
 - crypto, the key does not need to be too large.
 -}
cipherHalf :: Int
cipherHalf = 256

cipherSize :: Int
cipherSize = cipherHalf * 2

cipherPassphrase :: Cipher -> String
cipherPassphrase (Cipher c) = drop cipherHalf c

cipherHmac :: Cipher -> String
cipherHmac (Cipher c) = take cipherHalf c

{- Creates a new Cipher, encrypted as specified in the remote's configuration -}
genCipher :: RemoteConfig -> IO EncryptedCipher
genCipher c = do
	ks <- configKeyIds c
	random <- genrandom
	encryptCipher (Cipher random) ks
	where
		genrandom = gpgReadStrict
			-- Armor the random data, to avoid newlines,
			-- since gpg only reads ciphers up to the first
			-- newline.
			[ Params "--gen-random --armor"
			, Param $ show randomquality
			, Param $ show cipherSize
			]
		-- 1 is /dev/urandom; 2 is /dev/random
		randomquality = 1 :: Int

{- Updates an existing Cipher, re-encrypting it to add KeyIds specified in
 - the remote's configuration. -}
updateCipher :: RemoteConfig -> EncryptedCipher -> IO EncryptedCipher
updateCipher c encipher@(EncryptedCipher _ ks) = do
	ks' <- configKeyIds c
	cipher <- decryptCipher c encipher
	encryptCipher cipher (merge ks ks')
	where
		merge (KeyIds a) (KeyIds b) = KeyIds $ a ++ b

describeCipher :: EncryptedCipher -> String
describeCipher (EncryptedCipher _ (KeyIds ks)) =
	"with gpg " ++ keys ks ++ " " ++ unwords ks
	where
		keys [_] = "key"
		keys _ = "keys"

{- Stores an EncryptedCipher in a remote's configuration. -}
storeCipher :: RemoteConfig -> EncryptedCipher -> RemoteConfig
storeCipher c (EncryptedCipher t ks) = 
	M.insert "cipher" (toB64 t) $ M.insert "cipherkeys" (showkeys ks) c
	where
		showkeys (KeyIds l) = join "," l

{- Extracts an EncryptedCipher from a remote's configuration. -}
extractCipher :: RemoteConfig -> Maybe EncryptedCipher
extractCipher c = 
	case (M.lookup "cipher" c, M.lookup "cipherkeys" c) of
		(Just t, Just ks) -> Just $ EncryptedCipher (fromB64 t) (readkeys ks)
		_ -> Nothing
	where
		readkeys = KeyIds . split ","

{- Encrypts a Cipher to the specified KeyIds. -}
encryptCipher :: Cipher -> KeyIds -> IO EncryptedCipher
encryptCipher (Cipher c) (KeyIds ks) = do
	let ks' = nub $ sort ks -- gpg complains about duplicate recipient keyids
	encipher <- gpgPipeStrict (encrypt++recipients ks') c
	return $ EncryptedCipher encipher (KeyIds ks')
	where
		encrypt = [ Params "--encrypt" ]
		recipients l = force_recipients :
			concatMap (\k -> [Param "--recipient", Param k]) l
		-- Force gpg to only encrypt to the specified
		-- recipients, not configured defaults.
		force_recipients = Params "--no-encrypt-to --no-default-recipient"

{- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -}
decryptCipher :: RemoteConfig -> EncryptedCipher -> IO Cipher
decryptCipher _ (EncryptedCipher encipher _) = 
	Cipher <$> gpgPipeStrict decrypt encipher
	where
		decrypt = [ Param "--decrypt" ]

{- Generates an encrypted form of a Key. The encryption does not need to be
 - reversable, nor does it need to be the same type of encryption used
 - on content. It does need to be repeatable. -}
encryptKey :: Cipher -> Key -> Key
encryptKey c k = Key
	{ keyName = hmacWithCipher c (show k)
	, keyBackendName = "GPGHMACSHA1"
	, keySize = Nothing -- size and mtime omitted
	, keyMtime = Nothing -- to avoid leaking data
	}

{- Runs an action, passing it a handle from which it can 
 - stream encrypted content. -}
withEncryptedHandle :: Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a
withEncryptedHandle = gpgPassphraseHandle [Params "--symmetric --force-mdc"] . cipherPassphrase

{- Runs an action, passing it a handle from which it can
 - stream decrypted content. -}
withDecryptedHandle :: Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a
withDecryptedHandle = gpgPassphraseHandle [Param "--decrypt"] . cipherPassphrase

{- Streams encrypted content to an action. -}
withEncryptedContent :: Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a
withEncryptedContent = pass withEncryptedHandle

{- Streams decrypted content to an action. -}
withDecryptedContent :: Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a
withDecryptedContent = pass withDecryptedHandle

pass :: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a) 
      -> Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a
pass to c i a = to c i $ \h -> a =<< L.hGetContents h

gpgParams :: [CommandParam] -> IO [String]
gpgParams params = do
	-- Enable batch mode if GPG_AGENT_INFO is set, to avoid extraneous
	-- gpg output about password prompts.
	e <- catchDefaultIO (getEnv "GPG_AGENT_INFO") ""
	let batch = if null e then [] else ["--batch"]
	return $ batch ++ defaults ++ toCommand params
	where
		-- be quiet, even about checking the trustdb
		defaults = ["--quiet", "--trust-model", "always"]

{- Runs gpg with some params and returns its stdout, strictly. -}
gpgReadStrict :: [CommandParam] -> IO String
gpgReadStrict params = do
	params' <- gpgParams params
	pOpen ReadFromPipe "gpg" params' hGetContentsStrict

{- Runs gpg, piping an input value to it, and returninging its stdout,
 - strictly. -}
gpgPipeStrict :: [CommandParam] -> String -> IO String
gpgPipeStrict params input = do
	params' <- gpgParams params
	(pid, fromh, toh) <- hPipeBoth "gpg" params'
	_ <- forkIO $ finally (hPutStr toh input) (hClose toh)
	output <- hGetContentsStrict fromh
	forceSuccess pid
	return output

{- Runs gpg with some parameters, first feeding it a passphrase via
 - --passphrase-fd, then feeding it an input, and passing a handle
 - to its output to an action.
 -
 - Note that to avoid deadlock with the cleanup stage,
 - the action must fully consume gpg's input before returning. -}
gpgPassphraseHandle :: [CommandParam] -> String -> IO L.ByteString -> (Handle -> IO a) -> IO a
gpgPassphraseHandle params passphrase a b = do
	-- pipe the passphrase into gpg on a fd
	(frompipe, topipe) <- createPipe
	_ <- forkIO $ do
		toh <- fdToHandle topipe
		hPutStrLn toh passphrase
		hClose toh
	let Fd pfd = frompipe
	let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]

	params' <- gpgParams $ passphrasefd ++ params
	(pid, fromh, toh) <- hPipeBoth "gpg" params'
	pid2 <- forkProcess $ do
		L.hPut toh =<< a
		hClose toh
		exitSuccess
	hClose toh
	ret <- b fromh

	-- cleanup
	forceSuccess pid
	_ <- getProcessStatus True False pid2
	closeFd frompipe
	return ret

configKeyIds :: RemoteConfig -> IO KeyIds
configKeyIds c = parse <$> gpgReadStrict params
	where
		params = [Params "--with-colons --list-public-keys",
			Param $ configGet c "encryption"]
		parse = KeyIds . map keyIdField . filter pubKey . lines
		pubKey = isPrefixOf "pub:"
		keyIdField s = split ":" s !! 4

configGet :: RemoteConfig -> String -> String
configGet c key = fromMaybe missing $ M.lookup key c
	where
		missing = error $ "missing " ++ key ++ " in remote config"

hmacWithCipher :: Cipher -> String -> String
hmacWithCipher c = hmacWithCipher' (cipherHmac c) 
hmacWithCipher' :: String -> String -> String
hmacWithCipher' c s = showDigest $ hmacSha1 (fromString c) (fromString s)

{- Ensure that hmacWithCipher' returns the same thing forevermore. -}
prop_hmacWithCipher_sane :: Bool
prop_hmacWithCipher_sane = known_good == hmacWithCipher' "foo" "bar"
	where
		known_good = "46b4ec586117154dacd49d664e5d63fdc88efb51"