diff --git a/Crypto.hs b/Crypto.hs index 4ea43838a2..f32d429c3b 100644 --- a/Crypto.hs +++ b/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 - @@ -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" diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 66c78970c9..b4403bb03e 100644 --- a/Remote/Bup.hs +++ b/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 = diff --git a/Remote/Encrypted.hs b/Remote/Encrypted.hs new file mode 100644 index 0000000000..ae40446209 --- /dev/null +++ b/Remote/Encrypted.hs @@ -0,0 +1,31 @@ +{- common functions for encrypted remotes + - + - Copyright 2011 Joey Hess + - + - 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 diff --git a/Remote/S3real.hs b/Remote/S3real.hs index af4e48048a..0f6327f575 100644 --- a/Remote/S3real.hs +++ b/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