subscribe all user contacts and group members (#85)

src/Simplex/Chat.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.Chat where
 
@@ -23,7 +24,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.List (find)
-import Data.Maybe (isJust)
+import Data.Maybe (isJust, mapMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
@@ -200,12 +201,32 @@ processChatCommand user@User {userId, profile} = \case
 agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
 agentSubscriber = do
   q <- asks $ subQ . smpAgent
+  subscribeUserConnections
   forever $ do
     (_, connId, msg) <- atomically $ readTBQueue q
     user <- asks currentUser
     -- TODO handle errors properly
     void . runExceptT $ processAgentMessage user connId msg `catchError` (liftIO . print)
 
+subscribeUserConnections :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
+subscribeUserConnections = void . runExceptT $ do
+  user <- asks currentUser
+  subscribeContacts user
+  subscribeGroups user
+  where
+    subscribeContacts user = do
+      contacts <- withStore (`getUserContacts` user)
+      forM_ contacts $ \ct@Contact {localDisplayName = c} ->
+        (subscribe (contactConnId ct) >> showContactSubscribed c) `catchError` showContactSubError c
+    subscribeGroups user = do
+      groups <- filter (not . null . members) <$> withStore (`getUserGroups` user)
+      forM_ groups $ \Group {members, localDisplayName = g} -> do
+        let connectedMembers = mapMaybe (\m -> (m,) <$> memberConnId m) members
+        forM_ connectedMembers $ \(GroupMember {localDisplayName = c}, cId) ->
+          subscribe cId `catchError` showMemberSubError g c
+        showGroupSubscribed g
+    subscribe cId = withAgent (`subscribeConnection` cId)
+
 processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m ()
 processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
   chatDirection <- withStore $ \st -> getConnectionChatDirection st user agentConnId

src/Simplex/Chat/Store.hs

@@ -23,12 +23,14 @@ module Simplex.Chat.Store
     createDirectContact,
     deleteContact,
     getContact,
+    getUserContacts,
     getContactConnections,
     getConnectionChatDirection,
     updateConnectionStatus,
     createNewGroup,
     createGroupInvitation,
     getGroup,
+    getUserGroups,
     getGroupInvitation,
     createContactGroupMember,
     createMemberConnection,
@@ -53,6 +55,7 @@ import Control.Monad.IO.Unlift
 import Crypto.Random (ChaChaDRG, randomBytesGenerate)
 import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
+import Data.Either (rights)
 import Data.FileEmbed (embedDir, makeRelativeToProject)
 import Data.Function (on)
 import Data.Int (Int64)
@@ -199,18 +202,20 @@ deleteContact st userId displayName =
       |]
       [":user_id" := userId, ":display_name" := displayName]
 
+getContact :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Contact
+getContact st userId localDisplayName =
+  liftIOEither . withTransaction st $ \db -> runExceptT $ getContact_ db userId localDisplayName
+
 -- TODO return the last connection that is ready, not any last connection
 -- requires updating connection status
-getContact :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Contact
--- TODO merge contact and connection?
-getContact st userId localDisplayName =
-  liftIOEither . withTransaction st $ \db -> runExceptT $ do
-    c@Contact {contactId} <- getContact_ db
-    activeConn <- getConnection_ db contactId
-    pure $ (c :: Contact) {activeConn}
+getContact_ :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Contact
+getContact_ db userId localDisplayName = do
+  c@Contact {contactId} <- getContactRec_
+  activeConn <- getConnection_ contactId
+  pure $ (c :: Contact) {activeConn}
   where
-    getContact_ :: DB.Connection -> ExceptT StoreError IO Contact
-    getContact_ db = ExceptT $ do
+    getContactRec_ :: ExceptT StoreError IO Contact
+    getContactRec_ = ExceptT $ do
       toContact
         <$> DB.queryNamed
           db
@@ -221,8 +226,8 @@ getContact st userId localDisplayName =
             WHERE c.user_id = :user_id AND c.local_display_name = :local_display_name AND c.is_user = :is_user
           |]
           [":user_id" := userId, ":local_display_name" := localDisplayName, ":is_user" := False]
-    getConnection_ :: DB.Connection -> Int64 -> ExceptT StoreError IO Connection
-    getConnection_ db contactId = ExceptT $ do
+    getConnection_ :: Int64 -> ExceptT StoreError IO Connection
+    getConnection_ contactId = ExceptT $ do
       connection
         <$> DB.queryNamed
           db
@@ -244,6 +249,12 @@ getContact st userId localDisplayName =
     connection (connRow : _) = Right $ toConnection connRow
     connection _ = Left $ SEContactNotReady localDisplayName
 
