buffering

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: 9893935e7c3cf8d102c85730a4e48d32f05c2ec7
+    tag: 3f177b8c8a91de124dfe871af82bd7433f275efb
 
 source-repository-package
     type: git

package.yaml

@@ -181,6 +181,3 @@ ghc-options:
   - -Wredundant-constraints
   - -Wincomplete-record-updates
   - -Wunused-type-patterns
-
-default-extensions:
-  - StrictData

scripts/nix/sha256map.nix

@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."9893935e7c3cf8d102c85730a4e48d32f05c2ec7" = "1bpgsdnmk8fml6ad9bjbvyichvd0kq0nqj562xyy5y1npymaxpyn";
+  "https://github.com/simplex-chat/simplexmq.git"."3f177b8c8a91de124dfe871af82bd7433f275efb" = "18lhllv1w6wnvvphpqcib4fa7fqiyqf01swix2afs80mnxjip01v";
   "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";

simplex-chat.cabal

@@ -201,8 +201,6 @@ library
       Paths_simplex_chat
   hs-source-dirs:
       src
-  default-extensions:
-      StrictData
   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.*
@@ -266,8 +264,6 @@ executable simplex-bot
       Paths_simplex_chat
   hs-source-dirs:
       apps/simplex-bot
-  default-extensions:
-      StrictData
   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.*
@@ -332,8 +328,6 @@ executable simplex-bot-advanced
       Paths_simplex_chat
   hs-source-dirs:
       apps/simplex-bot-advanced
-  default-extensions:
-      StrictData
   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.*
@@ -397,8 +391,6 @@ executable simplex-broadcast-bot
   hs-source-dirs:
       apps/simplex-broadcast-bot
       apps/simplex-broadcast-bot/src
-  default-extensions:
-      StrictData
   other-modules:
       Broadcast.Bot
       Broadcast.Options
@@ -468,8 +460,6 @@ executable simplex-chat
       Paths_simplex_chat
   hs-source-dirs:
       apps/simplex-chat
-  default-extensions:
-      StrictData
   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.*
@@ -534,8 +524,6 @@ executable simplex-directory-service
   hs-source-dirs:
       apps/simplex-directory-service
       apps/simplex-directory-service/src
-  default-extensions:
-      StrictData
   other-modules:
       Directory.Events
       Directory.Options
@@ -641,8 +629,6 @@ test-suite simplex-chat-test
       tests
       apps/simplex-broadcast-bot/src
       apps/simplex-directory-service/src
-  default-extensions:
-      StrictData
   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.*

src/Simplex/Chat.hs

@@ -2872,19 +2872,27 @@ processChatCommand' vr = \case
     updateProfile_ user@User {profile = p@LocalProfile {displayName = n}} p'@Profile {displayName = n'} updateUser
       | p' == fromLocalProfile p = pure $ CRUserProfileNoChange user
       | otherwise = do
