diff --git a/cabal.project b/cabal.project index 2f4de58dd1..c0b6242089 100644 --- a/cabal.project +++ b/cabal.project @@ -5,7 +5,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: e75846aa38dd26fa70e3faa38ec780edf245e022 + tag: a6f401041ac82c1ba94a8fea21339acb33904ad0 source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 45bf4a4a86..47059d7e56 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."e75846aa38dd26fa70e3faa38ec780edf245e022" = "1mjr5bpjnz6pw9w4qy2r548xlgw89rxbmj36zb4vwq4jghj3gmcz"; + "https://github.com/simplex-chat/simplexmq.git"."a6f401041ac82c1ba94a8fea21339acb33904ad0" = "1q4wah7mwrbp98gv5z7vvdyyf6sgw4af26b220yimvkjam6l5mx5"; "https://github.com/simplex-chat/aeson.git"."3eb66f9a68f103b5f1489382aad89f5712a64db7" = "0kilkx59fl6c3qy3kjczqvm8c3f4n3p0bdk9biyflf51ljnzp4yp"; "https://github.com/simplex-chat/haskell-terminal.git"."f708b00009b54890172068f168bf98508ffcd495" = "0zmq7lmfsk8m340g47g5963yba7i88n4afa6z93sg9px5jv1mijj"; "https://github.com/zw3rk/android-support.git"."3c3a5ab0b8b137a072c98d3d0937cbdc96918ddb" = "1r6jyxbim3dsvrmakqfyxbd6ms6miaghpbwyl0sr6dzwpgaprz97"; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index dca3c291c9..76cabe9b15 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -31,12 +31,13 @@ import Data.Either (fromRight) import Data.Fixed (div') import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (find, isSuffixOf) +import Data.List (find, isSuffixOf, sortBy) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) +import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds) @@ -54,7 +55,7 @@ import Simplex.Chat.Protocol import Simplex.Chat.Store import Simplex.Chat.Types import Simplex.Chat.Util (safeDecodeUtf8, uncurry3) -import Simplex.Messaging.Agent +import Simplex.Messaging.Agent as Agent import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), defaultAgentConfig) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C @@ -64,7 +65,7 @@ import Simplex.Messaging.Parsers (base64P, parseAll) import Simplex.Messaging.Protocol (ErrorType (..), MsgBody, MsgFlags (..), NtfServer) import qualified Simplex.Messaging.Protocol as SMP import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (ifM, liftEitherError, tryError, unlessM, whenM, (<$?>)) +import Simplex.Messaging.Util import System.Exit (exitFailure, exitSuccess) import System.FilePath (combine, splitExtensions, takeFileName) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout) @@ -157,7 +158,7 @@ startChatController user subConns = do a1 <- async $ race_ notificationSubscriber agentSubscriber a2 <- if subConns - then Just <$> async (subscribeUserConnections subscribeConnection user) + then Just <$> async (void . runExceptT $ subscribeUserConnections Agent.subscribeConnections user) else pure Nothing atomically . writeTVar s $ Just (a1, a2) pure a1 @@ -218,7 +219,7 @@ processChatCommand = \case withUser $ \user -> restoreCalls user withAgent activateAgent $> CRCmdOk APISuspendChat t -> withAgent (`suspendAgent` t) $> CRCmdOk - ResubscribeAllConnections -> withUser (subscribeUserConnections resubscribeConnection) $> CRCmdOk + ResubscribeAllConnections -> withUser (subscribeUserConnections Agent.resubscribeConnections) $> CRCmdOk SetFilesFolder filesFolder' -> do createDirectoryIfMissing True filesFolder' ff <- asks filesFolder @@ -582,7 +583,7 @@ processChatCommand = \case (NotificationInfo {ntfConnId, ntfMsgMeta}, msgs) <- withAgent $ \a -> getNotificationMessage a nonce encNtfInfo let ntfMessages = map (\SMP.SMPMsgMeta {msgTs, msgFlags} -> NtfMsgInfo {msgTs = systemToUTCTime msgTs, msgFlags}) msgs msgTs' = systemToUTCTime . (SMP.msgTs :: SMP.NMsgMeta -> SystemTime) <$> ntfMsgMeta - connEntity <- withStore (\db -> Just <$> getConnectionEntity db user ntfConnId) `catchError` \_ -> pure Nothing + connEntity <- withStore (\db -> Just <$> getConnectionEntity db user (AgentConnId ntfConnId)) `catchError` \_ -> pure Nothing pure CRNtfMessages {connEntity, msgTs = msgTs', ntfMessages} GetUserSMPServers -> CRUserSMPServers <$> withUser (\user -> withStore' (`getSMPServers` user)) SetUserSMPServers smpServers -> withUser $ \user -> withChatLock $ do @@ -618,12 +619,12 @@ processChatCommand = \case (connId, cReq) <- withAgent (`createConnection` SCMContact) withStore $ \db -> createUserContactLink db userId connId cReq pure $ CRUserContactLinkCreated cReq - DeleteMyAddress -> withUser $ \User {userId} -> withChatLock $ do - conns <- withStore (`getUserContactLinkConnections` userId) + DeleteMyAddress -> withUser $ \user -> withChatLock $ do + conns <- withStore (`getUserContactLinkConnections` user) procCmd $ do withAgent $ \a -> forM_ conns $ \conn -> deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure () - withStore' (`deleteUserContactLink` userId) + withStore' (`deleteUserContactLink` user) pure CRUserContactLinkDeleted ShowMyAddress -> withUser $ \User {userId} -> uncurry3 CRUserContactLink <$> withStore (`getUserContactLink` userId) @@ -1076,85 +1077,120 @@ agentSubscriber = do withLock l . void . runExceptT $ processAgentMessage u connId msg `catchError` (toView . CRChatError) -subscribeUserConnections :: - (MonadUnliftIO m, MonadReader ChatController m) => - (forall m'. ChatMonad m' => AgentClient -> ConnId -> ExceptT AgentErrorType m' ()) -> - User -> - m () -subscribeUserConnections agentSubscribe user@User {userId} = do - n <- asks $ subscriptionConcurrency . config +type AgentBatchSubscribe m = AgentClient -> [ConnId] -> ExceptT AgentErrorType m (Map ConnId (Either AgentErrorType ())) + +subscribeUserConnections :: forall m. ChatMonad m => AgentBatchSubscribe m -> User -> m () +subscribeUserConnections agentBatchSubscribe user = do + -- get user connections ce <- asks $ subscriptionEvents . config - void . runExceptT $ do - catchErr $ subscribeContacts n ce - catchErr $ subscribeUserContactLink n - catchErr $ subscribeGroups n ce - catchErr $ subscribeFiles n - catchErr $ subscribePendingConnections n + (ctConns, cts) <- getContactConns + (ucConns, ucs) <- getUserContactLinkConns + (gs, mConns, ms) <- getGroupMemberConns + (sftConns, sfts) <- getSndFileTransferConns + (rftConns, rfts) <- getRcvFileTransferConns + (pcConns, pcs) <- getPendingContactConns + -- subscribe using batched commands + rs <- withAgent (`agentBatchSubscribe` concat [ctConns, ucConns, mConns, sftConns, rftConns, pcConns]) + -- send connection events to view + contactSubsToView rs cts + contactLinkSubsToView rs ucs + groupSubsToView rs gs ms ce + sndFileSubsToView rs sfts + rcvFileSubsToView rs rfts + pendingConnSubsToView rs pcs where - catchErr a = a `catchError` \_ -> pure () - subscribeContacts n ce = do - contacts <- withStore' (`getUserContacts` user) - toView . CRContactSubSummary =<< pooledForConcurrentlyN n contacts (\ct -> ContactSubStatus ct <$> subscribeContact ce ct) - subscribeContact ce ct = - (subscribe (contactConnId ct) $> Nothing) - `catchError` (\e -> when ce (toView $ CRContactSubError ct e) $> Just e) - subscribeGroups n ce = do - groups <- withStore' (`getUserGroups` user) - toView . CRMemberSubErrors . mconcat =<< forM groups (subscribeGroup n ce) - subscribeGroup n ce (Group g@GroupInfo {membership} members) = do - let connectedMembers = mapMaybe (\m -> (m,) <$> memberConnId m) members - if memberStatus membership == GSMemInvited - then do - toView $ CRGroupInvitation g - pure [] - else - if null connectedMembers - then do - if memberActive membership - then toView $ CRGroupEmpty g - else toView $ CRGroupRemoved g - pure [] - else do - ms <- pooledForConcurrentlyN n connectedMembers $ \(m@GroupMember {localDisplayName = c}, cId) -> - (m,) <$> ((subscribe cId $> Nothing) `catchError` (\e -> when ce (toView $ CRMemberSubError g c e) $> Just e)) - toView $ CRGroupSubscribed g - pure $ mapMaybe (\(m, e) -> (Just . MemberSubError m) =<< e) ms - subscribeFiles n = do - sndFileTransfers <- withStore' (`getLiveSndFileTransfers` user) - pooledForConcurrentlyN_ n sndFileTransfers $ \sft -> subscribeSndFile sft - rcvFileTransfers <- withStore' (`getLiveRcvFileTransfers` user) - pooledForConcurrentlyN_ n rcvFileTransfers $ \rft -> subscribeRcvFile rft + getContactConns :: m ([ConnId], Map ConnId Contact) + getContactConns = do + cts <- withStore_ getUserContacts + let connIds = map contactConnId cts + pure (connIds, M.fromList $ zip connIds cts) + getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact) + getUserContactLinkConns = do + (cs, ucs) <- unzip <$> withStore_ getUserContactLinks + let connIds = map aConnId cs + pure (connIds, M.fromList $ zip connIds ucs) + getGroupMemberConns :: m ([Group], [ConnId], Map ConnId GroupMember) + getGroupMemberConns = do + gs <- withStore_ getUserGroups + let mPairs = concatMap (\(Group _ ms) -> mapMaybe (\m -> (,m) <$> memberConnId m) ms) gs + pure (gs, map fst mPairs, M.fromList mPairs) + getSndFileTransferConns :: m ([ConnId], Map ConnId SndFileTransfer) + getSndFileTransferConns = do + sfts <- withStore_ getLiveSndFileTransfers + let connIds = map sndFileTransferConnId sfts + pure (connIds, M.fromList $ zip connIds sfts) + getRcvFileTransferConns :: m ([ConnId], Map ConnId RcvFileTransfer) + getRcvFileTransferConns = do + rfts <- withStore_ getLiveRcvFileTransfers + let rftPairs = mapMaybe (\ft -> (,ft) <$> liveRcvFileTransferConnId ft) rfts + pure (map fst rftPairs, M.fromList rftPairs) + getPendingContactConns :: m ([ConnId], Map ConnId PendingContactConnection) + getPendingContactConns = do + pcs <- withStore_ getPendingContactConnections + let connIds = map aConnId' pcs + pure (connIds, M.fromList $ zip connIds pcs) + contactSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId Contact -> m () + contactSubsToView rs = toView . CRContactSubSummary . map (uncurry ContactSubStatus) . resultsFor rs + contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> m () + contactLinkSubsToView rs ucs = case resultsFor rs ucs of + [] -> pure () + ((_, Just e) : _) -> toView $ CRUserContactLinkSubError e + _ -> toView CRUserContactLinkSubscribed + groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> m () + groupSubsToView rs gs ms ce = do + mapM_ groupSub $ + sortBy (comparing $ \(Group GroupInfo {localDisplayName = g} _) -> g) gs + toView . CRMemberSubSummary $ map (uncurry MemberSubStatus) mRs where - subscribeSndFile ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId cId} = do - subscribe cId `catchError` (toView . CRSndFileSubError ft) - void . forkIO $ do - threadDelay 1000000 - l <- asks chatLock - a <- asks smpAgent - when (fileStatus == FSConnected) . unlessM (isFileActive fileId sndFiles) $ - withAgentLock a . withLock l $ - sendFileChunk user ft - subscribeRcvFile ft@RcvFileTransfer {fileStatus} = - case fileStatus of - RFSAccepted fInfo -> resume fInfo - RFSConnected fInfo -> resume fInfo - _ -> pure () + mRs = resultsFor rs ms + groupSub :: Group -> m () + groupSub (Group g@GroupInfo {membership, groupId = gId} members) = do + when ce $ mapM_ (toView . uncurry (CRMemberSubError g)) mErrors + toView groupEvent where - resume RcvFileInfo {agentConnId = AgentConnId cId} = - subscribe cId `catchError` (toView . CRRcvFileSubError ft) - subscribePendingConnections n = do - cs <- withStore' (`getPendingConnections` user) - summary <- pooledForConcurrentlyN n cs $ \Connection {agentConnId = acId@(AgentConnId cId)} -> - PendingSubStatus acId <$> ((subscribe cId $> Nothing) `catchError` (pure . Just)) - toView $ CRPendingSubSummary summary - subscribeUserContactLink n = do - cs <- withStore (`getUserContactLinkConnections` userId) - (subscribeConns n cs >> toView CRUserContactLinkSubscribed) - `catchError` (toView . CRUserContactLinkSubError) - subscribe cId = withAgent (`agentSubscribe` cId) - subscribeConns n conns = - withAgent $ \a -> - pooledForConcurrentlyN_ n conns $ \c -> agentSubscribe a (aConnId c) + mErrors :: [(GroupMember, ChatError)] + mErrors = + sortBy (comparing (\(GroupMember {localDisplayName = n}, _) -> n)) + . filterErrors + $ filter (\(GroupMember {groupId}, _) -> groupId == gId) mRs + groupEvent :: ChatResponse + groupEvent + | memberStatus membership == GSMemInvited = CRGroupInvitation g + | all (\GroupMember {activeConn} -> isNothing activeConn) members = + if memberActive membership + then CRGroupEmpty g + else CRGroupRemoved g + | otherwise = CRGroupSubscribed g + sndFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId SndFileTransfer -> m () + sndFileSubsToView rs sfts = do + let sftRs = resultsFor rs sfts + forM_ sftRs $ \(ft@SndFileTransfer {fileId, fileStatus}, err_) -> do + forM_ err_ $ toView . CRSndFileSubError ft + void . forkIO $ do + threadDelay 1000000 + l <- asks chatLock + a <- asks smpAgent + when (fileStatus == FSConnected) . unlessM (isFileActive fileId sndFiles) $ + withAgentLock a . withLock l $ + sendFileChunk user ft + rcvFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId RcvFileTransfer -> m () + rcvFileSubsToView rs = mapM_ (toView . uncurry CRRcvFileSubError) . filterErrors . resultsFor rs + pendingConnSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId PendingContactConnection -> m () + pendingConnSubsToView rs = toView . CRPendingSubSummary . map (uncurry PendingSubStatus) . resultsFor rs + withStore_ :: (DB.Connection -> User -> IO [a]) -> m [a] + withStore_ a = withStore' (`a` user) `catchError` \_ -> pure [] + filterErrors :: [(a, Maybe ChatError)] -> [(a, ChatError)] + filterErrors = mapMaybe (\(a, e_) -> (a,) <$> e_) + resultsFor :: Map ConnId (Either AgentErrorType ()) -> Map ConnId a -> [(a, Maybe ChatError)] + resultsFor rs = M.foldrWithKey' addResult [] + where + addResult :: ConnId -> a -> [(a, Maybe ChatError)] -> [(a, Maybe ChatError)] + addResult connId = (:) . (,err) + where + err = case M.lookup connId rs of + Just (Left e) -> Just $ ChatErrorAgent e + Just _ -> Nothing + _ -> Just . ChatError . CEAgentNoSubResult $ AgentConnId connId processAgentMessage :: forall m. ChatMonad m => Maybe User -> ConnId -> ACommand 'Agent -> m () processAgentMessage Nothing _ _ = throwChatError CENoActiveUser @@ -1169,7 +1205,7 @@ processAgentMessage (Just User {userId}) "" agentMessage = case agentMessage of toView $ event srv cs showToast ("server " <> str) (safeDecodeUtf8 . strEncode $ SrvLoc host port) processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage = - (withStore (\db -> getConnectionEntity db user agentConnId) >>= updateConnStatus) >>= \case + (withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= updateConnStatus) >>= \case RcvDirectMsgConnection conn contact_ -> processDirectMessage agentMessage conn contact_ RcvGroupMsgConnection conn gInfo m -> diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index d9b6bc3f83..80901ef175 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -270,10 +270,10 @@ data ChatResponse | CRGroupEmpty {groupInfo :: GroupInfo} | CRGroupRemoved {groupInfo :: GroupInfo} | CRGroupDeleted {groupInfo :: GroupInfo, member :: GroupMember} - | CRMemberSubError {groupInfo :: GroupInfo, contactName :: ContactName, chatError :: ChatError} -- TODO Contact? or GroupMember? - | CRMemberSubErrors {memberSubErrors :: [MemberSubError]} + | CRMemberSubError {groupInfo :: GroupInfo, member :: GroupMember, chatError :: ChatError} + | CRMemberSubSummary {memberSubscriptions :: [MemberSubStatus]} | CRGroupSubscribed {groupInfo :: GroupInfo} - | CRPendingSubSummary {pendingSubStatus :: [PendingSubStatus]} + | CRPendingSubSummary {pendingSubscriptions :: [PendingSubStatus]} | CRSndFileSubError {sndFileTransfer :: SndFileTransfer, chatError :: ChatError} | CRRcvFileSubError {rcvFileTransfer :: RcvFileTransfer, chatError :: ChatError} | CRCallInvitation {callInvitation :: RcvCallInvitation} @@ -311,17 +311,18 @@ instance ToJSON ContactSubStatus where toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} -data MemberSubError = MemberSubError +data MemberSubStatus = MemberSubStatus { member :: GroupMember, - memberError :: ChatError + memberError :: Maybe ChatError } deriving (Show, Generic) -instance ToJSON MemberSubError where - toEncoding = J.genericToEncoding J.defaultOptions +instance ToJSON MemberSubStatus where + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} data PendingSubStatus = PendingSubStatus - { connId :: AgentConnId, + { connection :: PendingContactConnection, connError :: Maybe ChatError } deriving (Show, Generic) @@ -396,6 +397,7 @@ data ChatErrorType | CECallContact {contactId :: Int64} | CECallState {currentCallState :: CallStateTag} | CEAgentVersion + | CEAgentNoSubResult {agentConnId :: AgentConnId} | CECommandError {message :: String} deriving (Show, Exception, Generic) diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index a4a5ebf032..a852f21f53 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -40,6 +40,7 @@ module Simplex.Chat.Store getUserContacts, createUserContactLink, getUserContactLinkConnections, + getUserContactLinks, deleteUserContactLink, getUserContactLink, getUserContactLinkById, @@ -52,7 +53,7 @@ module Simplex.Chat.Store getLiveSndFileTransfers, getLiveRcvFileTransfers, getPendingSndChunks, - getPendingConnections, + getPendingContactConnections, getContactConnections, getConnectionEntity, getConnectionsContacts, @@ -330,7 +331,7 @@ createConnReqConnection db userId acId cReqHash xContactId = do |] (userId, acId, pccConnStatus, ConnContact, createdAt, createdAt, cReqHash, xContactId) pccConnId <- insertedRowId db - pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, createdAt, updatedAt = createdAt} + pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, createdAt, updatedAt = createdAt} getConnReqContactXContactId :: DB.Connection -> UserId -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId) getConnReqContactXContactId db userId cReqHash = do @@ -377,7 +378,7 @@ createDirectConnection db userId acId pccConnStatus = do |] (userId, acId, pccConnStatus, ConnContact, createdAt, createdAt) pccConnId <- insertedRowId db - pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, createdAt, updatedAt = createdAt} + pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, viaUserContactLink = Nothing, createdAt, updatedAt = createdAt} createMemberContactConnection_ :: DB.Connection -> UserId -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection createMemberContactConnection_ db userId agentConnId viaContact = createConnection_ db userId ConnContact Nothing agentConnId viaContact Nothing @@ -578,28 +579,33 @@ createUserContactLink db userId agentConnId cReq = userContactLinkId <- insertedRowId db void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing 0 currentTs -getUserContactLinkConnections :: DB.Connection -> UserId -> ExceptT StoreError IO [Connection] -getUserContactLinkConnections db userId = - connections =<< liftIO getConnections - where - getConnections = - DB.queryNamed - db - [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, - c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at - FROM connections c - JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id - WHERE c.user_id = :user_id - AND uc.user_id = :user_id - AND uc.local_display_name = '' - |] - [":user_id" := userId] - connections [] = throwError SEUserContactLinkNotFound - connections rows = pure $ map toConnection rows +getUserContactLinkConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection] +getUserContactLinkConnections db user = do + cs <- liftIO $ getUserContactLinks db user + if null cs then throwError SEUserContactLinkNotFound else pure $ map fst cs -deleteUserContactLink :: DB.Connection -> UserId -> IO () -deleteUserContactLink db userId = do +getUserContactLinks :: DB.Connection -> User -> IO [(Connection, UserContact)] +getUserContactLinks db User {userId} = + map toResult + <$> DB.queryNamed + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, + c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, + uc.user_contact_link_id, uc.conn_req_contact + FROM connections c + JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id + WHERE c.user_id = :user_id + AND uc.user_id = :user_id + AND uc.local_display_name = '' + |] + [":user_id" := userId] + where + toResult :: (ConnectionRow :. (Int64, ConnReqContact)) -> (Connection, UserContact) + toResult (connRow :. (userContactLinkId, connReqContact)) = (toConnection connRow, UserContact {userContactLinkId, connReqContact}) + +deleteUserContactLink :: DB.Connection -> User -> IO () +deleteUserContactLink db User {userId} = do DB.execute db [sql| @@ -896,14 +902,13 @@ getPendingSndChunks db fileId connId = |] (fileId, connId) -getPendingConnections :: DB.Connection -> User -> IO [Connection] -getPendingConnections db User {userId} = - map toConnection +getPendingContactConnections :: DB.Connection -> User -> IO [PendingContactConnection] +getPendingContactConnections db User {userId} = do + map toPendingContactConnection <$> DB.queryNamed db [sql| - SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, - conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, created_at, updated_at FROM connections WHERE user_id = :user_id AND conn_type = :conn_type @@ -1091,7 +1096,7 @@ mergeContactRecords db userId Contact {contactId = toContactId} Contact {contact DB.execute db "DELETE FROM contacts WHERE contact_id = ? AND user_id = ?" (fromContactId, userId) DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) -getConnectionEntity :: DB.Connection -> User -> ConnId -> ExceptT StoreError IO ConnectionEntity +getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity getConnectionEntity db user@User {userId, userContactId} agentConnId = do c@Connection {connType, entityId} <- getConnection_ case entityId of @@ -1109,8 +1114,8 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do where getConnection_ :: ExceptT StoreError IO Connection getConnection_ = ExceptT $ do - connection - <$> DB.query + firstRow toConnection (SEConnectionNotFound agentConnId) $ + DB.query db [sql| SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, @@ -1119,9 +1124,6 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do WHERE user_id = ? AND agent_conn_id = ? |] (userId, agentConnId) - connection :: [ConnectionRow] -> Either StoreError Connection - connection (connRow : _) = Right $ toConnection connRow - connection _ = Left . SEConnectionNotFound $ AgentConnId agentConnId getContactRec_ :: Int64 -> Connection -> ExceptT StoreError IO Contact getContactRec_ contactId c = ExceptT $ do toContact' contactId c @@ -1173,8 +1175,8 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer getConnSndFileTransfer_ fileId Connection {connId} = ExceptT $ - sndFileTransfer_ fileId connId - <$> DB.query + firstRow' (sndFileTransfer_ fileId connId) (SESndFileNotFound fileId) $ + DB.query db [sql| SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, cs.local_display_name, m.local_display_name @@ -1185,12 +1187,11 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ? |] (userId, fileId, connId) - sndFileTransfer_ :: Int64 -> Int64 -> [(FileStatus, String, Integer, Integer, FilePath, Maybe ContactName, Maybe ContactName)] -> Either StoreError SndFileTransfer - sndFileTransfer_ fileId connId [(fileStatus, fileName, fileSize, chunkSize, filePath, contactName_, memberName_)] = + sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer + sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, contactName_, memberName_) = case contactName_ <|> memberName_ of - Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId = AgentConnId agentConnId} + Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId} Nothing -> Left $ SESndFileInvalid fileId - sndFileTransfer_ fileId _ _ = Left $ SESndFileNotFound fileId getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact getUserContact_ userContactLinkId = ExceptT $ do userContact_ @@ -2700,13 +2701,13 @@ getContactConnectionChatPreviews_ db User {userId} _ = <$> DB.query db [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, created_at, updated_at + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, created_at, updated_at FROM connections WHERE user_id = ? AND conn_type = ? AND contact_id IS NULL AND conn_level = 0 AND via_contact IS NULL |] (userId, ConnContact) where - toContactConnectionChatPreview :: (Int64, ConnId, ConnStatus, Maybe ByteString, UTCTime, UTCTime) -> AChat + toContactConnectionChatPreview :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, UTCTime, UTCTime) -> AChat toContactConnectionChatPreview connRow = let conn = toPendingContactConnection connRow stats = ChatStats {unreadCount = 0, minUnreadItemId = 0} @@ -2718,7 +2719,7 @@ getPendingContactConnection db userId connId = do DB.query db [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, created_at, updated_at + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, created_at, updated_at FROM connections WHERE user_id = ? AND connection_id = ? @@ -2744,9 +2745,9 @@ deletePendingContactConnection db userId connId = |] (userId, connId, ConnContact) -toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, UTCTime, UTCTime) -> PendingContactConnection -toPendingContactConnection (pccConnId, acId, pccConnStatus, connReqHash, createdAt, updatedAt) = - PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = isJust connReqHash, createdAt, updatedAt} +toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, UTCTime, UTCTime) -> PendingContactConnection +toPendingContactConnection (pccConnId, acId, pccConnStatus, connReqHash, viaUserContactLink, createdAt, updatedAt) = + PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = isJust connReqHash, viaUserContactLink, createdAt, updatedAt} getDirectChat :: DB.Connection -> User -> Int64 -> ChatPagination -> ExceptT StoreError IO (Chat 'CTDirect) getDirectChat db user contactId pagination = do diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 00b934c136..d62ff467a4 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -541,6 +541,9 @@ data SndFileTransfer = SndFileTransfer instance ToJSON SndFileTransfer where toEncoding = J.genericToEncoding J.defaultOptions +sndFileTransferConnId :: SndFileTransfer -> ConnId +sndFileTransferConnId SndFileTransfer {agentConnId = AgentConnId acId} = acId + type FileTransferId = Int64 data FileInvitation = FileInvitation @@ -586,6 +589,14 @@ data RcvFileInfo = RcvFileInfo instance ToJSON RcvFileInfo where toEncoding = J.genericToEncoding J.defaultOptions +liveRcvFileTransferConnId :: RcvFileTransfer -> Maybe ConnId +liveRcvFileTransferConnId RcvFileTransfer {fileStatus} = case fileStatus of + RFSAccepted fi -> acId fi + RFSConnected fi -> acId fi + _ -> Nothing + where + acId RcvFileInfo {agentConnId = AgentConnId cId} = Just cId + newtype AgentConnId = AgentConnId ConnId deriving (Eq, Show) @@ -703,6 +714,7 @@ data PendingContactConnection = PendingContactConnection pccAgentConnId :: AgentConnId, pccConnStatus :: ConnStatus, viaContactUri :: Bool, + viaUserContactLink :: Maybe Int64, createdAt :: UTCTime, updatedAt :: UTCTime } diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 8ec8c882c1..c02912c848 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -144,8 +144,8 @@ responseToView testView = \case CRGroupEmpty g -> [ttyFullGroup g <> ": group is empty"] CRGroupRemoved g -> [ttyFullGroup g <> ": you are no longer a member or group deleted"] CRGroupDeleted g m -> [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> groupName' g) <> " to delete the local copy of the group"] - CRMemberSubError g c e -> [ttyGroup' g <> " member " <> ttyContact c <> " error: " <> sShow e] - CRMemberSubErrors summary -> viewErrorsSummary summary " group member errors" + CRMemberSubError g m e -> [ttyGroup' g <> " member " <> ttyMember m <> " error: " <> sShow e] + CRMemberSubSummary summary -> viewErrorsSummary (filter (isJust . memberError) summary) " group member errors" CRGroupSubscribed g -> [ttyFullGroup g <> ": connected to server(s)"] CRPendingSubSummary _ -> [] CRSndFileSubError SndFileTransfer {fileId, fileName} e -> @@ -772,6 +772,7 @@ viewChatError = \case CECallContact _ -> [] CECallState _ -> [] CEAgentVersion -> ["unsupported agent version"] + CEAgentNoSubResult connId -> ["no subscription result for connection: " <> sShow connId] CECommandError e -> ["bad chat command: " <> plain e] -- e -> ["chat error: " <> sShow e] ChatErrorStore err -> case err of diff --git a/stack.yaml b/stack.yaml index 86ec49a705..07220678cd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -49,7 +49,7 @@ extra-deps: # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561 # - ../simplexmq - github: simplex-chat/simplexmq - commit: e75846aa38dd26fa70e3faa38ec780edf245e022 + commit: a6f401041ac82c1ba94a8fea21339acb33904ad0 # - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977 - github: simplex-chat/aeson commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7 diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index b45adf8cf6..6fcb6173ec 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -274,7 +274,8 @@ serverCfg = certificateFile = "tests/fixtures/tls/server.crt", logStatsInterval = Just 86400, logStatsStartTime = 0, - serverStatsFile = Nothing, + serverStatsLogFile = "tests/smp-server-stats.daily.log", + serverStatsBackupFile = Nothing, smpServerVRange = supportedSMPServerVRange } diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 06cc8dee13..156ba67ebc 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -1095,6 +1095,7 @@ testGroupAsync = withTmpFiles $ do [ bob <## "#team: dan joined the group", dan <## "#team: you joined the group" ] + threadDelay 500000 print (4 :: Integer) withTestChat "alice" $ \alice -> do withTestChat "cath" $ \cath -> do @@ -1116,6 +1117,7 @@ testGroupAsync = withTmpFiles $ do dan <## "#team: member alice (Alice) is connected" dan <## "#team: member cath (Catherine) is connected" ] + threadDelay 500000 print (5 :: Integer) withTestChat "alice" $ \alice -> do withTestChat "bob" $ \bob -> do @@ -1706,9 +1708,9 @@ testGroupSendImageWithTextAndQuote = alice #$> ("/_get chat #1 count=100", chat'', [((0, "hi team"), Nothing, Nothing), ((1, "hey bob"), Just (0, "hi team"), Just "./tests/fixtures/test.jpg")]) alice @@@ [("#team", "hey bob"), ("@bob", "sent invitation to join group team as admin"), ("@cath", "sent invitation to join group team as admin")] bob #$> ("/_get chat #1 count=100", chat'', [((1, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (1, "hi team"), Just "./tests/tmp/test.jpg")]) - bob @@@ [("#team", "hey bob"), ("@alice","received invitation to join group team as admin")] + bob @@@ [("#team", "hey bob"), ("@alice", "received invitation to join group team as admin")] cath #$> ("/_get chat #1 count=100", chat'', [((0, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (0, "hi team"), Just "./tests/tmp/test_1.jpg")]) - cath @@@ [("#team", "hey bob"), ("@alice","received invitation to join group team as admin")] + cath @@@ [("#team", "hey bob"), ("@alice", "received invitation to join group team as admin")] testUserContactLink :: Spec testUserContactLink = versionTestMatrix3 $ \alice bob cath -> do diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index ee6eae98c3..b8e9b01cd1 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -50,18 +50,18 @@ contactSubSummary = "{\"resp\":{\"contactSubSummary\":{\"contactSubscriptions\": contactSubSummary = "{\"resp\":{\"type\":\"contactSubSummary\",\"contactSubscriptions\":[]}}" #endif -memberSubErrors :: String +memberSubSummary :: String #if defined(darwin_HOST_OS) && defined(swiftJSON) -memberSubErrors = "{\"resp\":{\"memberSubErrors\":{\"memberSubErrors\":[]}}}" +memberSubSummary = "{\"resp\":{\"memberSubSummary\":{\"memberSubscriptions\":[]}}}" #else -memberSubErrors = "{\"resp\":{\"type\":\"memberSubErrors\",\"memberSubErrors\":[]}}" +memberSubSummary = "{\"resp\":{\"type\":\"memberSubSummary\",\"memberSubscriptions\":[]}}" #endif pendingSubSummary :: String #if defined(darwin_HOST_OS) && defined(swiftJSON) -pendingSubSummary = "{\"resp\":{\"pendingSubSummary\":{\"pendingSubStatus\":[]}}}" +pendingSubSummary = "{\"resp\":{\"pendingSubSummary\":{\"pendingSubscriptions\":[]}}}" #else -pendingSubSummary = "{\"resp\":{\"type\":\"pendingSubSummary\",\"pendingSubStatus\":[]}}" +pendingSubSummary = "{\"resp\":{\"type\":\"pendingSubSummary\",\"pendingSubscriptions\":[]}}" #endif parsedMarkdown :: String @@ -89,7 +89,7 @@ testChatApi = withTmpFiles $ do chatSendCmd cc "/u alice Alice" `shouldReturn` activeUserExists chatSendCmd cc "/_start" `shouldReturn` chatStarted chatRecvMsg cc `shouldReturn` contactSubSummary - chatRecvMsg cc `shouldReturn` memberSubErrors + chatRecvMsg cc `shouldReturn` memberSubSummary chatRecvMsgWait cc 10000 `shouldReturn` pendingSubSummary chatRecvMsgWait cc 10000 `shouldReturn` "" chatParseMarkdown "hello" `shouldBe` "{}"