better Preparer interface

This will allow things like WebDAV to opean a single persistent connection
and reuse it for all the chunked data.

The crazy types allow for some nice code reuse.

3 files changed, 41 insertions, 29 deletions

diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 2ebf608cb..cb7553fe2 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE Rank2Types #-}
 
 module Remote.Directory (remote) where
 
@@ -106,11 +107,10 @@ tmpDir d k = addTrailingPathSeparator $ d </> "tmp" </> keyFile k
 
 {- Check if there is enough free disk space in the remote's directory to
  - store the key. Note that the unencrypted key size is checked. -}
-prepareStore :: FilePath -> ChunkConfig -> PrepareStorer
-prepareStore d chunkconfig k = ifM (checkDiskSpace (Just d) k 0)
-	( return $ Just (store d chunkconfig)
-	, return Nothing
-	)
+prepareStore :: FilePath -> ChunkConfig -> Preparer Storer
+prepareStore d chunkconfig = checkPrepare
+	(\k -> checkDiskSpace (Just d) k 0)
+	(store d chunkconfig)
 
 store :: FilePath -> ChunkConfig -> Storer
 store d chunkconfig k b p = do
@@ -135,9 +135,9 @@ store d chunkconfig k b p = do
 			mapM_ preventWrite =<< dirContents dest
 			preventWrite dest
 
-retrieve :: FilePath -> ChunkConfig -> PrepareRetriever
-retrieve d (LegacyChunks _) basek = Legacy.retrieve locations d basek
-retrieve d _ _ = return $ Just $ \k -> L.readFile =<< getLocation d k
+retrieve :: FilePath -> ChunkConfig -> Preparer Retriever
+retrieve d (LegacyChunks _) = Legacy.retrieve locations d
+retrieve d _ = simplyPrepare $ \k -> L.readFile =<< getLocation d k
 
 retrieveCheap :: FilePath -> ChunkConfig -> Key -> FilePath -> Annex Bool
 -- no cheap retrieval possible for chunks
diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs
index df6d94d04..c7b8ad52c 100644
--- a/Remote/Directory/LegacyChunked.hs
+++ b/Remote/Directory/LegacyChunked.hs
@@ -7,6 +7,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE Rank2Types #-}
+
 module Remote.Directory.LegacyChunked where
 
 import qualified Data.ByteString.Lazy as L
@@ -88,13 +90,13 @@ store chunksize finalizer k b p = storeHelper finalizer k $ \dests ->
  - Done very innefficiently, by writing to a temp file.
  - :/ This is legacy code..
  -}
-retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> PrepareRetriever
-retrieve locations d basek = do
+retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> Preparer Retriever
+retrieve locations d basek a = 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
+	a $ Just $ \k -> do
 		void $ withStoredFiles d locations k $ \fs -> do
 			forM_ fs $
 				S.appendFile tmp <=< S.readFile
diff --git a/Remote/Helper/ChunkedEncryptable.hs b/Remote/Helper/ChunkedEncryptable.hs
index cfa92406e..ac8917851 100644
--- a/Remote/Helper/ChunkedEncryptable.hs
+++ b/Remote/Helper/ChunkedEncryptable.hs
@@ -5,12 +5,15 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE Rank2Types #-}
+
 module Remote.Helper.ChunkedEncryptable (
-	chunkedEncryptableRemote,
-	PrepareStorer,
+	Preparer,
+	simplyPrepare,
+	checkPrepare,
 	Storer,
-	PrepareRetriever,
 	Retriever,
+	chunkedEncryptableRemote,
 	storeKeyDummy,
 	retreiveKeyFileDummy,
 	module X
@@ -28,18 +31,23 @@ import Remote.Helper.Encryptable as X
 import Annex.Content
 import Annex.Exception
 
--- Prepares to store a Key, and returns a Storer action if possible.
--- May throw exceptions.
-type PrepareStorer = Key -> Annex (Maybe Storer)
+-- Prepares for and then runs an action that will act on a Key,
+-- passing it a helper when the preparation is successful.
+type Preparer helper = forall a. Key -> (Maybe helper -> Annex a) -> Annex a
+
+simplyPrepare :: helper -> Preparer helper
+simplyPrepare helper _ a = a $ Just helper
+
+checkPrepare :: (Key -> Annex Bool) -> helper -> Preparer helper
+checkPrepare checker helper k a = ifM (checker k)
+	( a (Just helper)
+	, a Nothing
+	)
 
 -- Stores a Key, which may be encrypted and/or a chunk key.
 -- May throw exceptions.
 type Storer = Key -> L.ByteString -> MeterUpdate -> IO Bool
 
--- Prepares to retrieve a Key, and returns a Retriever action if possible.
--- May throw exceptions.
-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
@@ -48,8 +56,8 @@ type Retriever = Key -> IO L.ByteString
  -}
 chunkedEncryptableRemote
 	:: RemoteConfig
-	-> PrepareStorer
-	-> PrepareRetriever
+	-> Preparer Storer
+	-> Preparer Retriever
 	-> Remote
 	-> Remote
 chunkedEncryptableRemote c preparestorer prepareretriever r = encr
@@ -74,13 +82,14 @@ chunkedEncryptableRemote c preparestorer prepareretriever r = encr
 	safely a = catchNonAsyncAnnex a (\e -> warning (show e) >> return False)
 
 	-- chunk, then encrypt, then feed to the storer
-	storeKeyGen k p enc = safely $
-		maybe (return False) go =<< preparestorer k
+	storeKeyGen k p enc =
+		safely $ preparestorer k $ safely . go
 	  where
-		go storer = sendAnnex k rollback $ \src ->
+		go (Just storer) = sendAnnex k rollback $ \src ->
 			metered (Just p) k $ \p' ->
 				storeChunks (uuid r) chunkconfig k src p' $
 					storechunk storer
+		go Nothing = return False
 		rollback = void $ removeKey encr k
 		storechunk storer k' b p' = case enc of
 			Nothing -> storer k' b p'
@@ -90,13 +99,14 @@ chunkedEncryptableRemote c preparestorer prepareretriever r = encr
 						storer (enck k') encb p'
 
 	-- call retriever to get chunks; decrypt them; stream to dest file
-	retrieveKeyFileGen k dest p enc = safely $
-		maybe (return False) go =<< prepareretriever k
+	retrieveKeyFileGen k dest p enc =
+		safely $ prepareretriever k $ safely . go
 	  where
-	  	go retriever = metered (Just p) k $ \p' ->
+	  	go (Just retriever) = metered (Just p) k $ \p' ->
 			bracketIO (openBinaryFile dest WriteMode) hClose $ \h ->
 				retrieveChunks retriever (uuid r) chunkconfig enck k p' $
 					sink h
+		go Nothing = return False
 		sink h p' b = do
 			let write = meteredWrite p' h
 			case enc of