From cf18a864ff07942475ed1c24743d0985e3bec642 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 10 Nov 2012 01:34:03 -0400 Subject: fix deferring of CanPush, and stop deferring StartingPush --- Assistant/NetMessager.hs | 10 ++++------ Assistant/Types/NetMessager.hs | 5 +++++ 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/Assistant/NetMessager.hs b/Assistant/NetMessager.hs index 8fac55c8a..ab1c6aabe 100644 --- a/Assistant/NetMessager.hs +++ b/Assistant/NetMessager.hs @@ -61,8 +61,8 @@ runPush v handledeferred a = do <~> handledeferred m {- While a push is running, matching push messages are put into - - netMessagesPush, while others go to netMessagesDeferredPush. To avoid - - bloating memory, only PushRequest and StartingPush messages are + - netMessagesPush, while others go to netMessagesDeferredPush. + - To avoid bloating memory, only messages that initiate pushes are - deferred. - - When no push is running, returns False. @@ -82,10 +82,8 @@ queueNetPushMessage m = do writeTChan (netMessagesPush nm) m return True | otherwise = do - case m of - PushRequest _ -> defer nm - StartingPush _ -> defer nm - _ -> noop + when (isPushInitiationMessage m) $ + defer nm return True defer nm = do s <- takeTMVar (netMessagesDeferredPush nm) diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs index 3d7bb4d04..cd96a5523 100644 --- a/Assistant/Types/NetMessager.hs +++ b/Assistant/Types/NetMessager.hs @@ -53,6 +53,11 @@ getClientID (ReceivePackOutput cid _) = Just cid getClientID (SendPackOutput cid _) = Just cid getClientID (ReceivePackDone cid _) = Just cid +isPushInitiationMessage :: NetMessage -> Bool +isPushInitiationMessage (CanPush _) = True +isPushInitiationMessage (PushRequest _) = True +isPushInitiationMessage _ = False + data NetMessager = NetMessager -- outgoing messages { netMessages :: TChan (NetMessage) -- cgit v1.2.3