encryption key management working

Encrypted remotes don't yet encrypt data, but git annex initremote can
be used to generate a cipher and add additional gpg keys that can use it.

Crypto.hs

@@ -1,4 +1,7 @@
 {- git-annex crypto
+ -
+ - Currently using gpg; could later be modified to support different
+ - crypto backends if neccessary.
  -
  - Copyright 2011 Joey Hess <joey@kitenet.net>
  -
@@ -18,71 +21,91 @@ module Crypto (
 
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Map as M
-import System.IO
+import qualified Codec.Binary.Base64 as B64
 import System.Cmd.Utils
+import Data.String.Utils
+import Data.List
+import Data.Bits.Utils
 
 import Types
 import RemoteClass
 import Utility
 
 data Cipher = Cipher String -- XXX ideally, this would be a locked memory region
-data EncryptedCipher = EncryptedCipher String
-	deriving Show
+
+data EncryptedCipher = EncryptedCipher String KeyIds
+
+data KeyIds = KeyIds [String]
+
+instance Show KeyIds where
+	show (KeyIds ks) = join "," ks
+
+instance Read KeyIds where
+	readsPrec _ s = [(KeyIds (split "," s), "")]
 
 {- Creates a new Cipher, encrypted as specified in the remote's configuration -}
 genCipher :: RemoteConfig -> IO EncryptedCipher
-genCipher config = do
+genCipher c = do
+	ks <- configKeyIds c
 	random <- genrandom
-	encryptCipher config $ Cipher random
+	encryptCipher (Cipher random) ks
 	where
 		genrandom = gpgPipeRead
-			[ Params "--armor --gen-random"
+			[ Params "--gen-random"
 			, Param $ show randomquality
 			, Param $ show ciphersize
 			]
-		randomquality = 1 -- 1 is /dev/urandom; 2 is /dev/random
-		ciphersize = 1024
+		randomquality = 1 :: Int -- 1 is /dev/urandom; 2 is /dev/random
+		ciphersize = 1024 :: Int
 
-{- Updates an existing Cipher, re-encrypting it as specified in the
- - remote's configuration  -}
+{- Updates an existing Cipher, re-encrypting it to add KeyIds specified in
+ - the remote's configuration. -}
 updateCipher :: RemoteConfig -> EncryptedCipher -> IO EncryptedCipher
-updateCipher config encipher = do
-	cipher <- decryptCipher config encipher
-	encryptCipher config cipher
+updateCipher c encipher@(EncryptedCipher _ ks) = do
+	ks' <- configKeyIds c
+	cipher <- decryptCipher c encipher
+	encryptCipher cipher (combine ks ks')
+	where
+		combine (KeyIds a) (KeyIds b) = KeyIds $ a ++ b
 
 {- Stores an EncryptedCipher in a remote's configuration. -}
 storeCipher :: RemoteConfig -> EncryptedCipher -> RemoteConfig
-storeCipher config (EncryptedCipher c) = M.insert "cipher" c config
+storeCipher c (EncryptedCipher t ks) = 
+	M.insert "cipher" (toB64 t) $ M.insert "cipherkeys" (show ks) c
+	where
+		toB64 = B64.encode . s2w8
 
 {- Extracts an EncryptedCipher from a remote's configuration. -}
-extractCipher :: RemoteConfig -> EncryptedCipher
-extractCipher config = case M.lookup "cipher" config of
-	Just c -> EncryptedCipher c
-	Nothing -> error "missing cipher in remote config"
-
-{- Encryptes a Cipher as specified by a remote's configuration. -}
-encryptCipher :: RemoteConfig -> Cipher -> IO EncryptedCipher
-encryptCipher config (Cipher c) = do
-	encipher <- gpgPipeBoth (encrypt++recipient) c
-	return $ EncryptedCipher encipher
+extractCipher :: RemoteConfig -> Maybe EncryptedCipher
+extractCipher c = 
+	case (M.lookup "cipher" c, M.lookup "cipherkeys" c) of
+		(Just t, Just ks) -> Just $ EncryptedCipher (fromB64 t) (read ks)
+		_ -> Nothing
 	where
-		encrypt =
-			[ Params "--encrypt --armor"
-			, Params "--trust-model always"
-			]
-		recipient = case M.lookup "encryption" config of
-			Nothing -> [ Param "--default-recipient-self" ]
-			Just r ->
-				-- Force gpg to only encrypt to the specified
-				-- recipients, not configured defaults.
-				[ Params "--no-encrypt-to --no-default-recipient"
-				, Param "--recipient"
-				, Param r
-				]
+		fromB64 s = case B64.decode s of
+			Nothing -> error "bad base64 encoded cipher in remote config"
+			Just ws -> w82s ws
+
+{- 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 <- gpgPipeBoth (encrypt++recipients ks') c
+	return $ EncryptedCipher encipher (KeyIds ks')
+	where
+		encrypt = [ Params "--encrypt" ]
+		recipients l = 
+			-- Force gpg to only encrypt to the specified
+			-- recipients, not configured defaults.
+			[ Params "--no-encrypt-to --no-default-recipient"] ++
+			(concat $ map (\k -> [Param "--recipient", Param k]) l)
 
 {- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -}
 decryptCipher :: RemoteConfig -> EncryptedCipher -> IO Cipher
-decryptCipher = error "TODO"
+decryptCipher _ (EncryptedCipher encipher _) = 
+	return . Cipher =<< gpgPipeBoth decrypt encipher
+	where
+		decrypt = [ Params "--decrypt" ]
 
 {- Genetates an encrypted form of a Key. The enctyption does not need to be
  - reversable, nor does it need to be the same type of encryption used
@@ -100,7 +123,10 @@ decryptContent = error "TODO"
 
 
 gpgParams :: [CommandParam] -> [String]
-gpgParams params = ["--batch", "--quiet"] ++ toCommand params
+gpgParams params =
+	-- avoid console IO, and be quiet, even about checking the trustdb
+	["--batch", "--quiet", "--trust-model", "always"] ++
+	toCommand params
 
 gpgPipeRead :: [CommandParam] -> IO String
 gpgPipeRead params = pOpen ReadFromPipe "gpg" (gpgParams params) hGetContentsStrict
@@ -109,3 +135,19 @@ gpgPipeBoth :: [CommandParam] -> String -> IO String
 gpgPipeBoth params input = do
 	(_, s) <- pipeBoth "gpg" (gpgParams params) input
 	return s
+
+configKeyIds :: RemoteConfig -> IO KeyIds
+configKeyIds c = do
+	let k = configGet c "encryption"
+	s <- gpgPipeRead [Params "--with-colons --list-public-keys", Param k]
+	return $ KeyIds $ parseWithColons s
+	where
+		parseWithColons s = map keyIdField $ filter pubKey $ lines s
+		pubKey = isPrefixOf "pub:"
+		keyIdField s = (split ":" s) !! 4
+
+configGet :: RemoteConfig -> String -> String
+configGet c key =
+	case M.lookup key c of
+		Just v -> v
+		Nothing -> error $ "missing " ++ key ++ " in remote config"

Remote/Bup.hs

@@ -26,8 +26,9 @@ import Locations
 import Config
 import Utility
 import Messages
-import Remote.Special
 import Ssh
+import Remote.Special
+import Remote.Encrypted
 
 type BupRepo = String
 
@@ -66,10 +67,7 @@ bupSetup u c = do
 	let buprepo = case M.lookup "buprepo" c of
 		Nothing -> error "Specify buprepo="
 		Just r -> r
-	case M.lookup "encryption" c of
-		Nothing -> error "Specify encryption=key or encryption=none"
-		Just "none" -> return ()
-		Just _ -> error "encryption keys not yet supported"
+	c' <- encryptionSetup c
 
 	-- bup init will create the repository.
 	-- (If the repository already exists, bup init again appears safe.)
@@ -81,9 +79,9 @@ bupSetup u c = do
 
 	-- The buprepo is stored in git config, as well as this repo's
 	-- persistant state, so it can vary between hosts.
-	gitConfigSpecialRemote u c "buprepo" buprepo
+	gitConfigSpecialRemote u c' "buprepo" buprepo
 
-	return $ M.delete "directory" c
+	return c'
 
 bupParams :: String -> BupRepo -> [CommandParam] -> [CommandParam]
 bupParams command buprepo params = 

Remote/Encrypted.hs

@@ -0,0 +1,31 @@
+{- common functions for encrypted remotes
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Encrypted where
+
+import qualified Data.Map as M
+import Control.Monad.State (liftIO)
+
+import Types
+import RemoteClass
+import Crypto
+
+{- 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. -}
+encryptionSetup :: RemoteConfig -> Annex RemoteConfig
+encryptionSetup c =
+	case (M.lookup "encryption" c, extractCipher c) of
+		(Nothing, Nothing) -> error "Specify encryption=key or encryption=none"
+		(Just "none", _) -> return c
+		(Nothing, Just _) -> return c
+		(Just _, Nothing) -> use $ genCipher c
+		(Just _, Just v) -> use $ updateCipher c v
+	where
+		use a = do
+			cipher <- liftIO a
+			return $ M.delete "encryption" $ storeCipher c cipher

Remote/S3real.hs

@@ -28,6 +28,7 @@ import Messages
 import Locations
 import Config
 import Remote.Special
+import Remote.Encrypted
 
 remote :: RemoteType Annex
 remote = RemoteType {
@@ -81,11 +82,8 @@ s3Connection c = do
 s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig
 s3Setup u c = do
 	-- verify configuration is sane
-	case M.lookup "encryption" c of
-		Nothing -> error "Specify encryption=key or encryption=none"
-		Just "none" -> return ()
-		Just _ -> error "encryption keys not yet supported"
-	let fullconfig = M.union c defaults
+	c' <- encryptionSetup c
+	let fullconfig = M.union c' defaults
 
 	-- check bucket location to see if the bucket exists, and create it
 	let datacenter = fromJust $ M.lookup "datacenter" fullconfig