WebDAV: Avoid buffering whole file in memory when downloading.

httpBodyRetriever will later also be used by S3

This commit was sponsored by Ethan Aubin.

3 files changed, 35 insertions, 22 deletions

diff --git a/Remote/Helper/Http.hs b/Remote/Helper/Http.hs
index 945e5cd99..d4882b8c8 100644
--- a/Remote/Helper/Http.hs
+++ b/Remote/Helper/Http.hs
@@ -11,7 +11,7 @@ import Common.Annex
 import Types.StoreRetrieve
 import Utility.Metered
 import Remote.Helper.Special
-import Network.HTTP.Client (RequestBody(..))
+import Network.HTTP.Client (RequestBody(..), Response, responseBody, BodyReader)
 
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString as S
@@ -35,5 +35,19 @@ httpStorer a = fileStorer $ \k f m -> do
 	pop [] = ([], S.empty)
 	pop (c:cs) = (cs, c)
 
---httpRetriever :: (Key -> Annex Response) -> Retriever
---httpRetriever a = byteRetriever $ \k sink 
+-- Reads the http body and stores it to the specified file, updating the
+-- meter as it goes.
+httpBodyRetriever :: FilePath -> MeterUpdate -> Response BodyReader -> IO ()
+httpBodyRetriever dest meterupdate resp = 
+	bracket (openBinaryFile dest WriteMode) hClose (go zeroBytesProcessed)
+  where
+	reader = responseBody resp
+	go sofar h = do
+		b <- reader
+		if S.null b
+			then return ()
+			else do
+				let sofar' = addBytesProcessed sofar $ S.length b
+				S.hPut h b
+				meterupdate sofar'
+				go sofar' h
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index e7c08c800..2c621b633 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -97,7 +97,7 @@ store (LegacyChunks chunksize) (Just dav) = fileStorer $ \k f p -> liftIO $
 	withMeteredFile f p $ storeLegacyChunked chunksize k dav
 store _  (Just dav) = httpStorer $ \k reqbody -> liftIO $ goDAV dav $ do
 	let tmp = keyTmpLocation k
-	let dest = keyLocation k ++ keyFile k
+	let dest = keyLocation k
 	void $ mkColRecursive tmpDir
 	inLocation tmp $
 		putContentM' (contentType, reqbody)
@@ -117,16 +117,10 @@ retrieve :: ChunkConfig -> Maybe DavHandle -> Retriever
 retrieve _ Nothing = error "unable to connect"
 retrieve (LegacyChunks _) (Just dav) = retrieveLegacyChunked dav
 retrieve _ (Just dav) = fileRetriever $ \d k p -> liftIO $
-	meteredWriteFile p d =<< getDAV dav (keyLocation k ++ keyFile k)
-
-getDAV :: DavHandle -> DavLocation -> IO L.ByteString
-getDAV dav l = do
-	mb <- goDAV dav $ safely $
-		inLocation l $
-			snd <$> getContentM
-	case mb of
-		Nothing -> error "download failed"
-		Just b -> return b
+	goDAV dav $
+		inLocation (keyLocation k) $
+			withContentM $
+				httpBodyRetriever d p
 
 remove :: Maybe DavHandle -> Remover
 remove Nothing _ = return False
@@ -134,7 +128,7 @@ remove (Just dav) k = liftIO $ do
 	-- Delete the key's whole directory, including any
 	-- legacy chunked files, etc, in a single action.
 	ret <- goDAV dav $ safely $
-		inLocation (keyLocation k) delContentM
+		inLocation (keyDir k) delContentM
 	return (isJust ret)
 
 checkKey :: Remote -> ChunkConfig -> Maybe DavHandle -> CheckPresent
@@ -145,7 +139,7 @@ checkKey r chunkconfig (Just dav) k = do
 		LegacyChunks _ -> checkKeyLegacyChunked dav k
 		_ -> do
 			v <- liftIO $ goDAV dav $
-				existsDAV (keyLocation k ++ keyFile k)
+				existsDAV (keyLocation k)
 			either error return v
 
 configUrl :: Remote -> Maybe URLString
@@ -315,13 +309,15 @@ storeLegacyChunked chunksize k dav b =
 		finalizeStore (baseURL dav) tmp' (fromJust $ locationParent dest')
 
 	tmp = keyTmpLocation k
-	dest = keyLocation k ++ keyFile k
+	dest = keyLocation k
 
 retrieveLegacyChunked :: DavHandle -> Retriever
 retrieveLegacyChunked dav = fileRetriever $ \d k p -> liftIO $
 	withStoredFilesLegacyChunked k dav onerr $ \locs ->
-		Legacy.meteredWriteFileChunks p d locs $ 
-			getDAV dav
+		Legacy.meteredWriteFileChunks p d locs $ \l ->
+			goDAV dav $
+				inLocation l $
+					snd <$> getContentM
   where
 	onerr = error "download failed"
 
@@ -365,4 +361,4 @@ withStoredFilesLegacyChunked k dav onerr a = do
 				then onerr chunkcount
 				else a chunks
   where
-	keyloc = keyLocation k ++ keyFile k
+	keyloc = keyLocation k
diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs
index 3b52f3a64..33c3aa079 100644
--- a/Remote/WebDAV/DavLocation.hs
+++ b/Remote/WebDAV/DavLocation.hs
@@ -29,8 +29,8 @@ inLocation :: (MonadIO m) => DavLocation -> DAVT m a -> DAVT m a
 inLocation d = inDAVLocation (</> d)
 
 {- The directory where files(s) for a key are stored. -}
-keyLocation :: Key -> DavLocation
-keyLocation k = addTrailingPathSeparator $ hashdir </> keyFile k
+keyDir :: Key -> DavLocation
+keyDir k = addTrailingPathSeparator $ hashdir </> keyFile k
   where
 #ifndef mingw32_HOST_OS
 	hashdir = hashDirLower k
@@ -38,6 +38,9 @@ keyLocation k = addTrailingPathSeparator $ hashdir </> keyFile k
 	hashdir = replace "\\" "/" (hashDirLower k)
 #endif
 
+keyLocation :: Key -> DavLocation
+keyLocation k = keyDir k ++ keyFile k
+
 {- Where we store temporary data for a key as it's being uploaded. -}
 keyTmpLocation :: Key -> DavLocation
 keyTmpLocation = addTrailingPathSeparator . tmpLocation . keyFile