summaryrefslogtreecommitdiff
path: root/P2P
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2016-12-08 18:26:03 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2016-12-08 18:42:52 -0400
commitc5f29d780863b010aa2893bfa3935588d22b7e13 (patch)
treecb84e106b41bd85e2e3cb42f9f86258caf6a0800 /P2P
parente983b6e352b48233f9526497b4317950d0cfa92f (diff)
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.
Diffstat (limited to 'P2P')
-rw-r--r--P2P/Annex.hs26
-rw-r--r--P2P/Protocol.hs10
2 files changed, 20 insertions, 16 deletions
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