full encryption support for directory special remotes

3 files changed, 83 insertions, 15 deletions

diff --git a/Crypto.hs b/Crypto.hs
index 337aedff6..9f404c1b1 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -9,6 +9,8 @@
  -}
 
 module Crypto (
+	Cipher,
+	EncryptedCipher,
 	genCipher,
 	updateCipher,
 	storeCipher,
@@ -133,7 +135,10 @@ gpgRead params = pOpen ReadFromPipe "gpg" (gpgParams params) hGetContentsStrict
 
 gpgPipeStrict :: [CommandParam] -> String -> IO String
 gpgPipeStrict params input = do
-	(_, output) <- pipeBoth "gpg" (gpgParams params) input
+	(pid, fromh, toh) <- hPipeBoth "gpg" (gpgParams params)
+	_ <- forkIO $ finally (hPutStr toh input) (hClose toh)
+	output <- hGetContentsStrict fromh
+	forceSuccess pid
 	return output
 
 gpgPipeBytes :: [CommandParam] -> L.ByteString -> IO (PipeHandle, L.ByteString)
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index bb1ef60e4..5ea0a1e6b 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -7,6 +7,7 @@
 
 module Remote.Directory (remote) where
 
+import qualified Data.ByteString.Lazy.Char8 as L
 import IO
 import Control.Exception.Extensible (IOException)
 import qualified Data.Map as M
@@ -27,6 +28,7 @@ import Content
 import Utility
 import Remote.Special
 import Remote.Encrypted
+import Crypto
 
 remote :: RemoteType Annex
 remote = RemoteType {
@@ -37,17 +39,17 @@ remote = RemoteType {
 }
 
 gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
-gen r u _ = do
+gen r u c = do
 	dir <- getConfig r "directory" (error "missing directory")
 	cst <- remoteCost r cheapRemoteCost
 	return $ Remote {
 		uuid = u,
 		cost = cst,
 		name = Git.repoDescribe r,
- 		storeKey = store dir,
-		retrieveKeyFile = retrieve dir,
-		removeKey = remove dir,
-		hasKey = checkPresent dir,
+ 		storeKey = storeKeyEncrypted c $ store dir,
+		retrieveKeyFile = retrieveKeyFileEncrypted c $ retrieve dir,
+		removeKey = removeKeyEncrypted c $ remove dir,
+		hasKey = hasKeyEncrypted c $ checkPresent dir,
 		hasKeyCheap = True,
 		config = Nothing
 	}
@@ -72,25 +74,43 @@ dirKey d k = d </> hashDirMixed k </> f </> f
 	where
 		f = keyFile k
 
-store :: FilePath -> Key -> Annex Bool
-store d k = do
+store :: FilePath -> Key -> Maybe (Cipher, Key) -> Annex Bool
+store d k c = do
 	g <- Annex.gitRepo
-	let src = gitAnnexLocation g k
+	let src = gitAnnexLocation g k	
 	liftIO $ catch (copy src) (const $ return False)
 	where
-		dest = dirKey d k
-		dir = parentDir dest
-		copy src = do
+		copy src = case c of
+			Just (cipher, enckey) -> do
+				content <- L.readFile src
+				let dest = dirKey d enckey
+				prep dest
+				withEncryptedContent cipher content $ \s -> do
+					L.writeFile dest s
+					cleanup True dest
+			_ -> do
+				let dest = dirKey d k
+				prep dest
+				ok <- copyFile src dest
+				cleanup ok dest
+		prep dest = liftIO $ do
+			let dir = parentDir dest
 			createDirectoryIfMissing True dir
 			allowWrite dir
-			ok <- copyFile src dest
+		cleanup ok dest = do
 			when ok $ do
+				let dir = parentDir dest
 				preventWrite dest
 				preventWrite dir
 			return ok
 
-retrieve :: FilePath -> Key -> FilePath -> Annex Bool
-retrieve d k f = liftIO $ copyFile (dirKey d k) f
+retrieve :: FilePath -> Key -> FilePath -> Maybe (Cipher, Key) -> Annex Bool
+retrieve d k f Nothing = liftIO $ copyFile (dirKey d k) f
+retrieve d k f (Just (cipher, enckey)) = 
+	liftIO $ flip catch (const $ return False) $ do
+		content <- L.readFile (dirKey d enckey)
+		withDecryptedContent cipher content $ L.writeFile f
+		return True
 
 remove :: FilePath -> Key -> Annex Bool
 remove d k = liftIO $ catch del (const $ return False)
diff --git a/Remote/Encrypted.hs b/Remote/Encrypted.hs
index ae4044620..2a0fb13bc 100644
--- a/Remote/Encrypted.hs
+++ b/Remote/Encrypted.hs
@@ -13,6 +13,8 @@ import Control.Monad.State (liftIO)
 import Types
 import RemoteClass
 import Crypto
+import qualified Annex
+import Messages
 
 {- 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
@@ -29,3 +31,44 @@ encryptionSetup c =
 		use a = do
 			cipher <- liftIO a
 			return $ M.delete "encryption" $ storeCipher c cipher
+
+{- Helpers that can be applied to a Remote's normal actions to
+ - add crypto support. -}
+storeKeyEncrypted :: Maybe RemoteConfig -> (Key -> Maybe (Cipher, Key) -> Annex a) -> Key -> Annex a
+storeKeyEncrypted c a k = a k =<< cipherKey c k
+retrieveKeyFileEncrypted :: Maybe RemoteConfig -> (Key -> FilePath -> Maybe (Cipher, Key) -> Annex a) -> Key -> FilePath -> Annex a
+retrieveKeyFileEncrypted c a k f = a k f =<< cipherKey c k
+removeKeyEncrypted :: Maybe RemoteConfig -> (Key -> Annex a) -> Key -> Annex a
+removeKeyEncrypted = withEncryptedKey
+hasKeyEncrypted :: Maybe RemoteConfig -> (Key -> Annex a) -> Key -> Annex a
+hasKeyEncrypted = withEncryptedKey
+
+{- Gets encryption Cipher, and encrypted version of Key. 
+ -
+ - The decrypted Cipher is cached in the Annex state. -}
+cipherKey :: Maybe RemoteConfig -> Key -> Annex (Maybe (Cipher, Key))
+cipherKey Nothing _ = return Nothing
+cipherKey (Just c) k = do
+	cache <- Annex.getState Annex.cipher
+	case cache of
+		Just cipher -> ret cipher
+		Nothing -> case extractCipher c of
+			Nothing -> return Nothing
+			Just encipher -> do
+				showNote "getting encryption key"
+				cipher <- liftIO $ decryptCipher c encipher
+				Annex.changeState (\s -> s { Annex.cipher = Just cipher })
+				ret cipher
+	where
+		ret cipher = do
+			k' <- liftIO $ encryptKey cipher k
+			return $ Just (cipher, k')
+
+{- Passes the encrypted version of the key to the action when encryption
+ - is enabled, and the non-encrypted version otherwise. -}
+withEncryptedKey :: Maybe RemoteConfig -> (Key -> Annex a) -> Key -> Annex a
+withEncryptedKey c a k = do
+	v <- cipherKey c k
+	case v of
+		Nothing -> a k
+		Just (_, k') -> a k'