WebDAV: Avoid buffering whole file in memory when downloading.

httpBodyRetriever will later also be used by S3

This commit was sponsored by Ethan Aubin.

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

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

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

debian/changelog

@@ -18,7 +18,8 @@ git-annex (5.20140718) UNRELEASED; urgency=medium
   * Display exception message when a transfer fails due to an exception.
   * WebDAV: Sped up by avoiding making multiple http connections
     when storing a file.
-  * WebDAV: Avoid buffering whole file in memory when uploading.
+  * WebDAV: Avoid buffering whole file in memory when uploading and
+    downloading.
   * WebDAV: Dropped support for DAV before 1.0.
   * testremote: New command to test uploads/downloads to a remote.
   * Dropping an object from a bup special remote now deletes the git branch