fix deferring of CanPush, and stop deferring StartingPush
This commit is contained in:
parent
17ec59bcd1
commit
c0fab69f85
2 changed files with 9 additions and 6 deletions
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in a new issue