WebDAV: Avoid buffering whole file in memory when uploading.

The httpStorer will later also be used by S3.

This commit was sponsored by Torbjørn Thorsen.

Remote/Helper/Http.hs

@@ -0,0 +1,39 @@
+{- helpers for remotes using http
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.Http where
+
+import Common.Annex
+import Types.StoreRetrieve
+import Utility.Metered
+import Remote.Helper.Special
+import Network.HTTP.Client (RequestBody(..))
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString as S
+import Control.Concurrent
+
+-- A storer that expects to be provided with a http RequestBody containing
+-- the content to store.
+--
+-- Implemented as a fileStorer, so that the content can be streamed
+-- from the file in constant space.
+httpStorer :: (Key -> RequestBody -> Annex Bool) -> Storer
+httpStorer a = fileStorer $ \k f m -> do
+	size <- liftIO $ (fromIntegral . fileSize <$> getFileStatus f :: IO Integer)
+	let streamer sink = withMeteredFile f m $ \b -> do
+		mvar <- newMVar $ L.toChunks b
+		let getnextchunk = modifyMVar mvar $ pure . pop
+		sink getnextchunk
+	let body = RequestBodyStream (fromInteger size) streamer
+	a k body
+  where
+	pop [] = ([], S.empty)
+	pop (c:cs) = (cs, c)
+
+--httpRetriever :: (Key -> Annex Response) -> Retriever
+--httpRetriever a = byteRetriever $ \k sink 

Remote/WebDAV.hs

@@ -25,6 +25,7 @@ import qualified Git
 import Config
 import Config.Cost
 import Remote.Helper.Special
+import Remote.Helper.Http
 import qualified Remote.Helper.Chunked.Legacy as Legacy
 import Creds
 import Utility.Metered
@@ -93,29 +94,29 @@ prepareDAV = resourcePrepare . const . withDAVHandle
 
 store :: ChunkConfig -> Maybe DavHandle -> Storer
 store _ Nothing = byteStorer $ \_k _b _p -> return False
-store chunkconfig (Just dav) = fileStorer $ \k f p -> liftIO $
+store (LegacyChunks chunksize) (Just dav) = fileStorer $ \k f p -> liftIO $
-	withMeteredFile f p $ storeHelper chunkconfig k dav
+	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
+	void $ mkColRecursive tmpDir
+	inLocation tmp $
+		putContentM' (contentType, reqbody)
+	finalizeStore (baseURL dav) tmp dest
+	return True
 
-storeHelper :: ChunkConfig -> Key -> DavHandle -> L.ByteString -> IO Bool
+storeLegacyChunked :: ChunkSize -> Key -> DavHandle -> L.ByteString -> IO Bool
-storeHelper chunkconfig k dav b = do
+storeLegacyChunked chunksize k dav b =
-	case chunkconfig of
+	Legacy.storeChunks k tmp dest storer recorder finalizer
-		LegacyChunks chunksize -> do
-			let storehttp l b' = do
-				void $ goDAV dav $ do
-					maybe noop (void . mkColRecursive) (locationParent l)
-					inLocation l $ putContentM (contentType, b')
-			let storer locs = Legacy.storeChunked chunksize locs storehttp b
-			let recorder l s = storehttp l (L8.fromString s)
-			let finalizer tmp' dest' = goDAV dav $ 
-				finalizeStore (baseURL dav) tmp' (fromJust $ locationParent dest')
-			Legacy.storeChunks k tmp dest storer recorder finalizer
-		_ -> goDAV dav $ do
-			void $ mkColRecursive tmpDir
-			inLocation tmp $
-				putContentM (contentType, b)
-			finalizeStore (baseURL dav) tmp dest
-			return True
   where
+	storehttp l b' = void $ goDAV dav $ do
+		maybe noop (void . mkColRecursive) (locationParent l)
+		inLocation l $ putContentM (contentType, b')
+	storer locs = Legacy.storeChunked chunksize locs storehttp b
+	recorder l s = storehttp l (L8.fromString s)
+	finalizer tmp' dest' = goDAV dav $ 
+		finalizeStore (baseURL dav) tmp' (fromJust $ locationParent dest')
+
 	tmp = keyTmpLocation k
 	dest = keyLocation k ++ keyFile k
 

debian/changelog

@@ -18,6 +18,7 @@ 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: Dropped support for DAV before 0.8.
   * testremote: New command to test uploads/downloads to a remote.
   * Dropping an object from a bup special remote now deletes the git branch