{- common functions for encryptable remotes - - Copyright 2011 Joey Hess - - 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 Types.ProposedAccepted 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 = fromProposedAccepted <$> 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 (Accepted "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 ((fromProposedAccepted encryptionField ++ "=") ++) ["none","shared","hybrid","pubkey", "sharedpubkey"]) ++ "." 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 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 (\v -> fromProposedAccepted v /= "false") $ M.lookup (Accepted "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). (map Accepted [ "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 . fromProposedAccepted =<< M.lookup embedCredsField 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 . fromProposedAccepted {- 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 (toB64bs t)) storekeys (KeyIds l) n = M.insert n (Accepted (intercalate "," l)) {- Extracts an StorableCipher from a remote's configuration. -} extractCipher :: RemoteConfig -> Maybe StorableCipher extractCipher c = case (fromProposedAccepted <$> M.lookup cipherField c, fromProposedAccepted <$> (M.lookup cipherkeysField c <|> M.lookup pubkeysField c), fromProposedAccepted <$> 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 fromProposedAccepted <$> 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"