diff --git a/cabal.project b/cabal.project index 63e85073a1..0756146fe0 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: c4b687ba644d8f0581a9f4317b6211c493a8d685 + tag: 6aadcf1f3fc19cbc0c8be457556fbaaffb0bfc46 source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index fdf8735197..8f77a6505e 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."c4b687ba644d8f0581a9f4317b6211c493a8d685" = "0s6wnmxjjr3fgfayyn0rdgwkqsg4z6da6ha0sq78mavvplwhg21m"; + "https://github.com/simplex-chat/simplexmq.git"."6aadcf1f3fc19cbc0c8be457556fbaaffb0bfc46" = "1qlm542jnik48zid3zy7iys7ybjmlmj3mjhc5aplfk410a5qsb93"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 5b445cf460..8e1e6705df 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -707,8 +707,8 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI if | inline -> do -- accepting inline - ci <- withStore $ \db -> acceptRcvInlineFT db vr user fileId filePath - sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId + (ci, sharedMsgId) <- withStore $ \db -> + liftM2 (,) (acceptRcvInlineFT db vr user fileId filePath) (getSharedMsgIdByFileId db userId fileId) send $ XFileAcptInv sharedMsgId Nothing fName pure ci | fileInline == Just IFMSent -> throwChatError $ CEFileAlreadyReceiving fName @@ -925,9 +925,11 @@ acceptGroupJoinRequestAsync incognitoProfile = do gVar <- asks random let initialStatus = acceptanceToStatus (memberAdmission groupProfile) gAccepted - (groupMemberId, memberId) <- withStore $ \db -> - createJoiningMember db gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ welcomeMsgId_ gLinkMemRole initialStatus - currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo + ((groupMemberId, memberId), currentMemCount) <- withStore $ \db -> + liftM2 + (,) + (createJoiningMember db gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ welcomeMsgId_ gLinkMemRole initialStatus) + (liftIO $ getGroupCurrentMembersCount db user gInfo) let Profile {displayName} = userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile) GroupMember {memberRole = userRole, memberId = userMemberId} = membership msg = @@ -1041,15 +1043,13 @@ introduceToModerators vr user gInfo@GroupInfo {groupId} m@GroupMember {memberRol introduceToAll :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM () introduceToAll vr user gInfo m = do - members <- withStore' $ \db -> getGroupMembers db vr user gInfo - vector <- withStore (`getMemberRelationsVector` m) + (members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db vr user gInfo) (getMemberRelationsVector db m) let recipients = filter (shouldIntroduce m vector) members introduceMember user gInfo m recipients Nothing introduceToRemaining :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM () introduceToRemaining vr user gInfo m = do - members <- withStore' $ \db -> getGroupMembers db vr user gInfo - vector <- withStore (`getMemberRelationsVector` m) + (members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db vr user gInfo) (getMemberRelationsVector db m) let recipients = filter (shouldIntroduce m vector) members introduceMember user gInfo m recipients Nothing diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 625e879607..e10bf2a081 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -691,9 +691,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- TODO REMOVE LEGACY vvv -- [async agent commands] group link auto-accept continuation on receiving INV CFCreateConnGrpInv -> do - ct <- withStore $ \db -> getContactViaMember db vr user m - withStore' $ \db -> setNewContactMemberConnRequest db user m cReq - groupLinkId <- withStore' $ \db -> getGroupLinkId db user gInfo + (ct, groupLinkId) <- withStore $ \db -> do + ct <- getContactViaMember db vr user m + liftIO $ setNewContactMemberConnRequest db user m cReq + liftIO $ (ct,) <$> getGroupLinkId db user gInfo sendGrpInvitation ct m groupLinkId toView $ CEvtSentGroupInvitation user gInfo ct m where @@ -1814,8 +1815,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = ts@(_, ft_) = msgContentTexts mc live = fromMaybe False live_ updateRcvChatItem = do - cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user gInfo groupMemberId sharedMsgId - scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci) + (cci, scopeInfo) <- withStore $ \db -> do + cci <- getGroupChatItemBySharedMsgId db user gInfo groupMemberId sharedMsgId + (cci,) <$> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci) case cci of CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} -> if sameMemberId memberId m' @@ -1948,8 +1950,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xFileCancel :: Contact -> SharedMsgId -> CM () xFileCancel Contact {contactId} sharedMsgId = do - fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId - ft <- withStore (\db -> getRcvFileTransfer db user fileId) + (fileId, ft) <- withStore $ \db -> do + fileId <- getFileIdBySharedMsgId db userId contactId sharedMsgId + (fileId,) <$> getRcvFileTransfer db user fileId unless (rcvFileCompleteOrCancelled ft) $ do cancelRcvFileTransfer user ft ci <- withStore $ \db -> getChatItemByFileId db vr user fileId @@ -1957,8 +1960,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM () xFileAcptInv ct sharedMsgId fileConnReq_ fName = do - fileId <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId - (AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId + (fileId, AChatItem _ _ _ ci) <- withStore $ \db -> do + fileId <- getDirectFileIdBySharedMsgId db user ct sharedMsgId + (fileId,) <$> getChatItemByFileId db vr user fileId assertSMPAcceptNotProhibited ci ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId) -- [async agent commands] no continuation needed, but command should be asynchronous for stability @@ -2033,8 +2037,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xFileCancelGroup g@GroupInfo {groupId} GroupMember {memberId} sharedMsgId = do (fileId, aci) <- withStore $ \db -> do fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId - aci <- getChatItemByFileId db vr user fileId - pure (fileId, aci) + (fileId,) <$> getChatItemByFileId db vr user fileId case aci of AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir = CIGroupRcv m} -> do if sameMemberId memberId m @@ -2051,8 +2054,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM () xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do - fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId - (AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId + (fileId, AChatItem _ _ _ ci) <- withStore $ \db -> do + fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId + (fileId,) <$> getChatItemByFileId db vr user fileId assertSMPAcceptNotProhibited ci -- TODO check that it's not already accepted ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId) @@ -2123,8 +2127,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xDirectDel c msg msgMeta = if directOrUsed c then do - ct' <- withStore' $ \db -> updateContactStatus db user c CSDeleted - contactConns <- withStore' $ \db -> getContactConnections db vr userId ct' + (ct', contactConns) <- withStore' $ \db -> do + ct' <- updateContactStatus db user c CSDeleted + (ct',) <$> getContactConnections db vr userId ct' deleteAgentConnectionsAsync $ map aConnId contactConns forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted} @@ -2496,15 +2501,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = associateMemberWithContact :: Contact -> GroupMember -> CM Contact associateMemberWithContact c1 m2@GroupMember {groupId} = do - withStore' $ \db -> associateMemberWithContactRecord db user c1 m2 - g <- withStore $ \db -> getGroupInfo db vr user groupId + g <- withStore $ \db -> do + liftIO $ associateMemberWithContactRecord db user c1 m2 + getGroupInfo db vr user groupId toView $ CEvtContactAndMemberAssociated user c1 g m2 c1 pure c1 associateContactWithMember :: GroupMember -> Contact -> CM Contact associateContactWithMember m1@GroupMember {groupId} c2 = do - c2' <- withStore $ \db -> associateContactWithMemberRecord db vr user m1 c2 - g <- withStore $ \db -> getGroupInfo db vr user groupId + (c2', g) <- withStore $ \db -> + liftM2 (,) (associateContactWithMemberRecord db vr user m1 c2) (getGroupInfo db vr user groupId) toView $ CEvtContactAndMemberAssociated user c2 g m1 c2' pure c2' @@ -2622,19 +2628,21 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _) IntroInvitation {groupConnReq, directConnReq} = do let GroupMember {memberId = membershipMemId} = membership checkHostRole m memRole - toMember <- - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case + toMember <- withStore $ \db -> do + toMember <- getGroupMemberByMemberId db vr user gInfo memId -- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent -- the situation when member does not exist is an error -- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that. -- For now, this branch compensates for the lack of delayed message delivery. - Left _ -> withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced - Right m' -> pure m' - -- TODO [knocking] separate pending statuses from GroupMemberStatus? - -- TODO add GSMemIntroInvitedPending, GSMemConnectedPending, etc.? - -- TODO keep as is? (GSMemIntroInvited has no purpose) - let newMemberStatus = if memberPending toMember then memberStatus toMember else GSMemIntroInvited - withStore' $ \db -> updateGroupMemberStatus db userId toMember newMemberStatus + `catchError` \case + SEGroupMemberNotFoundByMemberId _ -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced + e -> throwError e + -- TODO [knocking] separate pending statuses from GroupMemberStatus? + -- TODO add GSMemIntroInvitedPending, GSMemConnectedPending, etc.? + -- TODO keep as is? (GSMemIntroInvited has no purpose) + let newMemberStatus = if memberPending toMember then memberStatus toMember else GSMemIntroInvited + liftIO $ updateGroupMemberStatus db userId toMember newMemberStatus + pure toMember subMode <- chatReadVar subscriptionMode -- [incognito] send membership incognito profile, create direct connection as incognito let membershipProfile = redactedMemberProfile allowSimplexLinks $ fromLocalProfile $ memberProfile membership @@ -3021,14 +3029,15 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = updateGroupItemsStatus :: GroupInfo -> GroupMember -> Connection -> AgentMsgId -> GroupSndStatus -> Maybe Bool -> CM () updateGroupItemsStatus gInfo@GroupInfo {groupId} GroupMember {groupMemberId} Connection {connId} msgId newMemStatus viaProxy_ = do - items <- withStore' (\db -> getGroupChatItemsByAgentMsgId db user groupId connId msgId) - cis <- catMaybes <$> withStore (\db -> mapM (updateItem db) items) - -- SENT and RCVD events are received for messages that may be batched in single scope, - -- so we can look up scope of first item - scopeInfo <- case cis of - (ci : _) -> withStore $ \db -> getGroupChatScopeInfoForItem db vr user gInfo (chatItemId' ci) - _ -> pure Nothing - let acis = map (gItem scopeInfo) cis + acis <- withStore $ \db -> do + items <- liftIO $ getGroupChatItemsByAgentMsgId db user groupId connId msgId + cis <- catMaybes <$> mapM (updateItem db) items + -- SENT and RCVD events are received for messages that may be batched in single scope, + -- so we can look up scope of first item + scopeInfo <- case cis of + (ci : _) -> getGroupChatScopeInfoForItem db vr user gInfo (chatItemId' ci) + _ -> pure Nothing + pure $ map (gItem scopeInfo) cis unless (null acis) $ toView $ CEvtChatItemsStatusesUpdated user acis where gItem scopeInfo ci = AChatItem SCTGroup SMDSnd (GroupChat gInfo scopeInfo) ci diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index a0fdb07046..fadc65960b 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -1596,11 +1596,11 @@ setMemberVectorNewRelations db GroupMember {groupMemberId} relations = do v_ <- maybeFirstRow fromOnly $ DB.query db + ( "SELECT member_relations_vector FROM group_members WHERE group_member_id = ?" #if defined(dbPostgres) - "SELECT member_relations_vector FROM group_members WHERE group_member_id = ? FOR UPDATE" -#else - "SELECT member_relations_vector FROM group_members WHERE group_member_id = ?" + <> " FOR UPDATE" #endif + ) (Only groupMemberId) let v' = setNewRelations relations $ fromMaybe B.empty v_ currentTs <- getCurrentTime @@ -1638,11 +1638,11 @@ setMemberVectorRelationConnected db GroupMember {groupMemberId} GroupMember {ind firstRow fromOnly (SEMemberRelationsVectorNotFound groupMemberId) $ DB.query db + ( "SELECT member_relations_vector FROM group_members WHERE group_member_id = ? AND member_relations_vector IS NOT NULL" #if defined(dbPostgres) - "SELECT member_relations_vector FROM group_members WHERE group_member_id = ? AND member_relations_vector IS NOT NULL FOR UPDATE" -#else - "SELECT member_relations_vector FROM group_members WHERE group_member_id = ? AND member_relations_vector IS NOT NULL" + <> " FOR UPDATE" #endif + ) (Only groupMemberId) let v' = setRelationConnected indexInGroup newStatus v currentTs <- liftIO getCurrentTime diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 797d0cba11..e3b6911b59 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -52,7 +52,6 @@ module Simplex.Chat.Store.Messages getDirectChatItemLast, getAllChatItems, getAChatItem, - getAChatItemBySharedMsgId, updateDirectChatItem, updateDirectChatItem', addInitialAndNewCIVersions, @@ -1235,13 +1234,17 @@ getDirectChatItemLast db user@User {userId} contactId = do ExceptT . firstRow fromOnly (SEChatItemNotFoundByContactId contactId) $ DB.query db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND contact_id = ? - ORDER BY created_at DESC, chat_item_id DESC - LIMIT 1 - |] + ( [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND contact_id = ? + ORDER BY created_at DESC, chat_item_id DESC + LIMIT 1 + |] +#if defined(dbPostgres) + <> " FOR UPDATE" +#endif + ) (userId, contactId) getDirectChatItem db user contactId chatItemId @@ -1560,13 +1563,17 @@ getGroupMemberChatItemLast db user@User {userId} groupId groupMemberId = do ExceptT . firstRow fromOnly (SEChatItemNotFoundByGroupId groupId) $ DB.query db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND group_member_id = ? - ORDER BY item_ts DESC, chat_item_id DESC - LIMIT 1 - |] + ( [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND group_member_id = ? + ORDER BY item_ts DESC, chat_item_id DESC + LIMIT 1 + |] +#if defined(dbPostgres) + <> " FOR UPDATE" +#endif + ) (userId, groupId, groupMemberId) getGroupChatItem db user groupId chatItemId @@ -3243,15 +3250,6 @@ getAChatItem db vr user (ChatRef cType chatId scope) itemId = do _ -> throwError $ SEChatItemNotFound itemId liftIO $ getACIReactions db aci -getAChatItemBySharedMsgId :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> SharedMsgId -> ExceptT StoreError IO AChatItem -getAChatItemBySharedMsgId db user cd sharedMsgId = case cd of - CDDirectRcv ct@Contact {contactId} -> do - (CChatItem msgDir ci) <- getDirectChatItemBySharedMsgId db user contactId sharedMsgId - pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci - CDGroupRcv g scopeInfo GroupMember {groupMemberId} -> do - (CChatItem msgDir ci) <- getGroupChatItemBySharedMsgId db user g groupMemberId sharedMsgId - pure $ AChatItem SCTGroup msgDir (GroupChat g scopeInfo) ci - getChatItemVersions :: DB.Connection -> ChatItemId -> IO [ChatItemVersion] getChatItemVersions db itemId = do map toChatItemVersion diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 42d59cfa9f..45ae34be0a 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -1167,8 +1167,7 @@ testCapthaScreening ps = bob <## "/'filter 1 off' - disable filter" -- connect with captcha screen _ <- join cath groupLink - cath ##> "/_send #1(_support) text 123" -- sending incorrect captcha - cath <# "#privacy (support) 123" + cath #> "#privacy (support) 123" -- sending incorrect captcha cath <# "#privacy (support) 'SimpleX Directory'!> > cath 123" cath <## " Incorrect text, please try again." captcha <- dropStrPrefix "#privacy (support) 'SimpleX Directory'> " . dropTime <$> getTermLine cath @@ -1220,8 +1219,7 @@ testCapthaScreening ps = cath <## "Send captcha text to join the group privacy." dropStrPrefix "#privacy (support) 'SimpleX Directory'> " . dropTime <$> getTermLine cath sendCaptcha cath captcha = do - cath ##> ("/_send #1(_support) text " <> captcha) - cath <# ("#privacy (support) " <> captcha) + cath #> ("#privacy (support) " <> captcha) cath <# ("#privacy (support) 'SimpleX Directory'!> > cath " <> captcha) cath <## " Correct, you joined the group privacy" cath <## "#privacy: you joined the group" @@ -1411,8 +1409,10 @@ submitGroup u n fn = do groupAccepted :: TestCC -> String -> IO String groupAccepted u n = do - u <# ("'SimpleX Directory'> Joining the group " <> n <> "…") - u <## ("#" <> viewName n <> ": 'SimpleX Directory' joined the group") + u <### + [ WithTime ("'SimpleX Directory'> Joining the group " <> n <> "…"), + ConsoleString ("#" <> viewName n <> ": 'SimpleX Directory' joined the group") + ] u <# ("'SimpleX Directory'> Joined the group " <> n <> ", creating the link…") u <# "'SimpleX Directory'> Created the public link to join the group via this directory service that is always online." u <## "" diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index e258f3dccc..8408fc0098 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -84,7 +84,7 @@ schemaDumpDBOpts = DBOpts { connstr = B.pack testDBConnstr, schema = "test_chat_schema", - poolSize = 3, + poolSize = 10, createSchema = True } @@ -131,7 +131,7 @@ testCoreOpts = -- dbSchemaPrefix is not used in tests (except bot tests where it's redefined), -- instead different schema prefix is passed per client so that single test database is used dbSchemaPrefix = "", - dbPoolSize = 1, + dbPoolSize = 10, dbCreateSchema = True #else { dbFilePrefix = "./simplex_v1", -- dbFilePrefix is not used in tests (except bot tests where it's redefined) @@ -424,7 +424,10 @@ testChatN cfg opts ps test params = ( TestCC -> IO String -getTermLine cc@TestCC {printOutput} = +getTermLine = getTermLine' Nothing + +getTermLine' :: HasCallStack => Maybe String -> TestCC -> IO String +getTermLine' expected cc@TestCC {printOutput} = 5000000 `timeout` atomically (readTQueue $ termQ cc) >>= \case Just s -> do -- remove condition to always echo virtual terminal @@ -433,7 +436,12 @@ getTermLine cc@TestCC {printOutput} = name <- userName cc putStrLn $ name <> ": " <> s pure s - _ -> error "no output for 5 seconds" + Nothing -> do + name <- userName cc + let expectedMsg = case expected of + Just e -> ", expected: " <> show e + Nothing -> "" + error $ name <> ": no output for 5 seconds" <> expectedMsg userName :: TestCC -> IO [Char] userName (TestCC ChatController {currentUser} _ _ _ _ _) = diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 121d5a92f8..16cf968437 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -2071,11 +2071,8 @@ testSharedMessageBody ps' = ] bob <# "#team alice> hello" cath <# "#team alice> hello" --- because of PostgreSQL concurrency deleteSndMsgDelivery fails to delete message body -#if !defined(dbPostgres) threadDelay 500000 checkMsgBodyCount alice 0 -#endif alice <## "disconnected 4 connections on server localhost" where @@ -2130,10 +2127,7 @@ testSharedBatchBody ps = concurrently_ (bob <# ("#team alice> message " <> show i)) (cath <# ("#team alice> message " <> show i)) --- because of PostgreSQL concurrency deleteSndMsgDelivery fails to delete message body -#if !defined(dbPostgres) checkMsgBodyCount alice 0 -#endif alice <## "disconnected 4 connections on server localhost" where diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index dded39e692..756ee47727 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -171,7 +171,8 @@ cc ?#> cmd = do (#$>) :: (Eq a, Show a, HasCallStack) => TestCC -> (String, String -> a, a) -> Expectation cc #$> (cmd, f, res) = do cc ##> cmd - (f <$> getTermLine cc) `shouldReturn` res + let expected = "result of " <> cmd <> ": " <> show res + (f <$> getTermLine' (Just expected) cc) `shouldReturn` res -- / PQ combinators @@ -345,7 +346,7 @@ chats = mapChats . read getChats :: HasCallStack => (Eq a, Show a) => ([(String, String, Maybe ConnStatus)] -> [a]) -> TestCC -> [a] -> Expectation getChats f cc res = do cc ##> "/_get chats 1 pcc=on" - line <- getTermLine cc + line <- getTermLine' (Just "chat list") cc f (read line) `shouldMatchList` res send :: TestCC -> String -> IO () @@ -353,41 +354,41 @@ send TestCC {chatController = cc} cmd = atomically $ writeTBQueue (inputQ cc) cm (<##) :: HasCallStack => TestCC -> String -> Expectation cc <## line = do - l <- getTermLine cc + l <- getTermLine' (Just line) cc when (l /= line) $ print ("expected: " <> line, ", got: " <> l) l `shouldBe` line (<##.) :: HasCallStack => TestCC -> String -> Expectation cc <##. line = do - l <- getTermLine cc + l <- getTermLine' (Just $ "prefix: " <> line) cc let prefix = line `isPrefixOf` l unless prefix $ print ("expected to start from: " <> line, ", got: " <> l) prefix `shouldBe` True (.<##) :: HasCallStack => TestCC -> String -> Expectation cc .<## line = do - l <- getTermLine cc + l <- getTermLine' (Just $ "suffix: " <> line) cc let suffix = line `isSuffixOf` l unless suffix $ print ("expected to end with: " <> line, ", got: " <> l) suffix `shouldBe` True (<#.) :: HasCallStack => TestCC -> String -> Expectation cc <#. line = do - l <- dropTime <$> getTermLine cc + l <- dropTime <$> getTermLine' (Just $ "prefix: " <> line) cc let prefix = line `isPrefixOf` l unless prefix $ print ("expected to start from: " <> line, ", got: " <> l) prefix `shouldBe` True (.<#) :: HasCallStack => TestCC -> String -> Expectation cc .<# line = do - l <- dropTime <$> getTermLine cc + l <- dropTime <$> getTermLine' (Just $ "suffix: " <> line) cc let suffix = line `isSuffixOf` l unless suffix $ print ("expected to end with: " <> line, ", got: " <> l) suffix `shouldBe` True (<##..) :: HasCallStack => TestCC -> [String] -> Expectation cc <##.. ls = do - l <- getTermLine cc + l <- getTermLine' (Just $ "one of prefixes: " <> show ls) cc let prefix = any (`isPrefixOf` l) ls unless prefix $ print ("expected to start from one of: " <> show ls, ", got: " <> l) prefix `shouldBe` True @@ -395,7 +396,8 @@ cc <##.. ls = do (>*) :: HasCallStack => TestCC -> String -> IO () cc >* note = do cc `send` ("/* " <> note) - (dropTime <$> getTermLine cc) `shouldReturn` ("* " <> note) + let expected = "* " <> note + (dropTime <$> getTermLine' (Just expected) cc) `shouldReturn` expected data ConsoleResponse = ConsoleString String @@ -404,13 +406,21 @@ data ConsoleResponse | StartsWith String | Predicate (String -> Bool) +instance Show ConsoleResponse where + show (ConsoleString s) = show s + show (WithTime s) = "WithTime " <> show s + show (EndsWith s) = "EndsWith " <> show s + show (StartsWith s) = "StartsWith " <> show s + show (Predicate _) = "" + instance IsString ConsoleResponse where fromString = ConsoleString -- this assumes that the string can only match one option getInAnyOrder :: HasCallStack => (String -> String) -> TestCC -> [ConsoleResponse] -> Expectation getInAnyOrder _ _ [] = pure () getInAnyOrder f cc ls = do - line <- f <$> getTermLine cc + let expectedDesc = "one of " <> show (length ls) <> " responses: " <> show ls + line <- f <$> getTermLine' (Just expectedDesc) cc let rest = filterFirst (expected line) ls if length rest < length ls then getInAnyOrder f cc rest @@ -436,25 +446,27 @@ getInAnyOrder f cc ls = do (<##?) = getInAnyOrder dropTime (<#) :: HasCallStack => TestCC -> String -> Expectation -cc <# line = (dropTime <$> getTermLine cc) `shouldReturn` line +cc <# line = (dropTime <$> getTermLine' (Just line) cc) `shouldReturn` line (*<#) :: HasCallStack => [TestCC] -> String -> Expectation ccs *<# line = mapConcurrently_ (<# line) ccs (?<#) :: HasCallStack => TestCC -> String -> Expectation -cc ?<# line = (dropTime <$> getTermLine cc) `shouldReturn` "i " <> line +cc ?<# line = do + let expected = "i " <> line + (dropTime <$> getTermLine' (Just expected) cc) `shouldReturn` expected ($<#) :: HasCallStack => (TestCC, String) -> String -> Expectation -(cc, uName) $<# line = (dropTime . dropUser uName <$> getTermLine cc) `shouldReturn` line +(cc, uName) $<# line = (dropTime . dropUser uName <$> getTermLine' (Just $ "for user " <> uName <> ": " <> line) cc) `shouldReturn` line (^<#) :: HasCallStack => (TestCC, String) -> String -> Expectation -(cc, p) ^<# line = (dropTime . dropStrPrefix p <$> getTermLine cc) `shouldReturn` line +(cc, p) ^<# line = (dropTime . dropStrPrefix p <$> getTermLine' (Just $ "without prefix " <> p <> ": " <> line) cc) `shouldReturn` line (⩗) :: HasCallStack => TestCC -> String -> Expectation -cc ⩗ line = (dropTime . dropReceipt <$> getTermLine cc) `shouldReturn` line +cc ⩗ line = (dropTime . dropReceipt <$> getTermLine' (Just $ "receipt: " <> line) cc) `shouldReturn` line (%) :: HasCallStack => TestCC -> String -> Expectation -cc % line = (dropTime . dropPartialReceipt <$> getTermLine cc) `shouldReturn` line +cc % line = (dropTime . dropPartialReceipt <$> getTermLine' (Just $ "partial receipt: " <> line) cc) `shouldReturn` line ( TestCC -> Expectation ( TestCC -> IO (String, String) getInvitations cc = do shortInv <- getInvitation_ cc cc <##. "The invitation link for old clients:" - fullInv <- getTermLine cc + fullInv <- getTermLine' (Just "full invitation link") cc pure (shortInv, fullInv) getInvitationNoShortLink :: HasCallStack => TestCC -> IO String @@ -537,7 +549,7 @@ getInvitation_ :: HasCallStack => TestCC -> IO String getInvitation_ cc = do cc <## "pass this invitation link to your contact (via another channel):" cc <## "" - inv <- getTermLine cc + inv <- getTermLine' (Just "invitation link") cc cc <## "" cc <## "and ask them to connect: /c " pure inv @@ -550,7 +562,8 @@ getContactLink cc created = do getContactLinks :: HasCallStack => TestCC -> Bool -> IO (String, String) getContactLinks cc created = do shortLink <- getContactLink_ cc created - fullLink <- dropLinePrefix "The contact link for old clients: " =<< getTermLine cc + line <- getTermLine' (Just "full contact link line") cc + fullLink <- dropLinePrefix "The contact link for old clients: " line pure (shortLink, fullLink) getContactLinkNoShortLink :: HasCallStack => TestCC -> Bool -> IO String @@ -560,7 +573,7 @@ getContactLink_ :: HasCallStack => TestCC -> Bool -> IO String getContactLink_ cc created = do cc <## if created then "Your new chat address is created!" else "Your chat address:" cc <## "" - link <- getTermLine cc + link <- getTermLine' (Just "contact link") cc cc <## "" cc <## "Anybody can send you contact requests with: /c " cc <## "to show it again: /sa" @@ -581,7 +594,8 @@ getGroupLink cc gName mRole created = do getGroupLinks :: HasCallStack => TestCC -> String -> GroupMemberRole -> Bool -> IO (String, String) getGroupLinks cc gName mRole created = do shortLink <- getGroupLink_ cc gName mRole created - fullLink <- dropLinePrefix "The group link for old clients: " =<< getTermLine cc + line <- getTermLine' (Just "full group link line") cc + fullLink <- dropLinePrefix "The group link for old clients: " line pure (shortLink, fullLink) getGroupLinkNoShortLink :: HasCallStack => TestCC -> String -> GroupMemberRole -> Bool -> IO String @@ -591,7 +605,7 @@ getGroupLink_ :: HasCallStack => TestCC -> String -> GroupMemberRole -> Bool -> getGroupLink_ cc gName mRole created = do cc <## if created then "Group link is created!" else "Group link:" cc <## "" - link <- getTermLine cc + link <- getTermLine' (Just $ "group link for " <> gName) cc cc <## "" cc <## ("Anybody can connect to you and join group as " <> T.unpack (textEncode mRole) <> " with: /c ") cc <## ("to show it again: /show link #" <> gName) @@ -669,7 +683,7 @@ getTestCCContact cc contactId = do lastItemId :: HasCallStack => TestCC -> IO String lastItemId cc = do cc ##> "/last_item_id" - getTermLine cc + getTermLine' (Just "last item id") cc showActiveUser :: HasCallStack => TestCC -> String -> Expectation showActiveUser cc name = do