diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 404f7eba0e..f954a02829 100644 --- a/src/Simplex/Chat.hs +++ b/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 diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 98990911c9..fd576c0f30 100644 --- a/src/Simplex/Chat/Store.hs +++ b/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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 16fbb3fca0..a2c1a497ff 100644 --- a/src/Simplex/Chat/View.hs +++ b/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",