Support for remotes that are chunkable and encryptable.

I'd have liked to keep these two concepts entirely separate,
but that are entagled: Storing a key in an encrypted and chunked remote
need to generate chunk keys, encrypt the keys, chunk the data, encrypt the
chunks, and send them to the remote. Similar for retrieval, etc.

So, here's an implemnetation of all of that.

The total win here is that every remote was implementing encrypted storage
and retrival, and now it can move into this single place. I expect this
to result in several hundred lines of code being removed from git-annex
eventually!

This commit was sponsored by Henrik Ahlgren.

4 files changed, 254 insertions, 15 deletions

diff --git a/Crypto.hs b/Crypto.hs
index 0bfa81db2..89b47f318 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -13,6 +13,7 @@
 module Crypto (
 	Cipher,
 	KeyIds(..),
+	EncKey,
 	StorableCipher(..),
 	genEncryptedCipher,
 	genSharedCipher,
@@ -138,10 +139,12 @@ decryptCipher (EncryptedCipher t variant _) =
 		Hybrid -> Cipher
 		PubKey -> MacOnlyCipher
 
+type EncKey = Key -> Key
+
 {- Generates an encrypted form of a Key. The encryption does not need to be
  - reversable, nor does it need to be the same type of encryption used
  - on content. It does need to be repeatable. -}
-encryptKey :: Mac -> Cipher -> Key -> Key
+encryptKey :: Mac -> Cipher -> EncKey
 encryptKey mac c k = stubKey
 	{ keyName = macWithCipher mac c (key2file k)
 	, keyBackendName = "GPG" ++ showMac mac
diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs
new file mode 100644
index 000000000..df6d94d04
--- /dev/null
+++ b/Remote/Directory/LegacyChunked.hs
@@ -0,0 +1,110 @@
+{- Legacy chunksize support for directory special remote.
+ -
+ - Can be removed eventually.
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Directory.LegacyChunked where
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString as S
+
+import Common.Annex
+import Utility.FileMode
+import Remote.Helper.ChunkedEncryptable
+import qualified Remote.Helper.Chunked.Legacy as Legacy
+import Annex.Perms
+import Utility.Metered
+
+withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool
+withCheckedFiles _ [] _locations _ _ = return False
+withCheckedFiles check d locations k a = go $ locations d k
+  where
+	go [] = return False
+	go (f:fs) = do
+		let chunkcount = f ++ Legacy.chunkCount
+		ifM (check chunkcount)
+			( do
+				chunks <- Legacy.listChunks f <$> readFile chunkcount
+				ifM (allM check chunks)
+					( a chunks , return False )
+			, do
+				chunks <- Legacy.probeChunks f check
+				if null chunks
+					then go fs
+					else a chunks
+			)
+withStoredFiles :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool
+withStoredFiles = withCheckedFiles doesFileExist
+
+{- Splits a ByteString into chunks and writes to dests, obeying configured
+ - chunk size (not to be confused with the L.ByteString chunk size). -}
+storeLegacyChunked :: MeterUpdate -> ChunkSize -> [FilePath] -> L.ByteString -> IO [FilePath]
+storeLegacyChunked _ _ [] _ = error "bad storeLegacyChunked call"
+storeLegacyChunked meterupdate chunksize alldests@(firstdest:_) b
+	| L.null b = do
+		-- always write at least one file, even for empty
+		L.writeFile firstdest b
+		return [firstdest]
+	| otherwise = storeLegacyChunked' meterupdate chunksize alldests (L.toChunks b) []
+storeLegacyChunked' :: MeterUpdate -> ChunkSize -> [FilePath] -> [S.ByteString] -> [FilePath] -> IO [FilePath]
+storeLegacyChunked' _ _ [] _ _ = error "ran out of dests"
+storeLegacyChunked' _ _  _ [] c = return $ reverse c
+storeLegacyChunked' meterupdate chunksize (d:dests) bs c = do
+	bs' <- withFile d WriteMode $
+		feed zeroBytesProcessed chunksize bs
+	storeLegacyChunked' meterupdate chunksize dests bs' (d:c)
+  where
+	feed _ _ [] _ = return []
+	feed bytes sz (l:ls) h = do
+		let len = S.length l
+		let s = fromIntegral len
+		if s <= sz || sz == chunksize
+			then do
+				S.hPut h l
+				let bytes' = addBytesProcessed bytes len
+				meterupdate bytes'
+				feed bytes' (sz - s) ls h
+			else return (l:ls)
+
+storeHelper :: (FilePath -> FilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO Bool
+storeHelper finalizer key storer tmpdir destdir = do
+	void $ liftIO $ tryIO $ createDirectoryIfMissing True tmpdir
+	Legacy.storeChunks key tmpdir destdir storer recorder finalizer
+  where
+	recorder f s = do
+		void $ tryIO $ allowWrite f
+		writeFile f s
+		void $ tryIO $ preventWrite f
+
+store :: ChunkSize -> (FilePath -> FilePath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO Bool
+store chunksize finalizer k b p = storeHelper finalizer k $ \dests ->
+	storeLegacyChunked p chunksize dests b
+
+{- Need to get a single ByteString containing every chunk.
+ - Done very innefficiently, by writing to a temp file.
+ - :/ This is legacy code..
+ -}
+retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> PrepareRetriever
+retrieve locations d basek = do
+	showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow."
+	tmpdir <- fromRepo $ gitAnnexTmpMiscDir
+	createAnnexDirectory tmpdir
+	let tmp = tmpdir </> keyFile basek ++ ".directorylegacy.tmp"
+	return $ Just $ \k -> do
+		void $ withStoredFiles d locations k $ \fs -> do
+			forM_ fs $
+				S.appendFile tmp <=< S.readFile
+			return True
+		b <- L.readFile tmp
+		nukeFile tmp
+		return b
+
+checkPresent :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> Annex (Either String Bool)
+checkPresent d locations k = liftIO $ catchMsgIO $
+	withStoredFiles d locations k $
+		-- withStoredFiles checked that it exists
+		const $ return True
diff --git a/Remote/Helper/ChunkedEncryptable.hs b/Remote/Helper/ChunkedEncryptable.hs
new file mode 100644
index 000000000..740da58b9
--- /dev/null
+++ b/Remote/Helper/ChunkedEncryptable.hs
@@ -0,0 +1,121 @@
+{- Remotes that support both chunking and encryption.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.ChunkedEncryptable (
+	chunkedEncryptableRemote,
+	PrepareStorer,
+	Storer,
+	PrepareRetriever,
+	Retriever,
+	storeKeyDummy,
+	retreiveKeyFileDummy,
+	module X
+) where
+
+import qualified Data.ByteString.Lazy as L
+
+import Common.Annex
+import Types.Remote
+import Crypto
+import Config.Cost
+import Utility.Metered
+import Remote.Helper.Chunked as X
+import Remote.Helper.Encryptable as X
+import Annex.Content
+import Annex.Exception
+
+-- Prepares to store a Key, and returns a Storer action if possible.
+type PrepareStorer = Key -> Annex (Maybe Storer)
+
+-- Stores a Key, which may be encrypted and/or a chunk key.
+type Storer = Key -> L.ByteString -> MeterUpdate -> IO Bool
+
+-- Prepares to retrieve a Key, and returns a Retriever action if possible.
+type PrepareRetriever = Key -> Annex (Maybe Retriever)
+
+-- Retrieves a Key, which may be encrypted and/or a chunk key.
+-- Throws exception if key is not present, or remote is not accessible.
+type Retriever = Key -> IO L.ByteString
+
+{- Modifies a base Remote to support both chunking and encryption.
+ -}
+chunkedEncryptableRemote
+	:: RemoteConfig
+	-> PrepareStorer
+	-> PrepareRetriever
+	-> Remote
+	-> Remote
+chunkedEncryptableRemote c preparestorer prepareretriever r = encr
+  where
+	encr = r
+		{ storeKey = \k _f p -> cip >>= storeKeyGen k p
+		, retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p
+		, retrieveKeyFileCheap = \k d -> cip >>= maybe
+			(retrieveKeyFileCheap r k d)
+			(\_ -> return False)
+		, removeKey = \k -> cip >>= removeKeyGen k
+		, hasKey = \k -> cip >>= hasKeyGen k
+		, cost = maybe
+			(cost r)
+			(const $ cost r + encryptedRemoteCostAdj)
+			(extractCipher c)
+		}
+	cip = cipherKey c
+	chunkconfig = chunkConfig c
+	gpgopts = getGpgEncParams encr
+
+	-- chunk, then encrypt, then feed to the storer
+	storeKeyGen k p enc = maybe (return False) go =<< preparestorer k
+	  where
+		go storer = sendAnnex k rollback $ \src ->
+			metered (Just p) k $ \p' ->
+				storeChunks (uuid r) chunkconfig k src p' $
+					storechunk storer
+		rollback = void $ removeKey encr k
+		storechunk storer k' b p' = case enc of
+			Nothing -> storer k' b p'
+			Just (cipher, enck) -> 
+				encrypt gpgopts cipher (feedBytes b) $
+					readBytes $ \encb ->
+						storer (enck k') encb p'
+
+	-- call retriever to get chunks; decrypt them; stream to dest file
+	retrieveKeyFileGen k dest p enc =
+		maybe (return False) go =<< prepareretriever k
+	  where
+	  	go retriever = metered (Just p) k $ \p' ->
+			bracketIO (openBinaryFile dest WriteMode) hClose $ \h ->
+				retrieveChunks retriever (uuid r) chunkconfig enck k p' $
+					sink h
+		sink h p' b = do
+			let write = meteredWrite p' h
+			case enc of
+				Nothing -> write b
+				Just (cipher, _) ->
+					decrypt cipher (feedBytes b) $
+						readBytes write
+		enck = maybe id snd enc
+
+	removeKeyGen k enc = removeChunks remover (uuid r) chunkconfig enck k
+	  where
+		enck = maybe id snd enc
+		remover = removeKey r
+
+	hasKeyGen k enc = hasKeyChunks checker (uuid r) chunkconfig enck k
+	  where
+		enck = maybe id snd enc
+		checker = hasKey r
+
+{- The base Remote that is provided to chunkedEncryptableRemote
+ - needs to have storeKey and retreiveKeyFile methods, but they are
+ - never actually used (since chunkedEncryptableRemote replaces
+ - them). Here are some dummy ones.
+ -}
+storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
+storeKeyDummy _ _ _ = return False
+retreiveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
+retreiveKeyFileDummy _ _ _ _ = return False
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
index c450a1084..9da5e641d 100644
--- a/Remote/Helper/Encryptable.hs
+++ b/Remote/Helper/Encryptable.hs
@@ -70,10 +70,8 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
                 -- remotes (while being backward-compatible).
 		[ "keyid", "keyid+", "keyid-", "highRandomQuality" ]
 
-{- Modifies a Remote to support encryption.
- -
- - Two additional functions must be provided by the remote,
- - to support storing and retrieving encrypted content. -}
+{- Modifies a Remote to support encryption. -}
+-- TODO: deprecated
 encryptableRemote
 	:: RemoteConfig
 	-> ((Cipher, Key) -> Key -> MeterUpdate -> Annex Bool)
@@ -83,23 +81,30 @@ encryptableRemote
 encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r = r
 	{ storeKey = \k f p -> cip k >>= maybe
 		(storeKey r k f p)
-		(\enck -> storeKeyEncrypted enck k p)
+		(\v -> storeKeyEncrypted v k p)
 	, retrieveKeyFile = \k f d p -> cip k >>= maybe
 		(retrieveKeyFile r k f d p)
-		(\enck -> retrieveKeyFileEncrypted enck k d p)
+		(\v -> retrieveKeyFileEncrypted v k d p)
 	, retrieveKeyFileCheap = \k d -> cip k >>= maybe
 		(retrieveKeyFileCheap r k d)
 		(\_ -> return False)
-	, removeKey = withkey $ removeKey r
-	, hasKey = withkey $ hasKey r
+	, removeKey = \k -> cip k >>= maybe
+		(removeKey r k)
+		(\(_, enckey) -> removeKey r enckey)
+	, hasKey = \k -> cip k >>= maybe
+		(hasKey r k)
+		(\(_, enckey) -> hasKey r enckey)
 	, cost = maybe
 		(cost r)
 		(const $ cost r + encryptedRemoteCostAdj)
 		(extractCipher c)
 	}
   where
-	withkey a k = cip k >>= maybe (a k) (a . snd)
-	cip = cipherKey c
+	cip k = do
+		v <- cipherKey c
+		return $ case v of
+			Nothing -> Nothing
+			Just (cipher, enck) -> Just (cipher, enck k)
 
 {- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex
  - state. -}
@@ -132,11 +137,11 @@ embedCreds c
 	| isJust (M.lookup "cipherkeys" c) && isJust (M.lookup "cipher" c) = True
 	| otherwise = False
 
-{- Gets encryption Cipher, and encrypted version of Key. -}
-cipherKey :: RemoteConfig -> Key -> Annex (Maybe (Cipher, Key))
-cipherKey c k = fmap make <$> remoteCipher c
+{- Gets encryption Cipher, and key encryptor. -}
+cipherKey :: RemoteConfig -> Annex (Maybe (Cipher, EncKey))
+cipherKey c = fmap make <$> remoteCipher c
   where
-	make ciphertext = (ciphertext, encryptKey mac ciphertext k)
+	make ciphertext = (ciphertext, encryptKey mac ciphertext)
 	mac = fromMaybe defaultMac $ M.lookup "mac" c >>= readMac
 
 {- Stores an StorableCipher in a remote's configuration. -}