diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index b78b446821..b5f7220724 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -351,11 +351,11 @@ searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pa pure (gs, n) Just gId -> do gs <- groups $ DB.query db (listedGroupQuery <> " AND r.group_id > ? " <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, gId, pageSize) - n <- count $ DB.query db (countQuery' <> " AND r.group_id > ? " <> orderBy) (GRSActive, gId) + n <- count $ DB.query db (countQuery' <> " AND r.group_id > ?") (GRSActive, gId) pure (gs, n) where countQuery' = countQuery <> " WHERE r.group_reg_status = ? " - orderBy = " ORDER BY g.summary_current_members_count DESC " + orderBy = " ORDER BY g.summary_current_members_count DESC, r.group_reg_id ASC " STRecent -> case lastGroup_ of Nothing -> do gs <- groups $ DB.query db (listedGroupQuery <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, pageSize) @@ -363,11 +363,11 @@ searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pa pure (gs, n) Just gId -> do gs <- groups $ DB.query db (listedGroupQuery <> " AND r.group_id > ? " <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, gId, pageSize) - n <- count $ DB.query db (countQuery' <> " AND r.group_id > ? " <> orderBy) (GRSActive, gId) + n <- count $ DB.query db (countQuery' <> " AND r.group_id > ?") (GRSActive, gId) pure (gs, n) where countQuery' = countQuery <> " WHERE r.group_reg_status = ? " - orderBy = " ORDER BY r.created_at DESC " + orderBy = " ORDER BY r.created_at DESC, r.group_reg_id ASC " STSearch search -> case lastGroup_ of Nothing -> do gs <- groups $ DB.query db (listedGroupQuery <> searchCond <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, s, s, s, s, pageSize) @@ -375,12 +375,12 @@ searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pa pure (gs, n) Just gId -> do gs <- groups $ DB.query db (listedGroupQuery <> " AND r.group_id > ? " <> searchCond <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, gId, s, s, s, s, pageSize) - n <- count $ DB.query db (countQuery' <> " AND r.group_id > ? " <> searchCond <> orderBy) (GRSActive, gId, s, s, s, s) + n <- count $ DB.query db (countQuery' <> " AND r.group_id > ? " <> searchCond) (GRSActive, gId, s, s, s, s) pure (gs, n) where s = T.toLower search countQuery' = countQuery <> " JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id WHERE r.group_reg_status = ? " - orderBy = " ORDER BY g.summary_current_members_count DESC " + orderBy = " ORDER BY g.summary_current_members_count DESC, r.group_reg_id ASC " where groups = (map (toGroupInfoReg (vr cc) user) <$>) count = maybeFirstRow' 0 fromOnly diff --git a/cabal.project b/cabal.project index e9842b1138..e5d7464ece 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: 5f73d1e629a8807f1b9d94f8b411d6480a0a59fb + tag: a7b43b1a3e204759d4b7ad60928fa897b1600654 source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 3cfc2a05af..16454f63d1 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."5f73d1e629a8807f1b9d94f8b411d6480a0a59fb" = "1w5mxw9rwiiiqphbg2rdyp4cvv9hz2l64f7fpfhncw6gncfx7ggw"; + "https://github.com/simplex-chat/simplexmq.git"."a7b43b1a3e204759d4b7ad60928fa897b1600654" = "169vjn5gyw42cmak6kwyl27zm57il43khnlj40zjwjw7cldkzdzi"; "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/Controller.hs b/src/Simplex/Chat/Controller.hs index 34ad95b800..5754419933 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -96,7 +96,12 @@ import Simplex.RemoteControl.Types import System.IO (Handle) import System.Mem.Weak (Weak) import UnliftIO.STM -#if !defined(dbPostgres) + +#if defined(dbPostgres) +import qualified Database.PostgreSQL.Simple as PSQL + +type SQLError = PSQL.SqlError +#else import Database.SQLite.Simple (SQLError) import qualified Database.SQLite.Simple as SQL import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..)) @@ -1542,25 +1547,24 @@ withFastStore = withStorePriority True withStorePriority :: Bool -> (DB.Connection -> ExceptT StoreError IO a) -> CM a withStorePriority priority action = do ChatController {chatStore} <- ask - liftIOEither $ withTransactionPriority chatStore priority (runExceptT . withExceptT ChatErrorStore . action) `E.catches` handleDBErrors + liftIOEither $ withTransactionPriority chatStore priority (runExceptT . withExceptT ChatErrorStore . action) `E.catch` handleDBErrors withStoreBatch :: Traversable t => (DB.Connection -> t (IO (Either ChatError a))) -> CM' (t (Either ChatError a)) withStoreBatch actions = do ChatController {chatStore} <- ask - liftIO $ withTransaction chatStore $ mapM (`E.catches` handleDBErrors) . actions + liftIO $ withTransaction chatStore $ mapM (`E.catch` handleDBErrors) . actions --- TODO [postgres] postgres specific error handling -handleDBErrors :: [E.Handler (Either ChatError a)] -handleDBErrors = -#if !defined(dbPostgres) - ( E.Handler $ \(e :: SQLError) -> - let se = SQL.sqlError e - busy = se == SQL.ErrorBusy || se == SQL.ErrorLocked - in pure . Left . ChatErrorStore $ if busy then SEDBBusyError $ show se else SEDBException $ show e - ) : +handleDBErrors :: E.SomeException -> IO (Either ChatError a) +handleDBErrors e = pure $ Left $ ChatErrorStore $ case E.fromException e of + Just (e' :: SQLError) -> +#if defined(dbPostgres) + SEDBException $ show e' +#else + let se = SQL.sqlError e' + busy = se == SQL.ErrorBusy || se == SQL.ErrorLocked + in (if busy then SEDBBusyError else SEDBException) $ show e' #endif - [ E.Handler $ \(E.SomeException e) -> pure . Left . ChatErrorStore . SEDBException $ show e - ] + Nothing -> SEDBException $ show e withStoreBatch' :: Traversable t => (DB.Connection -> t (IO a)) -> CM' (t (Either ChatError a)) withStoreBatch' actions = withStoreBatch $ fmap (fmap Right) . actions diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index fc6a0ea782..675ca03a8a 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -262,7 +262,7 @@ stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd) atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd) disconnectAgentClient smpAgent - readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2) + readTVarIO s >>= mapM_ (\(a1, a2) -> forkIO $ uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2) closeFiles sndFiles closeFiles rcvFiles atomically $ do @@ -1805,7 +1805,7 @@ processChatCommand vr nm = \case conn <- withFastStore $ \db -> getPendingContactConnection db userId connId let PendingContactConnection {pccConnStatus, connLinkInv} = conn case (pccConnStatus, connLinkInv) of - (ConnNew, Just _ссLink) -> do + (ConnNew, Just _ccLink) -> do newUser <- privateGetUser newUserId conn' <- recreateConn user conn newUser pure $ CRConnectionUserChanged user conn conn' newUser diff --git a/src/Simplex/Chat/Options/Postgres.hs b/src/Simplex/Chat/Options/Postgres.hs index c74ae37750..ab7414566c 100644 --- a/src/Simplex/Chat/Options/Postgres.hs +++ b/src/Simplex/Chat/Options/Postgres.hs @@ -42,7 +42,7 @@ chatDbOptsP _appDir defaultDbName = do ( long "pool-size" <> metavar "DB_POOL_SIZE" <> help "Database connection pool size" - <> value 10 + <> value 1 <> showDefault ) dbCreateSchema <- @@ -84,7 +84,7 @@ mobileDbOpts schemaPrefix connstr = do ChatDbOpts { dbConnstr, dbSchemaPrefix, - dbPoolSize = 10, + dbPoolSize = 1, dbCreateSchema = True } diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index d0b186dd94..e258f3dccc 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -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 = 3, + dbPoolSize = 1, dbCreateSchema = True #else { dbFilePrefix = "./simplex_v1", -- dbFilePrefix is not used in tests (except bot tests where it's redefined) @@ -184,16 +184,11 @@ aCfg = (agentConfig defaultChatConfig) {tbqSize = 16} testAgentCfg :: AgentConfig testAgentCfg = aCfg - { reconnectInterval = (reconnectInterval aCfg) {initialInterval = 50000} - } - -testAgentCfgSlow :: AgentConfig -testAgentCfgSlow = - testAgentCfg - { smpClientVRange = mkVersionRange (Version 1) srvHostnamesSMPClientVersion, -- v2 - smpAgentVRange = mkVersionRange duplexHandshakeSMPAgentVersion pqdrSMPAgentVersion, -- v5 - smpCfg = (smpCfg testAgentCfg) {serverVRange = mkVersionRange minClientSMPRelayVersion sendingProxySMPVersion} -- v8 + { reconnectInterval = (reconnectInterval aCfg) {initialInterval = 50000}, + messageRetryInterval = RetryInterval2 {riFast = riFast {initialInterval = 50000}, riSlow = riSlow {initialInterval = 50000}} } + where + RetryInterval2 {riFast, riSlow} = messageRetryInterval aCfg testAgentCfgNoShortLinks :: AgentConfig testAgentCfgNoShortLinks = @@ -213,9 +208,6 @@ testCfg = confirmMigrations = MCYesUp } -testCfgSlow :: ChatConfig -testCfgSlow = testCfg {agentConfig = testAgentCfgSlow} - testCfgNoShortLinks :: ChatConfig testCfgNoShortLinks = testCfg {agentConfig = testAgentCfgNoShortLinks} @@ -522,7 +514,7 @@ smpServerCfg :: ServerConfig STMMsgStore smpServerCfg = ServerConfig { transports = [(serverPort, transport @TLS, False)], - tbqSize = 1, + tbqSize = 4, msgQueueQuota = 16, maxJournalMsgCount = 24, maxJournalStateLines = 4, diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 1b93013258..a56ad6d4e3 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -94,22 +94,9 @@ chatDirectTests = do describe "operators and usage conditions" $ do it "get and enable operators, accept conditions" testOperators describe "async connection handshake" $ do - describe "connect when initiating client goes offline" $ do - it "curr" $ testAsyncInitiatingOffline True testCfg testCfg - it "v5" $ testAsyncInitiatingOffline False testCfgSlow testCfgSlow - it "v5/curr" $ testAsyncInitiatingOffline False testCfgSlow testCfg - it "curr/v5" $ testAsyncInitiatingOffline True testCfg testCfgSlow - describe "connect when accepting client goes offline" $ do - it "curr" $ testAsyncAcceptingOffline True testCfg testCfg - it "v5" $ testAsyncAcceptingOffline False testCfgSlow testCfgSlow - it "v5/curr" $ testAsyncAcceptingOffline False testCfgSlow testCfg - it "curr/v5" $ testAsyncAcceptingOffline True testCfg testCfgSlow - describe "connect, fully asynchronous (when clients are never simultaneously online)" $ do - it "curr" testFullAsyncFast - -- fails in CI - xit'' "v5" $ testFullAsyncSlow False testCfgSlow testCfgSlow - xit'' "v5/curr" $ testFullAsyncSlow False testCfgSlow testCfg - xit'' "curr/v5" $ testFullAsyncSlow True testCfg testCfgSlow + it "connect when initiating client goes offline" $ testAsyncInitiatingOffline True + it "connect when accepting client goes offline" $ testAsyncAcceptingOffline True + it "connect, fully asynchronous (when clients are never simultaneously online)" $ testFullAsyncFast describe "webrtc calls api" $ do it "negotiate call" testNegotiateCall #if !defined(dbPostgres) @@ -1241,33 +1228,33 @@ testOperators = where opts' = testOpts {coreOptions = testCoreOpts {smpServers = [], xftpServers = []}} -testAsyncInitiatingOffline :: HasCallStack => Bool -> ChatConfig -> ChatConfig -> TestParams -> IO () -testAsyncInitiatingOffline withShortLink aliceCfg bobCfg ps = do - inv <- withNewTestChatCfg ps aliceCfg "alice" aliceProfile $ \alice -> do +testAsyncInitiatingOffline :: HasCallStack => Bool -> TestParams -> IO () +testAsyncInitiatingOffline withShortLink ps = do + inv <- withNewTestChat ps "alice" aliceProfile $ \alice -> do threadDelay 250000 alice ##> "/c" (if withShortLink then getInvitation else getInvitationNoShortLink) alice - withNewTestChatCfg ps bobCfg "bob" bobProfile $ \bob -> do + withNewTestChat ps "bob" bobProfile $ \bob -> do threadDelay 250000 bob ##> ("/c " <> inv) bob <## "confirmation sent!" - withTestChatCfg ps aliceCfg "alice" $ \alice -> do + withTestChat ps "alice" $ \alice -> do alice <## "subscribed 1 connections on server localhost" concurrently_ (bob <## "alice (Alice): contact is connected") (alice <## "bob (Bob): contact is connected") -testAsyncAcceptingOffline :: HasCallStack => Bool -> ChatConfig -> ChatConfig -> TestParams -> IO () -testAsyncAcceptingOffline withShortLink aliceCfg bobCfg ps = do - inv <- withNewTestChatCfg ps aliceCfg "alice" aliceProfile $ \alice -> do +testAsyncAcceptingOffline :: HasCallStack => Bool -> TestParams -> IO () +testAsyncAcceptingOffline withShortLink ps = do + inv <- withNewTestChat ps "alice" aliceProfile $ \alice -> do alice ##> "/c" (if withShortLink then getInvitation else getInvitationNoShortLink) alice - withNewTestChatCfg ps bobCfg "bob" bobProfile $ \bob -> do + withNewTestChat ps "bob" bobProfile $ \bob -> do threadDelay 250000 bob ##> ("/c " <> inv) bob <## "confirmation sent!" - withTestChatCfg ps aliceCfg "alice" $ \alice -> do - withTestChatCfg ps bobCfg "bob" $ \bob -> do + withTestChat ps "alice" $ \alice -> do + withTestChat ps "bob" $ \bob -> do alice <## "subscribed 1 connections on server localhost" bob <## "subscribed 1 connections on server localhost" concurrently_ @@ -1292,30 +1279,6 @@ testFullAsyncFast ps = do bob <## "subscribed 1 connections on server localhost" bob <## "alice (Alice): contact is connected" -testFullAsyncSlow :: HasCallStack => Bool -> ChatConfig -> ChatConfig -> TestParams -> IO () -testFullAsyncSlow withShortLink aliceCfg bobCfg ps = do - inv <- withNewTestChatCfg ps aliceCfg "alice" aliceProfile $ \alice -> do - threadDelay 250000 - alice ##> "/c" - (if withShortLink then getInvitation else getInvitationNoShortLink) alice - withNewTestChatCfg ps bobCfg "bob" bobProfile $ \bob -> do - threadDelay 250000 - bob ##> ("/c " <> inv) - bob <## "confirmation sent!" - withAlice $ \alice -> - alice <## "subscribed 1 connections on server localhost" - withBob $ \bob -> - bob <## "subscribed 1 connections on server localhost" - withAlice $ \alice -> do - alice <## "subscribed 1 connections on server localhost" - alice <## "bob (Bob): contact is connected" - withBob $ \bob -> do - bob <## "subscribed 1 connections on server localhost" - bob <## "alice (Alice): contact is connected" - where - withAlice = withTestChatCfg ps aliceCfg "alice" - withBob = withTestChatCfg ps aliceCfg "bob" - testCallType :: CallType testCallType = CallType {media = CMVideo, capabilities = CallCapabilities {encryption = True}} @@ -1341,7 +1304,7 @@ repeatM_ n a = forM_ [1 .. n] $ const a testNegotiateCall :: HasCallStack => TestParams -> IO () testNegotiateCall = - testChat2 aliceProfile bobProfile $ \alice bob -> do + withTestOutput $ testChat2 aliceProfile bobProfile $ \alice bob -> do connectUsers alice bob -- just for testing db query alice ##> "/_call get" @@ -2200,7 +2163,7 @@ testUsersDifferentCIExpirationTTL ps = do showActiveUser alice "alisa" alice #$> ("/_get chat @6 count=100", chat, chatFeatures <> [(1, "alisa 1"), (0, "alisa 2"), (1, "alisa 3"), (0, "alisa 4")]) - threadDelay 2000000 + threadDelay 2100000 alice #$> ("/_get chat @6 count=100", chat, [(1,"chat banner")]) where @@ -2419,7 +2382,7 @@ testDisableCIExpirationOnlyForOneUser ps = do cfg = testCfg {initialCleanupManagerDelay = 0, cleanupManagerStepDelay = 0, ciExpirationInterval = 500000} testUsersTimedMessages :: HasCallStack => TestParams -> IO () -testUsersTimedMessages ps = do +testUsersTimedMessages ps' = do withNewTestChat ps "bob" bobProfile $ \bob -> do withNewTestChat ps "alice" aliceProfile $ \alice -> do connectUsers alice bob @@ -2462,10 +2425,8 @@ testUsersTimedMessages ps = do threadDelay 1000000 - alice <## "[user: alice] timed message deleted: alice 1" - alice <## "[user: alice] timed message deleted: alice 2" - bob <## "timed message deleted: alice 1" - bob <## "timed message deleted: alice 2" + alice <### ["[user: alice] timed message deleted: alice 1", "[user: alice] timed message deleted: alice 2"] + bob <### ["timed message deleted: alice 1", "timed message deleted: alice 2"] alice ##> "/user alice" showActiveUser alice "alice (Alice)" @@ -2477,10 +2438,8 @@ testUsersTimedMessages ps = do threadDelay 1000000 - alice <## "timed message deleted: alisa 1" - alice <## "timed message deleted: alisa 2" - bob <## "timed message deleted: alisa 1" - bob <## "timed message deleted: alisa 2" + alice <### ["timed message deleted: alisa 1", "timed message deleted: alisa 2"] + bob <### ["timed message deleted: alisa 1", "timed message deleted: alisa 2"] alice ##> "/user" showActiveUser alice "alisa" @@ -2519,10 +2478,8 @@ testUsersTimedMessages ps = do -- messages are deleted after restart threadDelay 1000000 - alice <## "[user: alice] timed message deleted: alice 3" - alice <## "[user: alice] timed message deleted: alice 4" - bob <## "timed message deleted: alice 3" - bob <## "timed message deleted: alice 4" + alice <### ["[user: alice] timed message deleted: alice 3", "[user: alice] timed message deleted: alice 4"] + bob <### ["timed message deleted: alice 3", "timed message deleted: alice 4"] alice ##> "/user alice" showActiveUser alice "alice (Alice)" @@ -2534,15 +2491,14 @@ testUsersTimedMessages ps = do threadDelay 1000000 - alice <## "timed message deleted: alisa 3" - alice <## "timed message deleted: alisa 4" - bob <## "timed message deleted: alisa 3" - bob <## "timed message deleted: alisa 4" + alice <### ["timed message deleted: alisa 3", "timed message deleted: alisa 4"] + bob <### ["timed message deleted: alisa 3", "timed message deleted: alisa 4"] alice ##> "/user" showActiveUser alice "alisa" alice #$> ("/_get chat @6 count=100", chat, [(1,"chat banner")]) where + ps = ps' {printOutput = True} :: TestParams configureTimedMessages :: HasCallStack => TestCC -> TestCC -> String -> String -> IO () configureTimedMessages alice bob bobId ttl = do aliceName <- userName alice @@ -2699,7 +2655,7 @@ testUserPrivacy = testSetChatItemTTL :: HasCallStack => TestParams -> IO () testSetChatItemTTL = testChat2 aliceProfile bobProfile $ - \alice bob -> do + \alice bob -> withXFTPServer $ do connectUsers alice bob alice #> "@bob 1" bob <# "alice> 1" @@ -2713,6 +2669,7 @@ testSetChatItemTTL = alice <## "use /fc 1 to cancel sending" bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)" bob <## "use /fr 1 [