fix deferring of CanPush, and stop deferring StartingPush

This commit is contained in:
Joey Hess 2012-11-10 01:34:03 -04:00
parent 17ec59bcd1
commit c0fab69f85
2 changed files with 9 additions and 6 deletions

View file

@ -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)

View file

@ -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)