update for asynchronous message delivery (#92)

src/Simplex/Chat.hs

@@ -289,7 +289,7 @@ subscribeUserConnections = void . runExceptT $ do
     subscribe cId = withAgent (`subscribeConnection` cId)
 
 processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m ()
-processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
+processAgentMessage user@User {userId, profile} agentConnId agentMessage = unless (sent agentMessage) $ do
   chatDirection <- withStore $ \st -> getConnectionChatDirection st user agentConnId
   forM_ (agentMsgConnStatus agentMessage) $ \status ->
     withStore $ \st -> updateConnectionStatus st (fromConnection chatDirection) status
@@ -299,6 +299,10 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
     ReceivedGroupMessage conn gName m ->
       processGroupMessage agentMessage conn gName m
   where
+    sent :: ACommand 'Agent -> Bool
+    sent SENT {} = True
+    sent _ = False
+
     isMember :: MemberId -> Group -> Bool
     isMember memId Group {membership, members} =
       memberId membership == memId || isJust (find ((== memId) . memberId) members)
@@ -324,8 +328,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
           acceptAgentConnection conn confId $ XInfo profile
         INFO connInfo ->
           saveConnInfo conn connInfo
-        CON -> pure ()
-        _ -> messageError $ "unsupported agent event: " <> T.pack (show agentMsg)
+        _ -> pure ()
       Just ct@Contact {localDisplayName = c} -> case agentMsg of
         MSG meta msgBody -> do
           ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody
@@ -366,10 +369,17 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
                 notifyMemberConnected gName m
                 when (memberCategory m == GCPreMember) $ probeMatchingContacts ct
         END -> do
+          showContactAnotherClient c
+          showToast (c <> "> ") "connected to another client"
+          unsetActive $ ActiveC c
+        DOWN -> do
           showContactDisconnected c
           showToast (c <> "> ") "disconnected"
-          unsetActive $ ActiveC c
-        _ -> messageError $ "unexpected agent event: " <> T.pack (show agentMsg)
+        UP -> do
+          showContactSubscribed c
+          showToast (c <> "> ") "is active"
+          setActive $ ActiveC c
+        _ -> pure ()
 
     processGroupMessage :: ACommand 'Agent -> Connection -> GroupName -> GroupMember -> m ()
     processGroupMessage agentMsg conn gName m = case agentMsg of
@@ -449,7 +459,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
           XGrpLeave -> xGrpLeave gName m
           XGrpDel -> xGrpDel gName m
           _ -> messageError $ "unsupported message: " <> T.pack (show chatMsgEvent)
-      _ -> messageError $ "unsupported agent event: " <> T.pack (show agentMsg)
+      _ -> pure ()
 
     notifyMemberConnected :: GroupName -> GroupMember -> m ()
     notifyMemberConnected gName m@GroupMember {localDisplayName} = do
@@ -636,10 +646,11 @@ chatError :: ChatMonad m => ChatErrorType -> m ()
 chatError = throwError . ChatError
 
 deleteMemberConnection :: ChatMonad m => GroupMember -> m ()
-deleteMemberConnection m = do
-  User {userId} <- asks currentUser
-  withAgent $ forM_ (memberConnId m) . deleteConnection
-  withStore $ \st -> deleteGroupMemberConnection st userId m
+deleteMemberConnection m@GroupMember {activeConn} = do
+  -- User {userId} <- asks currentUser
+  withAgent $ forM_ (memberConnId m) . suspendConnection
+  -- withStore $ \st -> deleteGroupMemberConnection st userId m
+  forM_ activeConn $ \conn -> withStore $ \st -> updateConnectionStatus st conn ConnDeleted
 
 sendDirectMessage :: ChatMonad m => ConnId -> ChatMsgEvent -> m ()
 sendDirectMessage agentConnId chatMsgEvent =

src/Simplex/Chat/Types.hs

@@ -324,6 +324,8 @@ data ConnStatus
     ConnSndReady
   | -- | connection is ready for both parties to send and receive messages
     ConnReady
+  | -- | connection deleted
+    ConnDeleted
   deriving (Eq, Show)
 
 instance FromField ConnStatus where fromField = fromTextField_ connStatusT
@@ -338,6 +340,7 @@ connStatusT = \case
   "accepted" -> Just ConnAccepted
   "snd-ready" -> Just ConnSndReady
   "ready" -> Just ConnReady
+  "deleted" -> Just ConnDeleted
   _ -> Nothing
 
 serializeConnStatus :: ConnStatus -> Text
@@ -348,6 +351,7 @@ serializeConnStatus = \case
   ConnAccepted -> "accepted"
   ConnSndReady -> "snd-ready"
   ConnReady -> "ready"
+  ConnDeleted -> "deleted"
 
 data ConnType = ConnContact | ConnMember
   deriving (Eq, Show)

src/Simplex/Chat/View.hs

@@ -13,6 +13,7 @@ module Simplex.Chat.View
     showContactGroups,
     showContactConnected,
     showContactDisconnected,
+    showContactAnotherClient,
     showContactSubscribed,
     showContactSubError,
     showGroupSubscribed,
@@ -81,6 +82,9 @@ showContactConnected = printToView . contactConnected
 showContactDisconnected :: ChatReader m => ContactName -> m ()
 showContactDisconnected = printToView . contactDisconnected
 
+showContactAnotherClient :: ChatReader m => ContactName -> m ()
+showContactAnotherClient = printToView . contactAnotherClient
+
 showContactSubscribed :: ChatReader m => ContactName -> m ()
 showContactSubscribed = printToView . contactSubscribed
 
@@ -186,7 +190,10 @@ contactConnected :: Contact -> [StyledString]
 contactConnected ct = [ttyFullContact ct <> ": contact is connected"]
 
 contactDisconnected :: ContactName -> [StyledString]
-contactDisconnected c = [ttyContact c <> ": contact is disconnected - restart chat"]
+contactDisconnected c = [ttyContact c <> ": contact is disconnected (messages will be queued)"]
+
+contactAnotherClient :: ContactName -> [StyledString]
+contactAnotherClient c = [ttyContact c <> ": contact is connected to another client"]
 
 contactSubscribed :: ContactName -> [StyledString]
 contactSubscribed c = [ttyContact c <> ": contact is active"]

stack.yaml

@@ -43,7 +43,7 @@ extra-deps:
   # - simplexmq-0.3.1@sha256:f247aaff3c16c5d3974a4ab4d5882ab50ac78073110997c0bceb05a74d10a325,6688
   # - ../simplexmq
   - github: simplex-chat/simplexmq
-    commit: d9084522afa939b2993d4c3e94db90cf145ffadf
+    commit: dd5137c336d5525c38b068d7212964b4ab196a33
   # this commit is in PR #164
 #
 # extra-deps: []

tests/ChatClient.hs

@@ -20,6 +20,7 @@ import Simplex.Chat.Options
 import Simplex.Chat.Store
 import Simplex.Chat.Types (Profile)
 import Simplex.Messaging.Agent.Env.SQLite
+import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Server (runSMPServerBlocking)
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Transport

tests/ChatTests.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PostfixOperators #-}