diff --git a/apps/ios/SimpleX.xcodeproj/project.pbxproj b/apps/ios/SimpleX.xcodeproj/project.pbxproj index 8e1f95a27e..8553109f13 100644 --- a/apps/ios/SimpleX.xcodeproj/project.pbxproj +++ b/apps/ios/SimpleX.xcodeproj/project.pbxproj @@ -76,11 +76,11 @@ 5C9CC7AD28C55D7800BEF955 /* DatabaseEncryptionView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5C9CC7AC28C55D7800BEF955 /* DatabaseEncryptionView.swift */; }; 5C9D13A3282187BB00AB8B43 /* WebRTC.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5C9D13A2282187BB00AB8B43 /* WebRTC.swift */; }; 5C9D811A2AA8727A001D49FD /* CryptoFile.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5C9D81182AA7A4F1001D49FD /* CryptoFile.swift */; }; - 5C9F3DCC2BF7A6900003B86B /* libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C9F3DC72BF7A6900003B86B /* libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g.a */; }; - 5C9F3DCD2BF7A6900003B86B /* libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g-ghc9.6.3.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C9F3DC82BF7A6900003B86B /* libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g-ghc9.6.3.a */; }; - 5C9F3DCE2BF7A6900003B86B /* libgmp.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C9F3DC92BF7A6900003B86B /* libgmp.a */; }; - 5C9F3DCF2BF7A6900003B86B /* libgmpxx.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C9F3DCA2BF7A6900003B86B /* libgmpxx.a */; }; - 5C9F3DD02BF7A6900003B86B /* libffi.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C9F3DCB2BF7A6900003B86B /* libffi.a */; }; + 5C9F3DD62BFBCDD90003B86B /* libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf-ghc9.6.3.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C9F3DD12BFBCDD80003B86B /* libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf-ghc9.6.3.a */; }; + 5C9F3DD72BFBCDD90003B86B /* libffi.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C9F3DD22BFBCDD80003B86B /* libffi.a */; }; + 5C9F3DD82BFBCDD90003B86B /* libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C9F3DD32BFBCDD80003B86B /* libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf.a */; }; + 5C9F3DD92BFBCDD90003B86B /* libgmpxx.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C9F3DD42BFBCDD90003B86B /* libgmpxx.a */; }; + 5C9F3DDA2BFBCDD90003B86B /* libgmp.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C9F3DD52BFBCDD90003B86B /* libgmp.a */; }; 5C9FD96E27A5D6ED0075386C /* SendMessageView.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5C9FD96D27A5D6ED0075386C /* SendMessageView.swift */; }; 5CA059DC279559F40002BEB4 /* Tests_iOS.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059DB279559F40002BEB4 /* Tests_iOS.swift */; }; 5CA059DE279559F40002BEB4 /* Tests_iOSLaunchTests.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059DD279559F40002BEB4 /* Tests_iOSLaunchTests.swift */; }; @@ -359,11 +359,11 @@ 5C9CC7AC28C55D7800BEF955 /* DatabaseEncryptionView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = DatabaseEncryptionView.swift; sourceTree = ""; }; 5C9D13A2282187BB00AB8B43 /* WebRTC.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = WebRTC.swift; sourceTree = ""; }; 5C9D81182AA7A4F1001D49FD /* CryptoFile.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = CryptoFile.swift; sourceTree = ""; }; - 5C9F3DC72BF7A6900003B86B /* libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g.a"; sourceTree = ""; }; - 5C9F3DC82BF7A6900003B86B /* libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g-ghc9.6.3.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g-ghc9.6.3.a"; sourceTree = ""; }; - 5C9F3DC92BF7A6900003B86B /* libgmp.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmp.a; sourceTree = ""; }; - 5C9F3DCA2BF7A6900003B86B /* libgmpxx.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmpxx.a; sourceTree = ""; }; - 5C9F3DCB2BF7A6900003B86B /* libffi.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libffi.a; sourceTree = ""; }; + 5C9F3DD12BFBCDD80003B86B /* libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf-ghc9.6.3.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf-ghc9.6.3.a"; sourceTree = ""; }; + 5C9F3DD22BFBCDD80003B86B /* libffi.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libffi.a; sourceTree = ""; }; + 5C9F3DD32BFBCDD80003B86B /* libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = "libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf.a"; sourceTree = ""; }; + 5C9F3DD42BFBCDD90003B86B /* libgmpxx.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmpxx.a; sourceTree = ""; }; + 5C9F3DD52BFBCDD90003B86B /* libgmp.a */ = {isa = PBXFileReference; lastKnownFileType = archive.ar; path = libgmp.a; sourceTree = ""; }; 5C9FD96A27A56D4D0075386C /* JSON.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = JSON.swift; sourceTree = ""; }; 5C9FD96D27A5D6ED0075386C /* SendMessageView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = SendMessageView.swift; sourceTree = ""; }; 5CA059C3279559F40002BEB4 /* SimpleXApp.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = SimpleXApp.swift; sourceTree = ""; }; @@ -539,13 +539,13 @@ isa = PBXFrameworksBuildPhase; buildActionMask = 2147483647; files = ( - 5C9F3DCF2BF7A6900003B86B /* libgmpxx.a in Frameworks */, + 5C9F3DD92BFBCDD90003B86B /* libgmpxx.a in Frameworks */, + 5C9F3DDA2BFBCDD90003B86B /* libgmp.a in Frameworks */, + 5C9F3DD82BFBCDD90003B86B /* libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf.a in Frameworks */, 5CE2BA93284534B000EC33A6 /* libiconv.tbd in Frameworks */, - 5C9F3DCE2BF7A6900003B86B /* libgmp.a in Frameworks */, - 5C9F3DCC2BF7A6900003B86B /* libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g.a in Frameworks */, - 5C9F3DD02BF7A6900003B86B /* libffi.a in Frameworks */, + 5C9F3DD62BFBCDD90003B86B /* libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf-ghc9.6.3.a in Frameworks */, 5CE2BA94284534BB00EC33A6 /* libz.tbd in Frameworks */, - 5C9F3DCD2BF7A6900003B86B /* libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g-ghc9.6.3.a in Frameworks */, + 5C9F3DD72BFBCDD90003B86B /* libffi.a in Frameworks */, ); runOnlyForDeploymentPostprocessing = 0; }; @@ -611,11 +611,11 @@ 5C764E5C279C70B7000C6508 /* Libraries */ = { isa = PBXGroup; children = ( - 5C9F3DCB2BF7A6900003B86B /* libffi.a */, - 5C9F3DC92BF7A6900003B86B /* libgmp.a */, - 5C9F3DCA2BF7A6900003B86B /* libgmpxx.a */, - 5C9F3DC82BF7A6900003B86B /* libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g-ghc9.6.3.a */, - 5C9F3DC72BF7A6900003B86B /* libHSsimplex-chat-5.8.0.1-BrjXjAnJqNV7yWXU89n05g.a */, + 5C9F3DD22BFBCDD80003B86B /* libffi.a */, + 5C9F3DD52BFBCDD90003B86B /* libgmp.a */, + 5C9F3DD42BFBCDD90003B86B /* libgmpxx.a */, + 5C9F3DD12BFBCDD80003B86B /* libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf-ghc9.6.3.a */, + 5C9F3DD32BFBCDD80003B86B /* libHSsimplex-chat-5.8.0.2-8RkLdmy05dJBsgWrGV50Uf.a */, ); path = Libraries; sourceTree = ""; @@ -1562,7 +1562,7 @@ CLANG_TIDY_MISC_REDUNDANT_EXPRESSION = YES; CODE_SIGN_ENTITLEMENTS = "SimpleX (iOS).entitlements"; CODE_SIGN_STYLE = Automatic; - CURRENT_PROJECT_VERSION = 217; + CURRENT_PROJECT_VERSION = 218; DEAD_CODE_STRIPPING = YES; DEVELOPMENT_TEAM = 5NN7GUYB6T; ENABLE_BITCODE = NO; @@ -1611,7 +1611,7 @@ CLANG_TIDY_MISC_REDUNDANT_EXPRESSION = YES; CODE_SIGN_ENTITLEMENTS = "SimpleX (iOS).entitlements"; CODE_SIGN_STYLE = Automatic; - CURRENT_PROJECT_VERSION = 217; + CURRENT_PROJECT_VERSION = 218; DEAD_CODE_STRIPPING = YES; DEVELOPMENT_TEAM = 5NN7GUYB6T; ENABLE_BITCODE = NO; @@ -1697,7 +1697,7 @@ CODE_SIGN_ENTITLEMENTS = "SimpleX NSE/SimpleX NSE.entitlements"; CODE_SIGN_IDENTITY = "Apple Development"; CODE_SIGN_STYLE = Automatic; - CURRENT_PROJECT_VERSION = 217; + CURRENT_PROJECT_VERSION = 218; DEVELOPMENT_TEAM = 5NN7GUYB6T; ENABLE_BITCODE = NO; GCC_OPTIMIZATION_LEVEL = s; @@ -1734,7 +1734,7 @@ CODE_SIGN_ENTITLEMENTS = "SimpleX NSE/SimpleX NSE.entitlements"; CODE_SIGN_IDENTITY = "Apple Development"; CODE_SIGN_STYLE = Automatic; - CURRENT_PROJECT_VERSION = 217; + CURRENT_PROJECT_VERSION = 218; DEVELOPMENT_TEAM = 5NN7GUYB6T; ENABLE_BITCODE = NO; ENABLE_CODE_COVERAGE = NO; @@ -1771,7 +1771,7 @@ CLANG_TIDY_BUGPRONE_REDUNDANT_BRANCH_CONDITION = YES; CLANG_TIDY_MISC_REDUNDANT_EXPRESSION = YES; CODE_SIGN_STYLE = Automatic; - CURRENT_PROJECT_VERSION = 217; + CURRENT_PROJECT_VERSION = 218; DEFINES_MODULE = YES; DEVELOPMENT_TEAM = 5NN7GUYB6T; DYLIB_COMPATIBILITY_VERSION = 1; @@ -1822,7 +1822,7 @@ CLANG_TIDY_BUGPRONE_REDUNDANT_BRANCH_CONDITION = YES; CLANG_TIDY_MISC_REDUNDANT_EXPRESSION = YES; CODE_SIGN_STYLE = Automatic; - CURRENT_PROJECT_VERSION = 217; + CURRENT_PROJECT_VERSION = 218; DEFINES_MODULE = YES; DEVELOPMENT_TEAM = 5NN7GUYB6T; DYLIB_COMPATIBILITY_VERSION = 1; diff --git a/apps/multiplatform/gradle.properties b/apps/multiplatform/gradle.properties index 05d63578e7..01e3b17296 100644 --- a/apps/multiplatform/gradle.properties +++ b/apps/multiplatform/gradle.properties @@ -26,11 +26,11 @@ android.enableJetifier=true kotlin.mpp.androidSourceSetLayoutVersion=2 kotlin.jvm.target=11 -android.version_name=5.8-beta.1 -android.version_code=209 +android.version_name=5.8-beta.2 +android.version_code=210 -desktop.version_name=5.8-beta.1 -desktop.version_code=46 +desktop.version_name=5.8-beta.2 +desktop.version_code=47 kotlin.version=1.9.23 gradle.plugin.version=8.2.0 diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index 87950ecce7..31a7e94aad 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -35,8 +35,10 @@ import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Types import Simplex.Chat.Types.Shared +import Simplex.Messaging.Agent.Protocol (AgentErrorType (..)) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Util ((<$?>)) +import Simplex.Messaging.Protocol (BrokerErrorType (..)) +import Simplex.Messaging.Util (tshow, (<$?>)) data DirectoryEvent = DEContactConnected Contact @@ -53,6 +55,7 @@ data DirectoryEvent | DEItemEditIgnored Contact | DEItemDeleteIgnored Contact | DEContactCommand Contact ChatItemId ADirectoryCmd + | DELogChatResponse Text deriving (Show) crDirectoryEvent :: ChatResponse -> Maybe DirectoryEvent @@ -77,6 +80,13 @@ crDirectoryEvent = \case where ciId = chatItemId' ci err = ADC SDRUser DCUnknownCommand + CRMessageError {severity, errorMessage} -> Just $ DELogChatResponse $ "message error: " <> severity <> ", " <> errorMessage + CRChatCmdError {chatError} -> Just $ DELogChatResponse $ "chat cmd error: " <> tshow chatError + CRChatError {chatError} -> case chatError of + ChatErrorAgent {agentError = BROKER _ NETWORK} -> Nothing + ChatErrorAgent {agentError = BROKER _ TIMEOUT} -> Nothing + _ -> Just $ DELogChatResponse $ "chat error: " <> tshow chatError + CRChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors) _ -> Nothing data DirectoryRole = DRUser | DRSuperUser diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index eefb1f77a4..a61e405cb8 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -102,6 +102,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi case sUser of SDRUser -> deUserCommand env ct ciId cmd SDRSuperUser -> deSuperUserCommand ct ciId cmd + DELogChatResponse r -> logInfo r where withSuperUsers action = void . forkIO $ forM_ superUsers $ \KnownContact {contactId} -> action contactId notifySuperUsers s = withSuperUsers $ \contactId -> sendMessage' cc contactId s diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index 5082cab2ce..c810102e08 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -39,8 +39,8 @@ import Data.Text (Text) import Simplex.Chat.Types import Simplex.Messaging.Encoding.String import Simplex.Messaging.Util (ifM) -import System.IO (Handle, IOMode (..), openFile, BufferMode (..), hSetBuffering) -import System.Directory (renameFile, doesFileExist) +import System.Directory (doesFileExist, renameFile) +import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile) data DirectoryStore = DirectoryStore { groupRegs :: TVar [GroupReg], @@ -112,7 +112,7 @@ addGroupReg st ct GroupInfo {groupId} grStatus = do let ugrId = 1 + foldl' maxUgrId 0 grs grData' = grData {userGroupRegId_ = ugrId} gr' = gr {userGroupRegId = ugrId} - in (grData', gr' : grs) + in (grData', gr' : grs) ctId = contactId' ct maxUgrId mx GroupReg {dbContactId, userGroupRegId} | dbContactId == ctId && userGroupRegId > mx = userGroupRegId @@ -311,14 +311,15 @@ readDirectoryData f = Right r -> case r of GRCreate gr@GroupRegData {dbGroupId_ = gId} -> do when (isJust $ M.lookup gId m) $ - putStrLn $ "Warning: duplicate group with ID " <> show gId <> ", group replaced." + putStrLn $ + "Warning: duplicate group with ID " <> show gId <> ", group replaced." pure $ M.insert gId gr m GRUpdateStatus gId groupRegStatus_ -> case M.lookup gId m of Just gr -> pure $ M.insert gId gr {groupRegStatus_} m - Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <>", status update ignored.") + Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", status update ignored.") GRUpdateOwner gId grOwnerId -> case M.lookup gId m of Just gr -> pure $ M.insert gId gr {dbOwnerMemberId_ = Just grOwnerId} m - Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <>", owner update ignored.") + Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", owner update ignored.") writeDirectoryData :: FilePath -> [GroupRegData] -> IO Handle writeDirectoryData f grs = do diff --git a/cabal.project b/cabal.project index 3595f999e3..a68df42bf7 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: e3f5d244c1a435593e33adc023bf1f920f379f8d + tag: bd67844169d2206d8543c01e6ed966315115b0e3 source-repository-package type: git diff --git a/package.yaml b/package.yaml index df815e75a8..39410d16e0 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: simplex-chat -version: 5.8.0.2 +version: 5.8.0.3 #synopsis: #description: homepage: https://github.com/simplex-chat/simplex-chat#readme @@ -152,12 +152,31 @@ tests: ghc-options: # - -haddock - -O2 - - -Wall + - -Weverything + - -Wno-missing-exported-signatures + - -Wno-missing-import-lists + - -Wno-missed-specialisations + - -Wno-all-missed-specialisations + - -Wno-unsafe + - -Wno-safe + - -Wno-missing-local-signatures + - -Wno-missing-kind-signatures + - -Wno-missing-deriving-strategies + - -Wno-monomorphism-restriction + - -Wno-prepositive-qualified-module + - -Wno-unused-packages + - -Wno-implicit-prelude + - -Wno-missing-safe-haskell-mode + - -Wno-missing-export-lists + - -Wno-partial-fields - -Wcompat + - -Werror=incomplete-record-updates - -Werror=incomplete-patterns + - -Werror=missing-methods + - -Werror=incomplete-uni-patterns + - -Werror=tabs - -Wredundant-constraints - -Wincomplete-record-updates - - -Wincomplete-uni-patterns - -Wunused-type-patterns default-extensions: diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index a1f698fb4e..468ca71307 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."e3f5d244c1a435593e33adc023bf1f920f379f8d" = "1klin78kgvgzdvf64nahn3280m7hw5f8wzrca43cmyajm2qp3wfs"; + "https://github.com/simplex-chat/simplexmq.git"."bd67844169d2206d8543c01e6ed966315115b0e3" = "1g218q15hrg21h8gyidavfys5zx8dzmxq7iwfm5bfaw71grpd7pn"; "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/simplex-chat.cabal b/simplex-chat.cabal index 96689b9f30..11c0cc0731 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: simplex-chat -version: 5.8.0.2 +version: 5.8.0.3 category: Web, System, Services, Cryptography homepage: https://github.com/simplex-chat/simplex-chat#readme author: simplex.chat @@ -190,7 +190,7 @@ library src default-extensions: StrictData - ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns + ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 @@ -252,7 +252,7 @@ executable simplex-bot apps/simplex-bot default-extensions: StrictData - ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 @@ -315,7 +315,7 @@ executable simplex-bot-advanced apps/simplex-bot-advanced default-extensions: StrictData - ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 @@ -381,7 +381,7 @@ executable simplex-broadcast-bot Broadcast.Bot Broadcast.Options Paths_simplex_chat - ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 @@ -445,7 +445,7 @@ executable simplex-chat apps/simplex-chat default-extensions: StrictData - ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 @@ -515,7 +515,7 @@ executable simplex-directory-service Directory.Service Directory.Store Paths_simplex_chat - ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 @@ -610,7 +610,7 @@ test-suite simplex-chat-test apps/simplex-directory-service/src default-extensions: StrictData - ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded build-depends: QuickCheck ==2.14.* , aeson ==2.2.* diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 743cef932c..e259629d2b 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -228,6 +229,7 @@ newChatController smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore backgroundMode agentAsync <- newTVarIO Nothing random <- liftIO C.newRandom + eventSeq <- newTVarIO 0 inputQ <- newTBQueueIO tbqSize outputQ <- newTBQueueIO tbqSize connNetworkStatuses <- atomically TM.empty @@ -265,6 +267,7 @@ newChatController chatStore, chatStoreChanged, random, + eventSeq, inputQ, outputQ, connNetworkStatuses, @@ -1701,7 +1704,7 @@ processChatCommand' vr = \case sndMsgs <- lift $ createSndMessages idsEvts let msgReqs_ :: NonEmpty (Either ChatError MsgReq) = L.zipWith (fmap . ctMsgReq) ctConns sndMsgs (errs, ctSndMsgs :: [(Contact, SndMessage)]) <- - lift $ partitionEithers . L.toList . zipWith3' combineResults ctConns sndMsgs <$> deliverMessagesB msgReqs_ + partitionEithers . L.toList . zipWith3' combineResults ctConns sndMsgs <$> deliverMessagesB msgReqs_ timestamp <- liftIO getCurrentTime lift . void $ withStoreBatch' $ \db -> map (createCI db user timestamp) ctSndMsgs pure CRBroadcastSent {user, msgContent = mc, successes = length ctSndMsgs, failures = length errs, timestamp} @@ -2397,7 +2400,7 @@ processChatCommand' vr = \case Just changedCts -> do let idsEvts = L.map ctSndEvent changedCts msgReqs_ <- lift $ L.zipWith ctMsgReq changedCts <$> createSndMessages idsEvts - (errs, cts) <- lift $ partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_ + (errs, cts) <- partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_ unless (null errs) $ toView $ CRChatErrors (Just user) errs let changedCts' = filter (\ChangedProfileContact {ct, ct'} -> directOrUsed ct' && mergedPreferences ct' /= mergedPreferences ct) cts lift $ createContactsSndFeatureItems user' changedCts' @@ -3316,7 +3319,10 @@ deleteGroupLink_ user gInfo conn = do agentSubscriber :: CM' () agentSubscriber = do q <- asks $ subQ . smpAgent - forever $ atomically (readTBQueue q) >>= process + forever (atomically (readTBQueue q) >>= process) + `E.catchAny` \e -> do + toView' $ CRChatError Nothing $ ChatErrorAgent (CRITICAL True $ "Message reception stopped: " <> show e) Nothing + E.throwIO e where process :: (ACorrId, EntityId, APartyCmd 'Agent) -> CM' () process (corrId, entId, APC e msg) = run $ case e of @@ -3936,7 +3942,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- TODO only acknowledge without saving message? -- probably this branch is never executed, so there should be no reason -- to save message if contact hasn't been created yet - chat item isn't created anyway - withAckMessage' agentConnId meta $ + withAckMessage' "new contact msg" agentConnId meta $ void $ saveDirectRcvMSG conn meta msgBody SENT msgId _proxy -> @@ -3967,14 +3973,18 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = forM_ contData $ \(hostConnId, xGrpMemIntroCont) -> sendXGrpMemInv hostConnId (Just directConnReq) xGrpMemIntroCont CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" - MSG msgMeta _msgFlags msgBody -> - withAckMessage agentConnId msgMeta True $ do + MSG msgMeta _msgFlags msgBody -> do + tags <- newTVarIO [] + withAckMessage "contact msg" agentConnId msgMeta True (Just tags) $ \eInfo -> do let MsgMeta {pqEncryption} = msgMeta (ct', conn') <- updateContactPQRcv user ct conn pqEncryption checkIntegrityCreateItem (CDDirectRcv ct') msgMeta `catchChatError` \_ -> pure () (conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta msgBody + let tag = toCMEventTag event + atomically $ writeTVar tags [tshow tag] + logInfo $ "contact msg=" <> tshow tag <> " " <> eInfo let ct'' = ct' {activeConn = Just conn''} :: Contact - assertDirectAllowed user MDRcv ct'' $ toCMEventTag event + assertDirectAllowed user MDRcv ct'' tag case event of XMsgNew mc -> newContentMessage ct'' mc msg msgMeta XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr @@ -3999,9 +4009,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = BFileChunk sharedMsgId chunk -> bFileChunk ct'' sharedMsgId chunk msgMeta _ -> messageError $ "unsupported message: " <> T.pack (show event) let Contact {chatSettings = ChatSettings {sendRcpts}} = ct'' - pure $ fromMaybe (sendRcptsContacts user) sendRcpts && hasDeliveryReceipt (toCMEventTag event) + pure $ fromMaybe (sendRcptsContacts user) sendRcpts && hasDeliveryReceipt tag RCVD msgMeta msgRcpt -> - withAckMessage' agentConnId msgMeta $ + withAckMessage' "contact rcvd" agentConnId msgMeta $ directMsgReceived ct conn msgMeta msgRcpt CONF confId pqSupport _ connInfo -> do conn' <- processCONFpqSupport conn pqSupport @@ -4380,19 +4390,26 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = void $ sendDirectMemberMessage imConn (XGrpMemCon memberId) groupId _ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected" MSG msgMeta _msgFlags msgBody -> do - withAckMessage agentConnId msgMeta True $ do + tags <- newTVarIO [] + withAckMessage "group msg" agentConnId msgMeta True (Just tags) $ \eInfo -> do checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure () forM_ aChatMsgs $ \case Right (ACMsg _ chatMsg) -> - processEvent chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e - Left e -> toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e) - forwardMsg_ `catchChatError` \_ -> pure () + processEvent tags eInfo chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e + Left e -> do + atomically $ modifyTVar' tags ("error" :) + logInfo $ "group msg=error " <> eInfo <> " " <> tshow e + toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e) + forwardMsg_ `catchChatError` (toView . CRChatError (Just user)) checkSendRcpt $ rights aChatMsgs where aChatMsgs = parseChatMessages msgBody brokerTs = metaBrokerTs msgMeta - processEvent :: MsgEncodingI e => ChatMessage e -> CM () - processEvent chatMsg = do + processEvent :: TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM () + processEvent tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do + let tag = toCMEventTag chatMsgEvent + atomically $ modifyTVar' tags (tshow tag :) + logInfo $ "group msg=" <> tshow tag <> " " <> eInfo (m', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m conn msgMeta msgBody chatMsg case event of XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs False @@ -4423,7 +4440,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XInfoProbeCheck probeHash -> xInfoProbeCheck (COMGroupMember m') probeHash XInfoProbeOk probe -> xInfoProbeOk (COMGroupMember m') probe BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta - _ -> messageError $ "unsupported message: " <> T.pack (show event) + _ -> messageError $ "unsupported message: " <> tshow event checkSendRcpt :: [AChatMessage] -> CM Bool checkSendRcpt aMsgs = do currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo @@ -4457,7 +4474,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = sendGroupMessage' user gInfo ms msg _ -> pure () RCVD msgMeta msgRcpt -> - withAckMessage' agentConnId msgMeta $ + withAckMessage' "group rcvd" agentConnId msgMeta $ groupMsgReceived gInfo m conn msgMeta msgRcpt SENT msgId proxy -> do sentMsgDeliveryEvent conn msgId @@ -4581,7 +4598,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = lookupChatItemByFileId db vr user fileId toView $ CRSndFileRcvCancelled user ci ft _ -> throwChatError $ CEFileSend fileId err - MSG meta _ _ -> withAckMessage' agentConnId meta $ pure () + MSG meta _ _ -> + withAckMessage' "file msg" agentConnId meta $ pure () OK -> -- [async agent commands] continuation on receiving OK when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () @@ -4657,7 +4675,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = RcvChunkOk -> if B.length chunk /= fromInteger chunkSize then badRcvFileChunk ft "incorrect chunk size" - else withAckMessage' agentConnId meta $ appendFileChunk ft chunkNo chunk False + else withAckMessage' "file msg" agentConnId meta $ appendFileChunk ft chunkNo chunk False RcvChunkFinal -> if B.length chunk > fromInteger chunkSize then badRcvFileChunk ft "incorrect chunk size" @@ -4671,7 +4689,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = getChatItemByFileId db vr user fileId toView $ CRRcvFileComplete user ci forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn) - RcvChunkDuplicate -> withAckMessage' agentConnId meta $ pure () + RcvChunkDuplicate -> withAckMessage' "file msg" agentConnId meta $ pure () RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo processUserContactRequest :: ACommand 'Agent e -> ConnectionEntity -> Connection -> UserContact -> CM () @@ -4755,25 +4773,45 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = withStore' $ \db -> updateCommandStatus db user cmdId CSError throwChatError . CEAgentCommandError $ msg - withAckMessage' :: ConnId -> MsgMeta -> CM () -> CM () - withAckMessage' cId msgMeta action = do - withAckMessage cId msgMeta False $ action $> False + withAckMessage' :: Text -> ConnId -> MsgMeta -> CM () -> CM () + withAckMessage' label cId msgMeta action = do + withAckMessage label cId msgMeta False Nothing $ \_ -> action $> False - withAckMessage :: ConnId -> MsgMeta -> Bool -> CM Bool -> CM () - withAckMessage cId msgMeta showCritical action = + withAckMessage :: Text -> ConnId -> MsgMeta -> Bool -> Maybe (TVar [Text]) -> (Text -> CM Bool) -> CM () + withAckMessage label cId msgMeta showCritical tags action = do -- [async agent commands] command should be asynchronous -- TODO catching error and sending ACK after an error, particularly if it is a database error, will result in the message not processed (and no notification to the user). -- Possible solutions are: -- 1) retry processing several times -- 2) stabilize database -- 3) show screen of death to the user asking to restart - tryChatError action >>= \case - Right withRcpt -> ackMsg msgMeta $ if withRcpt then Just "" else Nothing + eInfo <- eventInfo + logInfo $ label <> ": " <> eInfo + tryChatError (action eInfo) >>= \case + Right withRcpt -> + withLog (eInfo <> " ok") $ ackMsg msgMeta $ if withRcpt then Just "" else Nothing -- If showCritical is True, then these errors don't result in ACK and show user visible alert -- This prevents losing the message that failed to be processed. Left (ChatErrorStore SEDBBusyError {message}) | showCritical -> throwError $ ChatErrorAgent (CRITICAL True message) Nothing - Left e -> ackMsg msgMeta Nothing >> throwError e + Left e -> do + withLog (eInfo <> " error: " <> tshow e) $ ackMsg msgMeta Nothing + throwError e where + eventInfo = do + v <- asks eventSeq + eId <- atomically $ stateTVar v $ \i -> (i + 1, i + 1) + pure $ "conn_id=" <> tshow cId <> " event_id=" <> tshow eId + withLog eInfo' ack = do + ts <- showTags + logInfo $ T.unwords [label, "ack:", ts, eInfo'] + ack + logInfo $ T.unwords [label, "ack=success:", ts, eInfo'] + showTags = do + ts <- maybe (pure []) readTVarIO tags + pure $ case ts of + [] -> "no_chat_messages" + [t] -> "chat_message=" <> t + _ -> "chat_message_batch=" <> T.intercalate "," (reverse ts) ackMsg :: MsgMeta -> Maybe MsgReceiptInfo -> CM () ackMsg MsgMeta {recipient = (msgId, _)} rcpt = withAgent $ \a -> ackMessageAsync a "" cId msgId rcpt @@ -6561,21 +6599,21 @@ deliverMessage conn cmEventTag msgBody msgId = do deliverMessage' :: Connection -> MsgFlags -> MsgBody -> MessageId -> CM (Int64, PQEncryption) deliverMessage' conn msgFlags msgBody msgId = - lift (deliverMessages ((conn, msgFlags, msgBody, msgId) :| [])) >>= \case + deliverMessages ((conn, msgFlags, msgBody, msgId) :| []) >>= \case r :| [] -> liftEither r rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs) type MsgReq = (Connection, MsgFlags, MsgBody, MessageId) -deliverMessages :: NonEmpty MsgReq -> CM' (NonEmpty (Either ChatError (Int64, PQEncryption))) +deliverMessages :: NonEmpty MsgReq -> CM (NonEmpty (Either ChatError (Int64, PQEncryption))) deliverMessages msgs = deliverMessagesB $ L.map Right msgs -deliverMessagesB :: NonEmpty (Either ChatError MsgReq) -> CM' (NonEmpty (Either ChatError (Int64, PQEncryption))) +deliverMessagesB :: NonEmpty (Either ChatError MsgReq) -> CM (NonEmpty (Either ChatError (Int64, PQEncryption))) deliverMessagesB msgReqs = do msgReqs' <- liftIO compressBodies - sent <- L.zipWith prepareBatch msgReqs' <$> withAgent' (`sendMessagesB` L.map toAgent msgReqs') - void $ withStoreBatch' $ \db -> map (updatePQSndEnabled db) (rights . L.toList $ sent) - withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent + sent <- L.zipWith prepareBatch msgReqs' <$> withAgent (`sendMessagesB` L.map toAgent msgReqs') + lift . void $ withStoreBatch' $ \db -> map (updatePQSndEnabled db) (rights . L.toList $ sent) + lift . withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent where compressBodies = forME msgReqs $ \mr@(conn@Connection {pqSupport, connChatVersion = v}, msgFlags, msgBody, msgId) -> @@ -6607,6 +6645,8 @@ deliverMessagesB msgReqs = do where updatePQ = updateConnPQSndEnabled db connId pqSndEnabled' +-- TODO combine profile update and message into one batch +-- Take into account that it may not fit, and that we currently don't support sending multiple messages to the same connection in one call. sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, [GroupMember]) sendGroupMessage user gInfo members chatMsgEvent = do when shouldSendProfileUpdate $ @@ -6634,10 +6674,11 @@ sendGroupMessage' user GroupInfo {groupId} members chatMsgEvent = do msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent (GroupId groupId) recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) let msgFlags = MsgFlags {notification = hasNotification $ toCMEventTag chatMsgEvent} - (toSend, pending) = foldr addMember ([], []) recipientMembers + (toSend, pending, _, dups) = foldr addMember ([], [], S.empty, 0 :: Int) recipientMembers -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here msgReqs = map (\(_, conn) -> (conn, msgFlags, msgBody, msgId)) toSend - delivered <- maybe (pure []) (fmap L.toList . lift . deliverMessages) $ L.nonEmpty msgReqs + when (dups /= 0) $ logError $ "sendGroupMessage: " <> tshow dups <> " duplicate members" + delivered <- maybe (pure []) (fmap L.toList . deliverMessages) $ L.nonEmpty msgReqs let errors = lefts delivered unless (null errors) $ toView $ CRChatErrors (Just user) errors stored <- lift . withStoreBatch' $ \db -> map (\m -> createPendingGroupMessage db (groupMemberId' m) msgId Nothing) pending @@ -6650,10 +6691,16 @@ sendGroupMessage' user GroupInfo {groupId} members chatMsgEvent = do liftM2 (<>) (shuffle adminMs) (shuffle otherMs) where isAdmin GroupMember {memberRole} = memberRole >= GRAdmin - addMember m (toSend, pending) = case memberSendAction chatMsgEvent members m of - Just (MSASend conn) -> ((m, conn) : toSend, pending) - Just MSAPending -> (toSend, m : pending) - Nothing -> (toSend, pending) + addMember m acc@(toSend, pending, !mIds, !dups) = case memberSendAction chatMsgEvent members m of + Just a + | mId `S.member` mIds -> (toSend, pending, mIds, dups + 1) + | otherwise -> case a of + MSASend conn -> ((m, conn) : toSend, pending, mIds', dups) + MSAPending -> (toSend, m : pending, mIds', dups) + Nothing -> acc + where + mId = groupMemberId' m + mIds' = S.insert mId mIds filterSent :: [Either ChatError a] -> [mem] -> (mem -> GroupMember) -> [GroupMember] filterSent rs ms mem = [mem m | (Right _, m) <- zip rs ms] diff --git a/src/Simplex/Chat/Archive.hs b/src/Simplex/Chat/Archive.hs index 8550c03438..01897de791 100644 --- a/src/Simplex/Chat/Archive.hs +++ b/src/Simplex/Chat/Archive.hs @@ -26,6 +26,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Database.SQLite3 as SQL import Simplex.Chat.Controller +import Simplex.Chat.Util () import Simplex.Messaging.Agent.Client (agentClientStore) import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), closeSQLiteStore, keyString, sqlString, storeKey) import Simplex.Messaging.Util diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 9ff903514f..2c4c09c79c 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -13,6 +13,7 @@ {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-implicit-lift #-} module Simplex.Chat.Controller where @@ -205,6 +206,7 @@ data ChatController = ChatController chatStore :: SQLiteStore, chatStoreChanged :: TVar Bool, -- if True, chat should be fully restarted random :: TVar ChaChaDRG, + eventSeq :: TVar Int, inputQ :: TBQueue String, outputQ :: TBQueue (Maybe CorrId, Maybe RemoteHostId, ChatResponse), connNetworkStatuses :: TMap AgentConnId NetworkStatus, diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 449731b91c..9742439fb3 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -14,6 +14,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} +{-# OPTIONS_GHC -fno-warn-operator-whitespace #-} module Simplex.Chat.Messages where @@ -455,10 +456,10 @@ deriving instance Show ACIReaction data JSONCIReaction c d = JSONCIReaction {chatInfo :: ChatInfo c, chatReaction :: CIReaction c d} type family ChatTypeQuotable (a :: ChatType) :: Constraint where - ChatTypeQuotable CTDirect = () - ChatTypeQuotable CTGroup = () + ChatTypeQuotable 'CTDirect = () + ChatTypeQuotable 'CTGroup = () ChatTypeQuotable a = - (Int ~ Bool, TypeError (Type.Text "ChatType " :<>: ShowType a :<>: Type.Text " cannot be quoted")) + (Int ~ Bool, TypeError ('Type.Text "ChatType " ':<>: 'ShowType a ':<>: 'Type.Text " cannot be quoted")) data CIQDirection (c :: ChatType) where CIQDirectSnd :: CIQDirection 'CTDirect diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index e8d13402ef..5b98ea119c 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -72,11 +72,11 @@ import UnliftIO.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExis -- when acting as host minRemoteCtrlVersion :: AppVersion -minRemoteCtrlVersion = AppVersion [5, 7, 0, 3] +minRemoteCtrlVersion = AppVersion [5, 8, 0, 2] -- when acting as controller minRemoteHostVersion :: AppVersion -minRemoteHostVersion = AppVersion [5, 7, 0, 3] +minRemoteHostVersion = AppVersion [5, 8, 0, 2] currentAppVersion :: AppVersion currentAppVersion = AppVersion SC.version diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index b0a0495c16..0487b80c17 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -838,7 +838,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex ciMeta content status = let itemDeleted' = case itemDeleted of DBCINotDeleted -> Nothing - _ -> Just (CIDeleted @CTLocal deletedTs) + _ -> Just (CIDeleted @'CTLocal deletedTs) itemEdited' = fromMaybe False itemEdited itemForwarded = toCIForwardedFrom forwardedFromRow in mkCIMeta itemId content itemText status sentViaProxy sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt @@ -1458,7 +1458,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT ciMeta content status = let itemDeleted' = case itemDeleted of DBCINotDeleted -> Nothing - _ -> Just (CIDeleted @CTDirect deletedTs) + _ -> Just (CIDeleted @'CTDirect deletedTs) itemEdited' = fromMaybe False itemEdited itemForwarded = toCIForwardedFrom forwardedFromRow in mkCIMeta itemId content itemText status sentViaProxy sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt @@ -1520,7 +1520,7 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, DBCINotDeleted -> Nothing DBCIBlocked -> Just (CIBlocked deletedTs) DBCIBlockedByAdmin -> Just (CIBlockedByAdmin deletedTs) - _ -> Just (maybe (CIDeleted @CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) + _ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) itemEdited' = fromMaybe False itemEdited itemForwarded = toCIForwardedFrom forwardedFromRow in mkCIMeta itemId content itemText status sentViaProxy sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt @@ -1919,7 +1919,7 @@ markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} let itemId = chatItemId' ci (deletedByGroupMemberId, itemDeleted) = case byGroupMember_ of Just m@GroupMember {groupMemberId} -> (Just groupMemberId, Just $ CIModerated (Just deletedTs) m) - _ -> (Nothing, Just $ CIDeleted @CTGroup (Just deletedTs)) + _ -> (Nothing, Just $ CIDeleted @'CTGroup (Just deletedTs)) insertChatItemMessage_ db itemId msgId currentTs DB.execute db diff --git a/src/Simplex/Chat/Util.hs b/src/Simplex/Chat/Util.hs index 2b2bd599ae..3f7d19fd6d 100644 --- a/src/Simplex/Chat/Util.hs +++ b/src/Simplex/Chat/Util.hs @@ -1,10 +1,18 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Simplex.Chat.Util (week, encryptFile, chunkSize, liftIOEither, shuffle) where +import Control.Exception (Exception) import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Control.Monad.IO.Unlift (MonadUnliftIO (..)) +import Control.Monad.Reader +import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as LB import Data.List (sortBy) import Data.Ord (comparing) @@ -13,6 +21,7 @@ import Data.Word (Word16) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import qualified Simplex.Messaging.Crypto.File as CF import System.Random (randomRIO) +import qualified UnliftIO.Exception as E import UnliftIO.IO (IOMode (..), withFile) week :: NominalDiffTime @@ -46,3 +55,24 @@ shuffle xs = map snd . sortBy (comparing fst) <$> mapM (\x -> (,x) <$> random) x liftIOEither :: (MonadIO m, MonadError e m) => IO (Either e a) -> m a liftIOEither a = liftIO a >>= liftEither {-# INLINE liftIOEither #-} + +newtype InternalException e = InternalException {unInternalException :: e} + deriving (Eq, Show) + +instance Exception e => Exception (InternalException e) + +instance Exception e => MonadUnliftIO (ExceptT e IO) where + {-# INLINE withRunInIO #-} + withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b + withRunInIO inner = + ExceptT . fmap (first unInternalException) . E.try $ + withRunInIO $ \run -> + inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT) + +instance Exception e => MonadUnliftIO (ExceptT e (ReaderT r IO)) where + {-# INLINE withRunInIO #-} + withRunInIO :: ((forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b) -> ExceptT e (ReaderT r IO) b + withRunInIO inner = + withExceptT unInternalException . ExceptT . E.try $ + withRunInIO $ \run -> + inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 1c2b0b2cc1..08980f21d2 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -2028,14 +2028,16 @@ viewChatError logLevel testView = \case DBErrorOpen e -> ["error opening database after encryption: " <> sqliteError' e] e -> ["chat database error: " <> sShow e] ChatErrorAgent err entity_ -> case err of - CMD PROHIBITED -> [withConnEntity <> "error: command is prohibited"] + CMD PROHIBITED cxt -> [withConnEntity <> plain ("error: command is prohibited, " <> cxt)] SMP _ SMP.AUTH -> [ withConnEntity <> "error: connection authorization failed - this could happen if connection was deleted,\ \ secured with different credentials, or due to a bug - please re-create the connection" ] + BROKER _ NETWORK -> [] + BROKER _ TIMEOUT -> [] AGENT A_DUPLICATE -> [withConnEntity <> "error: AGENT A_DUPLICATE" | logLevel == CLLDebug] - AGENT A_PROHIBITED -> [withConnEntity <> "error: AGENT A_PROHIBITED" | logLevel <= CLLWarning] + AGENT (A_PROHIBITED e) -> [withConnEntity <> "error: AGENT A_PROHIBITED, " <> plain e | logLevel <= CLLWarning] CONN NOT_FOUND -> [withConnEntity <> "error: CONN NOT_FOUND" | logLevel <= CLLWarning] CRITICAL restart e -> [plain $ "critical error: " <> e] <> ["please restart the app" | restart] INTERNAL e -> [plain $ "internal error: " <> e] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 2bcd52ab3f..83ac69ebe9 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -431,7 +431,8 @@ serverCfg = smpHandshakeTimeout = 1000000, controlPort = Nothing, smpAgentCfg = defaultSMPClientAgentConfig, - allowSMPProxy = False + allowSMPProxy = False, + serverClientConcurrency = 16 } withSmpServer :: IO () -> IO () diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 2e549d9dd1..24281ae830 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -2310,12 +2310,12 @@ testAbortSwitchContact tmp = do alice <## "bob: you started changing address" -- repeat switch is prohibited alice ##> "/switch bob" - alice <## "error: command is prohibited" + alice <## "error: command is prohibited, switchConnectionAsync: already switching" -- stop switch alice #$> ("/abort switch bob", id, "switch aborted") -- repeat switch stop is prohibited alice ##> "/abort switch bob" - alice <## "error: command is prohibited" + alice <## "error: command is prohibited, abortConnectionSwitch: not allowed" withTestChatContactConnected tmp "bob" $ \bob -> do bob <## "alice started changing address for you" -- alice changes address again @@ -2356,12 +2356,12 @@ testAbortSwitchGroupMember tmp = do alice <## "#team: you started changing address for bob" -- repeat switch is prohibited alice ##> "/switch #team bob" - alice <## "error: command is prohibited" + alice <## "error: command is prohibited, switchConnectionAsync: already switching" -- stop switch alice #$> ("/abort switch #team bob", id, "switch aborted") -- repeat switch stop is prohibited alice ##> "/abort switch #team bob" - alice <## "error: command is prohibited" + alice <## "error: command is prohibited, abortConnectionSwitch: not allowed" withTestChatContactConnected tmp "bob" $ \bob -> do bob <## "#team: connected to server(s)" bob <## "#team: alice started changing address for you" @@ -2485,7 +2485,7 @@ setupDesynchronizedRatchet tmp alice = do withTestChat tmp "bob_old" $ \bob -> do bob <## "1 contacts connected (use /cs for the list)" bob ##> "/sync alice" - bob <## "error: command is prohibited" + bob <## "error: command is prohibited, synchronizeRatchet: not allowed" alice #> "@bob 1" bob <## "alice: decryption error (connection out of sync), synchronization required" bob <## "use /sync alice to synchronize" @@ -2495,7 +2495,7 @@ setupDesynchronizedRatchet tmp alice = do bob ##> "/tail @alice 1" bob <# "alice> decryption error, possibly due to the device change (header, 3 messages)" bob ##> "@alice 1" - bob <## "error: command is prohibited" + bob <## "error: command is prohibited, sendMessagesB: send prohibited" (alice "/sync #team alice" - bob <## "error: command is prohibited" + bob <## "error: command is prohibited, synchronizeRatchet: not allowed" alice #> "#team 1" bob <## "#team alice: decryption error (connection out of sync), synchronization required" bob <## "use /sync #team alice to synchronize" @@ -3294,7 +3294,7 @@ testGroupSyncRatchet tmp = bob <## "1 contacts connected (use /cs for the list)" bob <## "#team: connected to server(s)" bob `send` "#team 1" - bob <## "error: command is prohibited" -- silence? + bob <## "error: command is prohibited, sendMessagesB: send prohibited" -- silence? bob <# "#team 1" (alice copyBytes toPtr (ptr' `plusPtr` 5) sz' contents `shouldBe` src - sz' `shouldBe` fromIntegral len + sz' `shouldBe` len testMissingFileCApi :: FilePath -> IO () testMissingFileCApi tmp = do