diff options
| author |  Joey Hess <joey@kitenet.net> | 2012-11-10 01:34:03 -0400 |
|---|---|---|
| committer | Joey Hess <joey@kitenet.net> | 2012-11-10 01:34:03 -0400 |
| commit | cf18a864ff07942475ed1c24743d0985e3bec642 (patch) | |
| tree | fd75862dd87eb7514a645a02dd4828db8baec5f6 | |
| parent | 9878bea94e465333bbfb32ae7bb410d59014749c (diff) | |
fix deferring of CanPush, and stop deferring StartingPush
| -rw-r--r-- | Assistant/NetMessager.hs | 10 | ||||
| -rw-r--r-- | 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) |