+          liftIO $ putStrLn $ "*** updateProfile_ profile: " <> show p'
           when (n /= n') $ checkValidName n'
           -- read contacts before user update to correctly merge preferences
           contacts <- withFastStore' $ \db -> getUserContacts db vr user
+          liftIO $ putStrLn $ "*** updateProfile_ contacts: " <> show contacts
           user' <- updateUser
           asks currentUser >>= atomically . (`writeTVar` Just user')
           withChatLock "updateProfile" . procCmd $ do
             let changedCts_ = L.nonEmpty $ foldr (addChangedProfileContact user') [] contacts
             summary <- case changedCts_ of
-              Nothing -> pure $ UserProfileUpdateSummary 0 0 []
+              Nothing -> do
+                liftIO $ putStrLn $ "*** updateProfile_ no changed contacts"
+                pure $ UserProfileUpdateSummary 0 0 []
               Just changedCts -> do
+                liftIO $ putStrLn $ "*** updateProfile_ changed contacts: " <> show changedCts_
                 let idsEvts = L.map ctSndEvent changedCts
+                liftIO $ putStrLn $ "*** updateProfile_ before sending"
                 msgReqs_ <- lift $ L.zipWith ctMsgReq changedCts <$> createSndMessages idsEvts
+                liftIO $ putStrLn $ "*** updateProfile_ created messages"
                 (errs, cts) <- partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_
+                liftIO $ putStrLn $ "*** updateProfile_ delivered messages to contacts: " <> show (length cts) <> ", errors: " <> show errs
                 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'
@@ -2892,7 +2900,7 @@ processChatCommand' vr = \case
                   UserProfileUpdateSummary
                     { updateSuccesses = length cts,
                       updateFailures = length errs,
-                      changedContacts = map (\ChangedProfileContact {ct'} -> ct') changedCts'
+                      changedContacts = map (\ChangedProfileContact {ct'} -> ct') $ L.toList changedCts
                     }
             pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary
       where
@@ -3505,6 +3513,7 @@ data ChangedProfileContact = ChangedProfileContact
     mergedProfile' :: Profile,
     conn :: Connection
   }
+  deriving (Show)
 
 prepareGroupMsg :: User -> GroupInfo -> MsgContent -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> CM (MsgContainer, Maybe (CIQuote 'CTGroup))
 prepareGroupMsg user GroupInfo {groupId, membership} mc quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of
@@ -7634,7 +7643,9 @@ deliverMessages msgs = deliverMessagesB $ L.map Right msgs
 deliverMessagesB :: NonEmpty (Either ChatError ChatMsgReq) -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption)))
 deliverMessagesB msgReqs = do
   msgReqs' <- liftIO compressBodies
+  liftIO $ putStrLn "deliverMessagesB"
   sent <- L.zipWith prepareBatch msgReqs' <$> withAgent (`sendMessagesB` snd (mapAccumL toAgent Nothing msgReqs'))
+  liftIO $ putStrLn $ "deliverMessagesB sent: " <> show sent
   lift . void $ withStoreBatch' $ \db -> map (updatePQSndEnabled db) (rights . L.toList $ sent)
   lift . withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent
   where

src/Simplex/Chat/Mobile.hs

@@ -10,6 +10,7 @@ module Simplex.Chat.Mobile where
 
 import Control.Concurrent.STM
 import Control.Exception (SomeException, catch)
+import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.Reader
 import qualified Data.Aeson as J
@@ -53,7 +54,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), BasicAuth (..), CorrId (..), ProtoServerWithAuth (..), ProtocolServer (..))
 import Simplex.Messaging.Util (catchAll, liftEitherWith, safeDecodeUtf8)
-import System.IO (utf8)
+import System.IO (BufferMode (..), hSetBuffering, stderr, stdout, utf8)
 import System.Timeout (timeout)
 
 data DBMigrationResult
@@ -192,7 +193,7 @@ mobileChatOpts dbFilePrefix =
             smpServers = [],
             xftpServers = [],
             simpleNetCfg = defaultSimpleNetCfg,
-            logLevel = CLLImportant,
+            logLevel = CLLDebug,
             logConnections = False,
             logServerHosts = True,
             logAgent = Nothing,
@@ -220,7 +221,7 @@ defaultMobileConfig :: ChatConfig
 defaultMobileConfig =
   defaultChatConfig
     { confirmMigrations = MCYesUp,
-      logLevel = CLLError,
+      logLevel = CLLDebug,
       coreApi = True,
       deviceNameForRemote = "Mobile"
     }
@@ -266,7 +267,10 @@ handleErr :: IO () -> IO String
 handleErr a = (a $> "") `catch` (pure . show @SomeException)
 
 chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString
-chatSendCmd cc = chatSendRemoteCmd cc Nothing
+chatSendCmd cc cmd = withGlobalLogging logCfg $ do
+  hSetBuffering stdout LineBuffering
+  hSetBuffering stderr LineBuffering
+  chatSendRemoteCmd cc Nothing cmd
 
 chatSendRemoteCmd :: ChatController -> Maybe RemoteHostId -> B.ByteString -> IO JSONByteString
 chatSendRemoteCmd cc rh s = J.encode . APIResponse Nothing rh <$> runReaderT (execChatCommand rh s) cc

src/Simplex/Chat/Store/Direct.hs

@@ -85,7 +85,7 @@ where
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
-import Data.Either (rights)
+import Data.Either (partitionEithers, rights)
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Maybe (fromMaybe, isJust, isNothing)
@@ -590,8 +590,13 @@ getContactByName db vr user localDisplayName = do
 getUserContacts :: DB.Connection -> VersionRangeChat -> User -> IO [Contact]
 getUserContacts db vr user@User {userId} = do
   contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId)
-  contacts <- rights <$> mapM (runExceptT . getContact db vr user) contactIds
+  putStrLn $ "*** getUserContacts contactIds" <> show contactIds
-  pure $ filter (\Contact {activeConn} -> isJust activeConn) contacts
+  (errs, contacts) <- partitionEithers <$> mapM (runExceptT . getContact db vr user) contactIds
+  putStrLn $ "*** getUserContacts contacts" <> show contacts
+  putStrLn $ "*** getUserContacts errors" <> show errs
+  r <- pure $ filter (\Contact {activeConn} -> isJust activeConn) contacts
+  putStrLn $ "*** getUserContacts filtered contacts" <> show r
+  pure r
 
 createOrUpdateContactRequest :: DB.Connection -> VersionRangeChat -> User -> Int64 -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> PQSupport -> ExceptT StoreError IO ChatOrRequest
 createOrUpdateContactRequest db vr user@User {userId, userContactId} userContactLinkId invId (VersionRange minV maxV) Profile {displayName, fullName, image, contactLink, preferences} xContactId_ pqSup =

