xmpp push control flow

It might even work, although nothing yet triggers XMPP pushes.

Also added a set of deferred push messages. Only one push can run at a
time, and unrelated push messages get deferred. The set will never grow
very large, because it only puts two types of messages in there, that
can only vary in the client doing the push.

1 files changed, 27 insertions, 2 deletions

diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs
index 77f2759b3..6974cf57d 100644
--- a/Assistant/Types/NetMessager.hs
+++ b/Assistant/Types/NetMessager.hs
@@ -14,6 +14,7 @@ import Data.Text (Text)
 import Control.Concurrent.STM
 import Control.Concurrent.MSampleVar
 import Data.ByteString (ByteString)
+import Data.Set as S
 
 {- Messages that can be sent out of band by a network messager. -}
 data NetMessage 
@@ -34,17 +35,41 @@ data NetMessage
 	| SendPackOutput ClientID ByteString
 	-- sent when git receive-pack exits, with its exit code
 	| ReceivePackDone ClientID ExitCode
-	deriving (Show)
+	deriving (Show, Eq, Ord)
 
-{- Something used to identify a specific client to send the message to. -}
+{- Something used to identify the client, or clients to send the message to. -}
 type ClientID = Text
 
+getClientID :: NetMessage -> Maybe ClientID
+getClientID (NotifyPush _) = Nothing
+getClientID QueryPresence = Nothing
+getClientID (PairingNotification _ cid _) = Just cid
+getClientID (PushRequest cid) = Just cid
+getClientID (StartingPush cid) = Just cid
+getClientID (ReceivePackOutput cid _) = Just cid
+getClientID (SendPackOutput cid _) = Just cid
+getClientID (ReceivePackDone cid _) = Just cid
+
 data NetMessager = NetMessager
+	-- outgoing messages
 	{ netMessages :: TChan (NetMessage)
+	-- only one push can be running at a time, and this tracks it
+	, netMessagerPushRunning :: TMVar (PushRunning)
+	-- incoming messages relating to the currently running push
+	, netMessagesPush :: TChan (NetMessage)
+	-- incoming push messages that have been deferred to be processed later
+	, netMessagesDeferredPush :: TMVar (S.Set NetMessage)
+	-- write to this to restart the net messager
 	, netMessagerRestart :: MSampleVar ()
 	}
 
+data PushRunning = NoPushRunning | SendPushRunning ClientID | ReceivePushRunning ClientID
+	deriving (Eq)
+
 newNetMessager :: IO NetMessager
 newNetMessager = NetMessager
 	<$> atomically newTChan
+	<*> atomically (newTMVar NoPushRunning)
+	<*> atomically newTChan
+	<*> atomically (newTMVar S.empty)
 	<*> newEmptySV