7 files changed, 43 insertions, 41 deletions
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 06679c4b8..44ea8c7d8 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -8,6 +8,7 @@
 module Remote.Bup (remote) where
 
 import qualified Data.Map as M
+import qualified Data.ByteString.Lazy as L
 import Data.ByteString.Lazy.UTF8 (fromString)
 
 import Common.Annex
@@ -127,12 +128,12 @@ store r buprepo = byteStorer $ \k b p -> do
 		return True
 
 retrieve :: BupRepo -> Retriever
-retrieve buprepo = fileRetriever $ \d k _p ->
-	liftIO $ withFile d WriteMode $ \h -> do
-		let params = bupParams "join" buprepo [Param $ bupRef k]
-		let p = proc "bup" (toCommand params)
-		(_, _, _, pid) <- createProcess $ p { std_out = UseHandle h }
-		forceSuccessProcess p pid
+retrieve buprepo = byteRetriever $ \k sink -> do
+	let params = bupParams "join" buprepo [Param $ bupRef k]
+	let p = proc "bup" (toCommand params)
+	(_, Just h, _, pid) <- liftIO $ createProcess $ p { std_out = CreatePipe }
+	liftIO (hClose h >> forceSuccessProcess p pid)
+		`after` (sink =<< liftIO (L.hGetContents h))
 
 retrieveCheap :: BupRepo -> Key -> FilePath -> Annex Bool
 retrieveCheap _ _ _ = return False
diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs
index 365506a22..bc4755a81 100644
--- a/Remote/Ddar.hs
+++ b/Remote/Ddar.hs
@@ -10,8 +10,8 @@ module Remote.Ddar (remote) where
 
 import Control.Exception
 import qualified Data.Map as M
+import qualified Data.ByteString.Lazy as L
 import System.IO.Error
-import System.Process
 
 import Data.String.Utils
 import Common.Annex
@@ -127,12 +127,12 @@ ddarExtractRemoteCall ddarrepo k =
 	ddarRemoteCall ddarrepo 'x' [Param "--force-stdout", Param $ key2file k]
 
 retrieve :: DdarRepo -> Retriever
-retrieve ddarrepo = fileRetriever $ \d k _p -> do
+retrieve ddarrepo = byteRetriever $ \k sink -> do
 	(cmd, params) <- ddarExtractRemoteCall ddarrepo k
-	liftIO $ withFile d WriteMode $ \h -> do
-		let p = (proc cmd $ toCommand params){ std_out = UseHandle h }
-		(_, _, _, pid) <- Common.Annex.createProcess p
-		forceSuccessProcess p pid
+	let p = (proc cmd $ toCommand params) { std_out = CreatePipe }
+	(_, Just h, _, pid) <- liftIO $ createProcess p
+	liftIO (hClose h >> forceSuccessProcess p pid)
+		`after` (sink =<< liftIO (L.hGetContents h))
 
 retrieveCheap :: Key -> FilePath -> Annex Bool
 retrieveCheap _ _ = return False
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index a87987529..78d30b1a1 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -136,8 +136,8 @@ store d chunkconfig k b p = liftIO $ do
 
 retrieve :: FilePath -> ChunkConfig -> Preparer Retriever
 retrieve d (LegacyChunks _) = Legacy.retrieve locations d