src/Simplex/Chat/Store/Shared.hs

@@ -22,7 +22,7 @@ import qualified Data.Aeson.TH as J
 import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
-import Data.Maybe (fromMaybe, isJust, listToMaybe)
+import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime (..), getCurrentTime)
@@ -46,6 +46,7 @@ import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Protocol (SubscriptionMode (..))
 import Simplex.Messaging.Util (allFinally)
 import Simplex.Messaging.Version
+import System.IO.Unsafe (unsafePerformIO)
 import UnliftIO.STM
 
 data ChatLockEntity
@@ -210,7 +211,26 @@ toConnection vr ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGr
 toMaybeConnection :: VersionRangeChat -> MaybeConnectionRow -> Maybe Connection
 toMaybeConnection vr ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, customUserProfileId, Just connStatus, Just connType, Just contactConnInitiated, Just localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just pqSupport, Just pqEncryption, pqSndEnabled_, pqRcvEnabled_, Just authErrCounter, Just quotaErrCounter, connChatVersion, Just minVer, Just maxVer)) =
   Just $ toConnection vr ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, contactConnInitiated, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled_, pqRcvEnabled_, authErrCounter, quotaErrCounter, connChatVersion, minVer, maxVer))
-toMaybeConnection _ _ = Nothing
+toMaybeConnection _ ((connId_, agentConnId_, connLevel_, viaContact, viaUserContactLink, viaGroupLink_, groupLinkId, customUserProfileId, connStatus_, connType_, contactConnInitiated_, localAlias_) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt_, code_, verifiedAt_, pqSupport_, pqEncryption_, pqSndEnabled_, pqRcvEnabled_, authErrCounter_, quotaErrCounter_, connChatVersion, minVer_, maxVer_)) =
+  unsafePerformIO logRow `seq` Nothing
+  where
+    logRow = do
+      putStrLn $ "connId_ = " <> show connId_
+      when (isNothing agentConnId_) $ putStrLn "agentConnId_ = Nothing"
+      when (isNothing connLevel_) $ putStrLn "connLevel_ = Nothing"
+      when (isNothing viaGroupLink_) $ putStrLn "viaGroupLink_ = Nothing"
+      when (isNothing connStatus_) $ putStrLn "connStatus_ = Nothing"
+      when (isNothing connType_) $ putStrLn "connType_ = Nothing"
+      when (isNothing contactConnInitiated_) $ putStrLn "contactConnInitiated_ = Nothing"
+      when (isNothing localAlias_) $ putStrLn "localAlias_ = Nothing"
+      when (isNothing contactId) $ putStrLn "contactId = Nothing"
+      when (isNothing createdAt_) $ putStrLn "createdAt_ = Nothing"
+      when (isNothing pqSupport_) $ putStrLn "pqSupport_ = Nothing"
+      when (isNothing pqEncryption_) $ putStrLn "pqEncryption_ = Nothing"
+      when (isNothing authErrCounter_) $ putStrLn "authErrCounter_ = Nothing"
+      when (isNothing quotaErrCounter_) $ putStrLn "quotaErrCounter_ = Nothing"
+      when (isNothing minVer_) $ putStrLn "minVer_ = Nothing"
+      when (isNothing maxVer_) $ putStrLn "maxVer_ = Nothing"
 
 createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> ConnStatus -> VersionChat -> VersionRangeChat -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> SubscriptionMode -> PQSupport -> IO Connection
 createConnection_ db userId connType entityId acId connStatus connChatVersion peerChatVRange@(VersionRange minV maxV) viaContact viaUserContactLink customUserProfileId connLevel currentTs subMode pqSup = do
@@ -394,7 +414,7 @@ type ContactRow = Only ContactId :. ContactRow'
 toContact :: VersionRangeChat -> User -> ContactRow :. MaybeConnectionRow -> Contact
 toContact vr user ((Only contactId :. (profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. (contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData)) :. connRow) =
   let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
-      activeConn = toMaybeConnection vr connRow
+      activeConn = unsafePerformIO (putStrLn $ "contactId " <> show contactId) `seq` toMaybeConnection vr connRow
       chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
       incognito = maybe False connIncognito activeConn
       mergedPreferences = contactUserPreferences user userPreferences preferences incognito