git-annex/Remote/Helper/Encryptable.hs

{- common functions for encryptable remotes
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Remote.Helper.Encryptable where

import qualified Data.Map as M

import Common.Annex
import Types.Remote
import Crypto
import Types.Crypto
import qualified Annex
import Config.Cost
import Utility.Base64
import Utility.Metered

{- 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 -> Annex RemoteConfig
encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
  where
	-- The type of encryption
	encryption = M.lookup "encryption" c
	-- Generate a new cipher, depending on the chosen encryption scheme
	genCipher = case encryption of
		_ | M.member "cipher" c || M.member "cipherkeys" c -> cannotchange
		Just "none" -> return c
		Just "shared" -> use "encryption setup" . genSharedCipher
			=<< highRandomQuality
		-- hybrid encryption is the default when a keyid is
                -- specified but no encryption
		_ | maybe (M.member "keyid" c) (== "hybrid") encryption ->
			use "encryption setup" . genEncryptedCipher key Hybrid
				=<< highRandomQuality
		Just "pubkey" -> use "encryption setup" . genEncryptedCipher key PubKey
				=<< highRandomQuality
		_ -> error $ "Specify " ++ intercalate " or "
			(map ("encryption=" ++)
				["none","shared","hybrid","pubkey"])
			++ "."
	key = fromMaybe (error "Specifiy keyid=...") $ M.lookup "keyid" c
	newkeys = maybe [] (\k -> [(True,k)]) (M.lookup "keyid+" c) ++
		maybe [] (\k -> [(False,k)]) (M.lookup "keyid-" c)
	cannotchange = error "Cannot set encryption type of existing remotes."
	-- Update an existing cipher if possible.
	updateCipher v = case v of
		SharedCipher _ | maybe True (== "shared") encryption -> return c'
		EncryptedCipher _ variant _
			| maybe True (== if variant == Hybrid then "hybrid" else "pubkey") encryption ->
				use "encryption update" $ updateEncryptedCipher newkeys v
		_ -> cannotchange
	use m a = do
		showNote m
		cipher <- liftIO a
		showNote $ describeCipher cipher
		return $ storeCipher c' cipher
	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" ]

{- Modifies a Remote to support encryption. -}
-- TODO: deprecated
encryptableRemote
	:: RemoteConfig
	-> ((Cipher, Key) -> Key -> MeterUpdate -> Annex Bool)
	-> ((Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool)
	-> Remote
	-> Remote
encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r = r
	{ storeKey = \k f p -> cip k >>= maybe
		(storeKey r k f p)
		(\v -> storeKeyEncrypted v k p)
	, retrieveKeyFile = \k f d p -> cip k >>= maybe
		(retrieveKeyFile r k f d p)
		(\v -> retrieveKeyFileEncrypted v k d p)
	, retrieveKeyFileCheap = \k d -> cip k >>= maybe
		(retrieveKeyFileCheap r k d)
		(\_ -> return False)
	, removeKey = \k -> cip k >>= maybe
		(removeKey r k)
		(\(_, enckey) -> removeKey r enckey)
	, checkPresent = \k -> cip k >>= maybe
		(checkPresent r k)
		(\(_, enckey) -> checkPresent r enckey)
	, cost = maybe
		(cost r)
		(const $ cost r + encryptedRemoteCostAdj)
		(extractCipher c)
	}
  where
	cip k = do
		v <- cipherKey c
		return $ case v of
			Nothing -> Nothing
			Just (cipher, enck) -> Just (cipher, enck k)

{- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex
 - state. -}
remoteCipher :: RemoteConfig -> Annex (Maybe Cipher)
remoteCipher c = 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
			Nothing -> do
				showNote "gpg"
				cipher <- liftIO $ decryptCipher encipher
				Annex.changeState (\s -> s { Annex.ciphers = M.insert encipher cipher cache })
				return $ Just cipher

{- 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, in which case the creds will be encrypted
 - using it. Not when a shared cipher is used.
 -}
embedCreds :: RemoteConfig -> Bool
embedCreds c
	| M.lookup "embedcreds" c == Just "yes" = True
	| M.lookup "embedcreds" c == Just "no" = False
	| isJust (M.lookup "cipherkeys" c) && isJust (M.lookup "cipher" c) = True
	| otherwise = False

{- Gets encryption Cipher, and key encryptor. -}
cipherKey :: RemoteConfig -> Annex (Maybe (Cipher, EncKey))
cipherKey c = fmap make <$> remoteCipher c
  where
	make ciphertext = (ciphertext, encryptKey mac ciphertext)
	mac = fromMaybe defaultMac $ M.lookup "mac" c >>= readMac

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

{- Extracts an StorableCipher from a remote's configuration. -}
extractCipher :: RemoteConfig -> Maybe StorableCipher
extractCipher c = case (M.lookup "cipher" c,
			M.lookup "cipherkeys" c,
			M.lookup "encryption" c) of
	(Just t, Just ks, encryption) | maybe True (== "hybrid") encryption ->
		Just $ EncryptedCipher (fromB64 t) Hybrid (readkeys ks)
	(Just t, Just ks, Just "pubkey") ->
		Just $ EncryptedCipher (fromB64 t) PubKey (readkeys ks)
	(Just t, Nothing, encryption) | maybe True (== "shared") encryption ->
		Just $ SharedCipher (fromB64 t)
	_ -> Nothing
  where
	readkeys = KeyIds . split ","