From c5f29d780863b010aa2893bfa3935588d22b7e13 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 8 Dec 2016 18:26:03 -0400
Subject: fix memory leak

I'm unsure why this fixed it, but it did. Seems to suggest that the
memory leak is not due to a bug in my code, but that ghc didn't manage
to take full advantage of laziness, or was failing to gc something it
could have.
---
 P2P/Annex.hs    | 26 +++++++++++++++-----------
 P2P/Protocol.hs | 10 +++++-----
 2 files changed, 20 insertions(+), 16 deletions(-)

(limited to 'P2P')

diff --git a/P2P/Annex.hs b/P2P/Annex.hs
index d55d69bdb..3b95c8c02 100644
--- a/P2P/Annex.hs
+++ b/P2P/Annex.hs
@@ -72,15 +72,15 @@ runLocal runmode runner a = case a of
 					Right b -> runner (next b)
 			Right Nothing -> return (Left "content not available")
 			Left e -> return (Left (show e))
-	StoreContent k af o l b next -> do
+	StoreContent k af o l getb next -> do
 		ok <- flip catchNonAsync (const $ return False) $
 			transfer download k af $
 				getViaTmp AlwaysVerify k $ \tmp ->
-					unVerified $ storefile tmp o l b
+					unVerified $ storefile tmp o l getb
 		runner (next ok)
-	StoreContentTo dest o l b next -> do
+	StoreContentTo dest o l getb next -> do
 		ok <- flip catchNonAsync (const $ return False) $
-			storefile dest o l b
+			storefile dest o l getb
 		runner (next ok)
 	SetPresent k u next -> do
 		v <- tryNonAsync $ logChange k u InfoPresent
@@ -120,10 +120,14 @@ runLocal runmode runner a = case a of
 		-- Transfer logs are updated higher in the stack when
 		-- a client.
 		Client -> ta
-	storefile dest (Offset o) (Len l) b = liftIO $ do
-		withBinaryFile dest ReadWriteMode $ \h -> do
-			when (o /= 0) $
-				hSeek h AbsoluteSeek o
-			L.hPut h b
-		sz <- getFileSize dest
-		return (toInteger sz == l + o)
+	storefile dest (Offset o) (Len l) getb = do
+		v <- runner getb
+		case v of
+			Right b -> liftIO $ do
+				withBinaryFile dest ReadWriteMode $ \h -> do
+					when (o /= 0) $
+						hSeek h AbsoluteSeek o
+					L.hPut h b
+				sz <- liftIO $ getFileSize dest
+				return (toInteger sz == l + o)
+			Left e -> error e
diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs
index 8aabb37d7..5d6c6fcc5 100644
--- a/P2P/Protocol.hs
+++ b/P2P/Protocol.hs
@@ -200,7 +200,7 @@ data LocalF c
 	| ReadContent Key AssociatedFile Offset (L.ByteString -> c)
 	-- ^ Lazily reads the content of a key. Note that the content
 	-- may change while it's being sent.
-	| StoreContent Key AssociatedFile Offset Len L.ByteString (Bool -> c)
+	| StoreContent Key AssociatedFile Offset Len (Proto L.ByteString) (Bool -> c)
 	-- ^ Stores content to the key's temp file starting at an offset.
 	-- Once the whole content of the key has been stored, moves the
 	-- temp file into place as the content of the key, and returns True.
@@ -208,7 +208,7 @@ data LocalF c
 	-- Note: The ByteString may not contain the entire remaining content
 	-- of the key. Only once the temp file size == Len has the whole
 	-- content been transferred.
-	| StoreContentTo FilePath Offset Len L.ByteString (Bool -> c)
+	| StoreContentTo FilePath Offset Len (Proto L.ByteString) (Bool -> c)
 	-- ^ Stores the content to a temp file starting at an offset.
 	-- Once the whole content of the key has been stored, returns True.
 	--
@@ -388,7 +388,7 @@ sendContent key af offset@(Offset n) p = do
 	net $ sendBytes len content p'
 	checkSuccess
 
-receiveContent :: MeterUpdate -> Local Len -> (Offset -> Len -> L.ByteString -> Local Bool) -> (Offset -> Message) -> Proto Bool
+receiveContent :: MeterUpdate -> Local Len -> (Offset -> Len -> Proto L.ByteString -> Local Bool) -> (Offset -> Message) -> Proto Bool
 receiveContent p sizer storer mkmsg = do
 	Len n <- local sizer
 	let p' = offsetMeterUpdate p (toBytesProcessed n)
@@ -397,8 +397,8 @@ receiveContent p sizer storer mkmsg = do
 	r <- net receiveMessage
 	case r of
 		DATA len -> do
-			ok <- local . storer offset len
-				=<< net (receiveBytes len p')
+			ok <- local $ storer offset len
+				(net (receiveBytes len p'))
 			sendSuccess ok
 			return ok
 		_ -> do
-- 
cgit v1.2.3