+getUserContacts :: MonadUnliftIO m => SQLiteStore -> User -> m [Contact]
+getUserContacts st User {userId} =
+  liftIO . withTransaction st $ \db -> do
+    contactNames <- liftIO $ map fromOnly <$> DB.query db "SELECT local_display_name FROM contacts WHERE user_id = ?" (Only userId)
+    rights <$> mapM (runExceptT . getContact_ db userId) contactNames
+
 getContactConnections :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m [Connection]
 getContactConnections st userId displayName =
   liftIOEither . withTransaction st $ \db ->
@@ -294,7 +305,7 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
       ConnContact ->
         ReceivedDirectMessage c <$> case entityId of
           Nothing -> pure Nothing
-          Just contactId -> Just <$> getContact_ db contactId c
+          Just contactId -> Just <$> getContactRec_ db contactId c
   where
     getConnection_ :: DB.Connection -> ExceptT StoreError IO Connection
     getConnection_ db = ExceptT $ do
@@ -311,8 +322,8 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
     connection :: [ConnectionRow] -> Either StoreError Connection
     connection (connRow : _) = Right $ toConnection connRow
     connection _ = Left $ SEConnectionNotFound agentConnId
-    getContact_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO Contact
-    getContact_ db contactId c = ExceptT $ do
+    getContactRec_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO Contact
+    getContactRec_ db contactId c = ExceptT $ do
       toContact contactId c
         <$> DB.query
           db
@@ -447,6 +458,12 @@ getGroup_ db User {userId, userContactId} localDisplayName = do
             [] -> Left SEGroupWithoutUser
             u : ms -> Right (b <> ms, u)
 
+getUserGroups :: MonadUnliftIO m => SQLiteStore -> User -> m [Group]
+getUserGroups st user =
+  liftIO . withTransaction st $ \db -> do
+    groupNames <- liftIO $ map fromOnly <$> DB.query db "SELECT local_display_name FROM groups WHERE user_id = ?" (Only $ userId user)
+    map fst . rights <$> mapM (runExceptT . getGroup_ db user) groupNames
+
 getGroupInvitation :: StoreMonad m => SQLiteStore -> User -> GroupName -> m ReceivedGroupInvitation
 getGroupInvitation st user localDisplayName =
   liftIOEither . withTransaction st $ \db -> runExceptT $ do

src/Simplex/Chat/View.hs

@@ -12,6 +12,10 @@ module Simplex.Chat.View
     showContactDeleted,
     showContactConnected,
     showContactDisconnected,
+    showContactSubscribed,
+    showContactSubError,
+    showGroupSubscribed,
+    showMemberSubError,
     showReceivedMessage,
     showReceivedGroupMessage,
     showSentMessage,
@@ -63,6 +67,18 @@ showContactConnected = printToView . contactConnected
 showContactDisconnected :: ChatReader m => ContactName -> m ()
 showContactDisconnected = printToView . contactDisconnected
 
+showContactSubscribed :: ChatReader m => ContactName -> m ()
+showContactSubscribed = printToView . contactSubscribed
+
+showContactSubError :: ChatReader m => ContactName -> ChatError -> m ()
+showContactSubError = printToView .: contactSubError
+
+showGroupSubscribed :: ChatReader m => GroupName -> m ()
+showGroupSubscribed = printToView . groupSubscribed
+
+showMemberSubError :: ChatReader m => GroupName -> ContactName -> ChatError -> m ()
+showMemberSubError = printToView .:. memberSubError
+
 showReceivedMessage :: ChatReader m => ContactName -> UTCTime -> Text -> MsgIntegrity -> m ()
 showReceivedMessage = showReceivedMessage_ . ttyFromContact
 
@@ -120,6 +136,18 @@ contactConnected ct = [ttyFullContact ct <> " is connected"]
 contactDisconnected :: ContactName -> [StyledString]
 contactDisconnected c = ["disconnected from " <> ttyContact c <> " - restart chat"]
 
+contactSubscribed :: ContactName -> [StyledString]
+contactSubscribed c = [ttyContact c <> " is active"]
+
+contactSubError :: ContactName -> ChatError -> [StyledString]
+contactSubError c e = ["contact " <> ttyContact c <> " error: " <> plain (show e)]
+
+groupSubscribed :: GroupName -> [StyledString]
+groupSubscribed g = [ttyGroup g <> " is active"]
+
+memberSubError :: GroupName -> ContactName -> ChatError -> [StyledString]
+memberSubError g c e = [ttyGroup g <> " member " <> ttyContact c <> " error: " <> plain (show e)]
+
 groupCreated :: Group -> [StyledString]
 groupCreated g@Group {localDisplayName} =
   [ "group " <> ttyFullGroup g <> " is created",