diff options
Diffstat (limited to 'Assistant/Types/NetMessager.hs')
| -rw-r--r-- | Assistant/Types/NetMessager.hs | 29 |
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 |