-retrieve d _ = simplyPrepare $ byteRetriever $ \k ->
-	liftIO $ L.readFile =<< getLocation d k
+retrieve d _ = simplyPrepare $ byteRetriever $ \k sink ->
+	sink =<< liftIO (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 5c200570c..a19868802 100644
--- a/Remote/Directory/LegacyChunked.hs
+++ b/Remote/Directory/LegacyChunked.hs
@@ -94,14 +94,14 @@ retrieve locations d basek a = do
 	tmpdir <- fromRepo $ gitAnnexTmpMiscDir
 	createAnnexDirectory tmpdir
 	let tmp = tmpdir </> keyFile basek ++ ".directorylegacy.tmp"
-	a $ Just $ byteRetriever $ \k -> liftIO $ do
-		void $ withStoredFiles d locations k $ \fs -> do
+	a $ Just $ byteRetriever $ \k sink -> do
+		liftIO $ void $ withStoredFiles d locations k $ \fs -> do
 			forM_ fs $
 				S.appendFile tmp <=< S.readFile
 			return True
-		b <- L.readFile tmp
-		nukeFile tmp
-		return b
+		b <- liftIO $ L.readFile tmp
+		liftIO $ nukeFile tmp
+		sink b
 
 checkPresent :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> Annex (Either String Bool)
 checkPresent d locations k = liftIO $ catchMsgIO $
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 9b428bd80..592a7db1f 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -20,7 +20,6 @@ import Config.Cost
 import Remote.Helper.Special
 import Remote.Helper.ChunkedEncryptable
 import qualified Remote.Helper.AWS as AWS
-import Crypto
 import Creds
 import Utility.Metered
 import qualified Annex
@@ -120,11 +119,10 @@ store r k b p = go =<< glacierEnv c u
 				return True
 
 prepareRetrieve :: Remote -> Preparer Retriever
-prepareRetrieve r = simplyPrepare $ fileRetriever $ \d k p ->
-	retrieve r k (readBytes (meteredWriteFile p d))
+prepareRetrieve = simplyPrepare . byteRetriever . retrieve
 
-retrieve :: Remote -> Key -> (Handle -> IO ()) -> Annex ()
-retrieve r k reader = go =<< glacierEnv c u
+retrieve :: Remote -> Key -> (L.ByteString -> Annex Bool) -> Annex Bool
+retrieve r k sink = go =<< glacierEnv c u
   where
 	c = config r
 	u = uuid r
@@ -138,17 +136,21 @@ retrieve r k reader = go =<< glacierEnv c u
 	go Nothing = error "cannot retrieve from glacier"
 	go (Just e) = do
 		let cmd = (proc "glacier" (toCommand params)) { env = Just e }
-		ok <- liftIO $ catchBoolIO $
-			withHandle StdoutHandle createProcessSuccess cmd $ \h ->
-				ifM (hIsEOF h)
-					( return False
-					, do
-						reader h
-						return True
-					)
+		(_, Just h, _, pid) <- liftIO $ createProcess cmd
+		-- Glacier cannot store empty files, so if the output is
+		-- empty, the content is not available yet.
+		ok <- ifM (liftIO $ hIsEOF h)
+			( return False
+			, sink =<< liftIO (L.hGetContents h)
+			)
+		liftIO $ hClose h
+		liftIO $ forceSuccessProcess cmd pid
 		unless ok $ do
 			showLongNote "Recommend you wait up to 4 hours, and then run this command again."
-			error "not yet available"
+		return ok
+
+retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
+retrieveCheap _ _ _ = return False
 
 remove :: Remote -> Key -> Annex Bool
 remove r k = glacierAction r
@@ -159,9 +161,6 @@ remove r k = glacierAction r
 	, Param $ archive r k
 	]
 
-retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
-retrieveCheap _ _ _ = return False
-
 checkPresent :: Remote -> Key -> Annex (Either String Bool)
 checkPresent r k = do
 	showAction $ "checking " ++ name r
diff --git a/Remote/Helper/ChunkedEncryptable.hs b/Remote/Helper/ChunkedEncryptable.hs
index e60771551..9c6ba98a2 100644
--- a/Remote/Helper/ChunkedEncryptable.hs
+++ b/Remote/Helper/ChunkedEncryptable.hs
@@ -77,9 +77,11 @@ fileRetriever a k m callback = do
 	a f k m
 	callback (FileContent f)
 
--- A Retriever that generates a L.ByteString containing the Key's content.
-byteRetriever :: (Key -> Annex L.ByteString) -> Retriever
-byteRetriever a k _m callback = callback =<< (ByteContent <$> a k)
+-- A Retriever that generates a lazy ByteString containing the Key's
+-- content, and passes it to a callback action which will fully consume it
+-- before returning.
+byteRetriever :: (Key -> (L.ByteString -> Annex Bool) -> Annex Bool) -> Retriever
+byteRetriever a k _m callback = a k (callback . ByteContent)
 
 {- The base Remote that is provided to chunkedEncryptableRemote
  - needs to have storeKey and retreiveKeyFile methods, but they are
diff --git a/Remote/S3.hs b/Remote/S3.hs
index ed9122cab..68d8ee4bf 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -147,9 +147,9 @@ store (conn, bucket) r k p file = do
 
 prepareRetrieve :: Remote -> Preparer Retriever
 prepareRetrieve r = resourcePrepare (const $ s3Action r False) $ \(conn, bucket) ->
-	byteRetriever $ \k ->
+	byteRetriever $ \k sink ->
 		liftIO (getObject conn $ bucketKey r bucket k)
-			>>= either s3Error (return . obj_data)
+			>>= either s3Error (sink . obj_data)
 
 retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
 retrieveCheap _ _ _ = return False