From 67cced26dc3407a749f01010515e2d2827af2a10 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sun, 17 Apr 2011 11:01:34 -0400
Subject: S3 crypto support

Untested, I will need to dust off my S3 keys, and plug the modem back in
that was unplugged last night due to very low battery bank power. But it
compiles, so it's probably perfect. :)
---
 Remote/S3real.hs | 50 +++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 39 insertions(+), 11 deletions(-)

diff --git a/Remote/S3real.hs b/Remote/S3real.hs
index 1fa387d68..b88b22037 100644
--- a/Remote/S3real.hs
+++ b/Remote/S3real.hs
@@ -29,6 +29,7 @@ import Locations
 import Config
 import Remote.Special
 import Remote.Encryptable
+import Crypto
 
 remote :: RemoteType Annex
 remote = RemoteType {
@@ -41,16 +42,22 @@ remote = RemoteType {
 gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
 gen r u c = do
 	cst <- remoteCost r expensiveRemoteCost
-	return $ this cst
+	return $ gen' r u c cst
+gen' :: Git.Repo -> UUID -> Maybe RemoteConfig -> Int -> Remote Annex
+gen' r u c cst =
+	encryptableRemote c
+		(storeEncrypted this)
+		(retrieveEncrypted this)
+		this
 	where
-		this cst = Remote {
+		this = Remote {
 			uuid = u,
 			cost = cst,
 			name = Git.repoDescribe r,
-	 		storeKey = store (this cst),
-			retrieveKeyFile = retrieve (this cst),
-			removeKey = remove (this cst),
-			hasKey = checkPresent (this cst),
+	 		storeKey = store this,
+			retrieveKeyFile = retrieve this,
+			removeKey = remove this,
+			hasKey = checkPresent this,
 			hasKeyCheap = False,
 			config = c
 		}
@@ -139,9 +146,21 @@ checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do
 		noconn = Left $ error "S3 not configured"
 
 store :: Remote Annex -> Key -> Annex Bool
-store r k = s3Action r False $ \(conn, bucket) -> do
+store r k = storeHelper r k =<< lazyKeyContent k
+
+storeEncrypted :: Remote Annex -> (Cipher, Key) -> Key -> Annex Bool
+storeEncrypted r (cipher, enck) k = do
+	content <- lazyKeyContent k
+	content' <- liftIO $ withEncryptedContent cipher content return
+	storeHelper r enck content'
+
+lazyKeyContent :: Key -> Annex L.ByteString
+lazyKeyContent k = do
 	g <- Annex.gitRepo
-	content <- liftIO $ L.readFile $ gitAnnexLocation g k
+	liftIO $ L.readFile $ gitAnnexLocation g k
+
+storeHelper :: Remote Annex -> Key -> L.ByteString -> Annex Bool
+storeHelper r k content = s3Action r False $ \(conn, bucket) -> do
 	let object = setStorageClass storageclass $ bucketKey bucket k content
 	res <- liftIO $ sendObject conn object
 	case res of
@@ -156,16 +175,25 @@ store r k = s3Action r False $ \(conn, bucket) -> do
 				_ -> STANDARD
 
 retrieve :: Remote Annex -> Key -> FilePath -> Annex Bool
-retrieve r k f = s3Action r False $ \(conn, bucket) -> do
+retrieve = retrieveHelper (return . obj_data)
+
+retrieveEncrypted :: Remote Annex -> (Cipher, Key) -> FilePath -> Annex Bool
+retrieveEncrypted r (cipher, enck) f = retrieveHelper decrypt r enck f
+	where
+		decrypt o = withDecryptedContent cipher (obj_data o) return
+
+retrieveHelper :: (S3Object -> IO L.ByteString) -> Remote Annex -> Key -> FilePath -> Annex Bool
+retrieveHelper a r k f = s3Action r False $ \(conn, bucket) -> do
 	res <- liftIO $ getObject conn $ bucketKey bucket k L.empty
 	case res of
 		Right o -> do
-			liftIO $ L.writeFile f (obj_data o)
+			content <- liftIO $ a o
+			liftIO $ L.writeFile f content
 			return True
 		Left e -> do
 			warning $ prettyReqError e
 			return False
-
+	
 remove :: Remote Annex -> Key -> Annex Bool
 remove r k = s3Action r False $ \(conn, bucket) -> do
 	res <- liftIO $ deleteObject conn $ bucketKey bucket k L.empty
-- 
cgit v1.2.3