Merge branch 'master' into master-ghc8107

2026-05-11 17:35:01 +00:00 · 2023-12-21 00:45:10 +00:00
parent aea7ff1c89 7bcda7e54b
commit 754c76d6fd
72 changed files with 1070 additions and 448 deletions
@@ -21,7 +21,6 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
-import Crypto.Random (drgNew)
 import qualified Data.Aeson as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -34,7 +33,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char
 import Data.Constraint (Dict (..))
-import Data.Either (fromRight, partitionEithers, rights)
+import Data.Either (fromRight, lefts, partitionEithers, rights)
 import Data.Fixed (div')
 import Data.Functor (($>))
 import Data.Int (Int64)
@@ -207,7 +206,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
  servers <- agentServers config
  smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore
  agentAsync <- newTVarIO Nothing
-  idsDrg <- newTVarIO =<< liftIO drgNew
+  random <- liftIO C.newRandom
  inputQ <- newTBQueueIO tbqSize
  outputQ <- newTBQueueIO tbqSize
  connNetworkStatuses <- atomically TM.empty
@@ -242,7 +241,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
        agentAsync,
        chatStore,
        chatStoreChanged,
-        idsDrg,
+        random,
        inputQ,
        outputQ,
        connNetworkStatuses,
@@ -472,12 +471,14 @@ processChatCommand = \case
      coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day)
      day = 86400
  ListUsers -> CRUsersList <$> withStoreCtx' (Just "ListUsers, getUsersInfo") getUsersInfo
-  APISetActiveUser userId' viewPwd_ -> withUser $ \user -> do
+  APISetActiveUser userId' viewPwd_ -> do
+    unlessM chatStarted $ throwChatError CEChatNotStarted
+    user_ <- chatReadVar currentUser
    user' <- privateGetUser userId'
-    validateUserPassword user user' viewPwd_
+    validateUserPassword_ user_ user' viewPwd_
    withStoreCtx' (Just "APISetActiveUser, setActiveUser") $ \db -> setActiveUser db userId'
    let user'' = user' {activeUser = True}
-    asks currentUser >>= atomically . (`writeTVar` Just user'')
+    chatWriteVar currentUser $ Just user''
    pure $ CRActiveUser user''
  SetActiveUser uName viewPwd_ -> do
    tryChatError (withStore (`getUserIdByName` uName)) >>= \case
@@ -1074,8 +1075,9 @@ processChatCommand = \case
      then do
        calls <- asks currentCalls
        withChatLock "sendCallInvitation" $ do
-          callId <- CallId <$> drgRandomBytes 16
-          dhKeyPair <- if encryptedCall callType then Just <$> liftIO C.generateKeyPair' else pure Nothing
+          g <- asks random
+          callId <- atomically $ CallId <$> C.randomBytes 16 g
+          dhKeyPair <- atomically $ if encryptedCall callType then Just <$> C.generateKeyPair g else pure Nothing
          let invitation = CallInvitation {callType, callDhPubKey = fst <$> dhKeyPair}
              callState = CallInvitationSent {localCallType = callType, localDhPrivKey = snd <$> dhKeyPair}
          (msg, _) <- sendDirectContactMessage ct (XCallInv callId invitation)
@@ -1598,7 +1600,7 @@ processChatCommand = \case
    processChatCommand $ APIChatItemReaction chatRef chatItemId add reaction
  APINewGroup userId incognito gProfile@GroupProfile {displayName} -> withUserId userId $ \user -> do
    checkValidName displayName
-    gVar <- asks idsDrg
+    gVar <- asks random
    -- [incognito] generate incognito profile for group membership
    incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
    groupInfo <- withStore $ \db -> createNewGroup db gVar user gProfile incognitoProfile
@@ -1619,7 +1621,7 @@ processChatCommand = \case
    let sendInvitation = sendGrpInvitation user contact gInfo
    case contactMember contact members of
      Nothing -> do
-        gVar <- asks idsDrg
+        gVar <- asks random
        subMode <- chatReadVar subscriptionMode
        (agentConnId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing subMode
        member <- withStore $ \db -> createNewContactMember db gVar user gInfo contact memRole agentConnId cReq subMode
@@ -1882,7 +1884,7 @@ processChatCommand = \case
  SetFileToReceive fileId encrypted_ -> withUser $ \_ -> do
    withChatLock "setFileToReceive" . procCmd $ do
      encrypt <- (`fromMaybe` encrypted_) <$> chatReadVar encryptLocalFiles
-      cfArgs <- if encrypt then Just <$> liftIO CF.randomArgs else pure Nothing
+      cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing
      withStore' $ \db -> setRcvFileToReceive db fileId cfArgs
      ok_
  CancelFile fileId -> withUser $ \user@User {userId} ->
@@ -2027,7 +2029,7 @@ processChatCommand = \case
    -- in View.hs `r'` should be defined as `id` in this case
    -- procCmd :: m ChatResponse -> m ChatResponse
    -- procCmd action = do
-    --   ChatController {chatLock = l, smpAgent = a, outputQ = q, idsDrg = gVar} <- ask
+    --   ChatController {chatLock = l, smpAgent = a, outputQ = q, random = gVar} <- ask
    --   corrId <- liftIO $ SMP.CorrId <$> randomBytes gVar 8
    --   void . forkIO $
    --     withAgentLock a . withLock l name $
@@ -2293,17 +2295,20 @@ processChatCommand = \case
            then pure Nothing
            else Just . addUTCTime (realToFrac ttl) <$> liftIO getCurrentTime
    drgRandomBytes :: Int -> m ByteString
-    drgRandomBytes n = asks idsDrg >>= liftIO . (`randomBytes` n)
+    drgRandomBytes n = asks random >>= atomically . C.randomBytes n
    privateGetUser :: UserId -> m User
    privateGetUser userId =
      tryChatError (withStore (`getUser` userId)) >>= \case
        Left _ -> throwChatError CEUserUnknown
        Right user -> pure user
-    validateUserPassword :: User -> User -> Maybe UserPwd -> m ()
-    validateUserPassword User {userId} User {userId = userId', viewPwdHash} viewPwd_ =
+    validateUserPassword :: User -> User -> Maybe UserPwd -> m ()        
+    validateUserPassword = validateUserPassword_ . Just
+    validateUserPassword_ :: Maybe User -> User -> Maybe UserPwd -> m ()
+    validateUserPassword_ user_ User {userId = userId', viewPwdHash} viewPwd_ =
      forM_ viewPwdHash $ \pwdHash ->
-        let pwdOk = case viewPwd_ of
-              Nothing -> userId == userId'
+        let userId_ = (\User {userId} -> userId) <$> user_
+            pwdOk = case viewPwd_ of
+              Nothing -> userId_ == Just userId'
              Just (UserPwd viewPwd) -> validPassword viewPwd pwdHash
         in unless pwdOk $ throwChatError CEUserUnknown
    validPassword :: Text -> UserPwdHash -> Bool
@@ -2326,16 +2331,16 @@ processChatCommand = \case
        pure $ CRUserPrivacy {user, updatedUser = user'}
    checkDeleteChatUser :: User -> m ()
    checkDeleteChatUser user@User {userId} = do
-      when (activeUser user) $ throwChatError (CECantDeleteActiveUser userId)
      users <- withStore' getUsers
-      unless (length users > 1 && (isJust (viewPwdHash user) || length (filter (isNothing . viewPwdHash) users) > 1)) $
-        throwChatError (CECantDeleteLastUser userId)
+      let otherVisible = filter (\User {userId = userId', viewPwdHash} -> userId /= userId' && isNothing viewPwdHash) users
+      when (activeUser user && length otherVisible > 0) $ throwChatError (CECantDeleteActiveUser userId)
    deleteChatUser :: User -> Bool -> m ChatResponse
    deleteChatUser user delSMPQueues = do
      filesInfo <- withStore' (`getUserFileInfo` user)
      forM_ filesInfo $ \fileInfo -> deleteFile user fileInfo
      withAgent $ \a -> deleteUser a (aUserId user) delSMPQueues
      withStore' (`deleteUserRecord` user)
+      when (activeUser user) $ chatWriteVar currentUser Nothing
      ok_
    updateChatSettings :: ChatName -> (ChatSettings -> ChatSettings) -> m ChatResponse
    updateChatSettings (ChatName cType name) updateSettings = withUser $ \user -> do
@@ -2567,7 +2572,7 @@ toFSFilePath f =

 setFileToEncrypt :: ChatMonad m => RcvFileTransfer -> m RcvFileTransfer
 setFileToEncrypt ft@RcvFileTransfer {fileId} = do
-  cfArgs <- liftIO CF.randomArgs
+  cfArgs <- atomically . CF.randomArgs =<< asks random
  withStore' $ \db -> setFileCryptoArgs db fileId cfArgs
  pure (ft :: RcvFileTransfer) {cryptoArgs = Just cfArgs}

@@ -2722,7 +2727,7 @@ acceptGroupJoinRequestAsync
  ucr@UserContactRequest {agentInvitationId = AgentInvId invId}
  gLinkMemRole
  incognitoProfile = do
-    gVar <- asks idsDrg
+    gVar <- asks random
    (groupMemberId, memberId) <- withStore $ \db -> createAcceptedMember db gVar user gInfo ucr gLinkMemRole
    let Profile {displayName} = profileToSendOnAccept user incognitoProfile
        GroupMember {memberRole = userRole, memberId = userMemberId} = membership
@@ -3403,7 +3408,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
                  groupInfo <- withStore $ \db -> getGroupInfo db user groupId
                  subMode <- chatReadVar subscriptionMode
                  groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
-                  gVar <- asks idsDrg
+                  gVar <- asks random
                  withStore $ \db -> createNewContactMemberAsync db gVar user groupInfo ct gLinkMemRole groupConnIds (fromJVersionRange peerChatVRange) subMode
            Just (gInfo, m@GroupMember {activeConn}) ->
              when (maybe False ((== ConnReady) . connStatus) activeConn) $ do
@@ -4045,7 +4050,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do

    probeMatchingContactsAndMembers :: Contact -> IncognitoEnabled -> Bool -> m ()
    probeMatchingContactsAndMembers ct connectedIncognito doProbeContacts = do
-      gVar <- asks idsDrg
+      gVar <- asks random
      contactMerge <- readTVarIO =<< asks contactMergeEnabled
      if contactMerge && not connectedIncognito
        then do
@@ -4069,7 +4074,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
    probeMatchingMemberContact :: GroupMember -> IncognitoEnabled -> m ()
    probeMatchingMemberContact GroupMember {activeConn = Nothing} _ = pure ()
    probeMatchingMemberContact m@GroupMember {groupId, activeConn = Just conn} connectedIncognito = do
-      gVar <- asks idsDrg
+      gVar <- asks random
      contactMerge <- readTVarIO =<< asks contactMergeEnabled
      if contactMerge && not connectedIncognito
        then do
@@ -4770,7 +4775,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
      checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
      if featureAllowed SCFCalls forContact ct
        then do
-          dhKeyPair <- if encryptedCall callType then Just <$> liftIO C.generateKeyPair' else pure Nothing
+          g <- asks random
+          dhKeyPair <- atomically $ if encryptedCall callType then Just <$> C.generateKeyPair g else pure Nothing
          ci <- saveCallItem CISCallPending
          let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> (snd <$> dhKeyPair))
              callState = CallInvitationReceived {peerCallType = callType, localDhPubKey = fst <$> dhKeyPair, sharedKey}
@@ -4998,7 +5004,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
            Left _ -> messageError "x.grp.mem.inv error: referenced member does not exist"
            Right reMember -> do
              GroupMemberIntro {introId} <- withStore $ \db -> saveIntroInvitation db reMember m introInv
-              void . sendGroupMessage' user [reMember] (XGrpMemFwd (memberInfo m) introInv) groupId (Just introId) $
+              sendGroupMemberMessage user reMember (XGrpMemFwd (memberInfo m) introInv) groupId (Just introId) $
                withStore' $
                  \db -> updateIntroStatus db introId GMIntroInvForwarded
        _ -> messageError "x.grp.mem.inv can be only sent by invitee member"
@@ -5513,7 +5519,7 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do

 createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage
 createSndMessage chatMsgEvent connOrGroupId = do
-  gVar <- asks idsDrg
+  gVar <- asks random
  ChatConfig {chatVRange} <- asks config
  withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId ->
    let msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent}
@@ -5525,46 +5531,62 @@ directMessage chatMsgEvent = do
  pure $ strEncode ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent}

 deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> MsgBody -> MessageId -> m Int64
-deliverMessage conn@Connection {connId} cmEventTag msgBody msgId = do
-  let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
-  agentMsgId <- withAgent $ \a -> sendMessage a (aConnId conn) msgFlags msgBody
-  let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId}
-  withStore' $ \db -> createSndMsgDelivery db sndMsgDelivery msgId
+deliverMessage conn cmEventTag msgBody msgId =
+  deliverMessages [(conn, cmEventTag, msgBody, msgId)] >>= \case
+    [r] -> liftEither r
+    rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs)
+
+deliverMessages :: ChatMonad' m => [(Connection, CMEventTag e, MsgBody, MessageId)] -> m [Either ChatError Int64]
+deliverMessages msgReqs = do
+  sent <- zipWith prepareBatch msgReqs <$> withAgent' (`sendMessages` aReqs)
+  withStoreBatch $ \db -> map (bindRight $ createDelivery db) sent
+  where
+    aReqs = map (\(conn, cmEvTag, msgBody, _msgId) -> (aConnId conn, msgFlags cmEvTag, msgBody)) msgReqs
+    msgFlags cmEvTag = MsgFlags {notification = hasNotification cmEvTag}
+    prepareBatch req = bimap (`ChatErrorAgent` Nothing) (req,)
+    createDelivery :: DB.Connection -> ((Connection, CMEventTag e, MsgBody, MessageId), AgentMsgId) -> IO (Either ChatError Int64)
+    createDelivery db ((Connection {connId}, _, _, msgId), agentMsgId) =
+      Right <$> createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId}) msgId

 sendGroupMessage :: (MsgEncodingI e, ChatMonad m) => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> m (SndMessage, [GroupMember])
-sendGroupMessage user GroupInfo {groupId} members chatMsgEvent =
-  sendGroupMessage' user members chatMsgEvent groupId Nothing $ pure ()
-
-sendGroupMessage' :: forall e m. (MsgEncodingI e, ChatMonad m) => User -> [GroupMember] -> ChatMsgEvent e -> Int64 -> Maybe Int64 -> m () -> m (SndMessage, [GroupMember])
-sendGroupMessage' user members chatMsgEvent groupId introId_ postDeliver = do
-  msg <- createSndMessage chatMsgEvent (GroupId groupId)
-  -- TODO collect failed deliveries into a single error
+sendGroupMessage user GroupInfo {groupId} members chatMsgEvent = do
+  msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent (GroupId groupId)
  recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) $ \GroupMember {memberRole} -> memberRole
-  rs <- forM recipientMembers $ \m ->
-    messageMember m msg `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing)
-  let sentToMembers = catMaybes rs
+  let tag = toCMEventTag chatMsgEvent
+      (toSend, pending) = foldr addMember ([], []) recipientMembers
+      msgReqs = map (\(_, conn) -> (conn, tag, msgBody, msgId)) toSend
+  delivered <- deliverMessages msgReqs
+  let errors = lefts delivered
+  unless (null errors) $ toView $ CRChatErrors (Just user) errors
+  stored <- withStoreBatch' $ \db -> map (\m -> createPendingGroupMessage db (groupMemberId' m) msgId Nothing) pending
+  let sentToMembers = filterSent delivered toSend fst <> filterSent stored pending id
  pure (msg, sentToMembers)
  where
-    messageMember :: GroupMember -> SndMessage -> m (Maybe GroupMember)
-    messageMember m@GroupMember {groupMemberId} SndMessage {msgId, msgBody} = case memberConn m of
-      Nothing -> pendingOrForwarded
-      Just conn@Connection {connStatus}
-        | connDisabled conn || connStatus == ConnDeleted -> pure Nothing
-        | connStatus == ConnSndReady || connStatus == ConnReady -> do
-          let tag = toCMEventTag chatMsgEvent
-          deliverMessage conn tag msgBody msgId >> postDeliver
-          pure $ Just m
-        | otherwise -> pendingOrForwarded
+    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)
+    filterSent :: [Either ChatError a] -> [mem] -> (mem -> GroupMember) -> [GroupMember]
+    filterSent rs ms mem = [mem m | (Right _, m) <- zip rs ms]
+
+data MemberSendAction = MSASend Connection | MSAPending
+
+memberSendAction :: ChatMsgEvent e -> [GroupMember] -> GroupMember -> Maybe MemberSendAction
+memberSendAction chatMsgEvent members m = case memberConn m of
+  Nothing -> pendingOrForwarded
+  Just conn@Connection {connStatus}
+    | connDisabled conn || connStatus == ConnDeleted -> Nothing
+    | connStatus == ConnSndReady || connStatus == ConnReady -> Just (MSASend conn)
+    | otherwise -> pendingOrForwarded
+  where
+    pendingOrForwarded
+      | forwardSupported && isForwardedGroupMsg chatMsgEvent = Nothing
+      | isXGrpMsgForward chatMsgEvent = Nothing
+      | otherwise = Just MSAPending
      where
-        pendingOrForwarded
-          | forwardSupported && isForwardedGroupMsg chatMsgEvent = pure Nothing
-          | isXGrpMsgForward chatMsgEvent = pure Nothing
-          | otherwise = do
-            withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_
-            pure $ Just m
-        forwardSupported = do
+        forwardSupported =
          let mcvr = memberChatVRange' m
-          isCompatibleRange mcvr groupForwardVRange && invitingMemberSupportsForward
+           in isCompatibleRange mcvr groupForwardVRange && invitingMemberSupportsForward
        invitingMemberSupportsForward = case invitedByGroupMemberId m of
          Just invMemberId ->
            -- can be optimized for large groups by replacing [GroupMember] with Map GroupMemberId GroupMember
@@ -5578,6 +5600,16 @@ sendGroupMessage' user members chatMsgEvent groupId introId_ postDeliver = do
          XGrpMsgForward {} -> True
          _ -> False

+sendGroupMemberMessage :: forall e m. (MsgEncodingI e, ChatMonad m) => User -> GroupMember -> ChatMsgEvent e -> Int64 -> Maybe Int64 -> m () -> m ()
+sendGroupMemberMessage user m@GroupMember {groupMemberId} chatMsgEvent groupId introId_ postDeliver = do
+  msg <- createSndMessage chatMsgEvent (GroupId groupId)
+  messageMember msg `catchChatError` (\e -> toView (CRChatError (Just user) e))
+  where
+    messageMember :: SndMessage -> m ()
+    messageMember SndMessage {msgId, msgBody} = forM_ (memberSendAction chatMsgEvent [m] m) $ \case
+      MSASend conn -> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId >> postDeliver
+      MSAPending -> withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_
+
 shuffleMembers :: [a] -> (a -> GroupMemberRole) -> IO [a]
 shuffleMembers ms role = do
  let (adminMs, otherMs) = partition ((GRAdmin <=) . role) ms
@@ -84,6 +84,7 @@ import Simplex.RemoteControl.Invitation (RCSignedInvitation, RCVerifiedInvitatio
 import Simplex.RemoteControl.Types
 import System.IO (Handle)
 import System.Mem.Weak (Weak)
+import qualified UnliftIO.Exception as E
 import UnliftIO.STM

 versionNumber :: String
@@ -179,7 +180,7 @@ data ChatController = ChatController
    agentAsync :: TVar (Maybe (Async (), Maybe (Async ()))),
    chatStore :: SQLiteStore,
    chatStoreChanged :: TVar Bool, -- if True, chat should be fully restarted
-    idsDrg :: TVar ChaChaDRG,
+    random :: TVar ChaChaDRG,
    inputQ :: TBQueue String,
    outputQ :: TBQueue (Maybe CorrId, Maybe RemoteHostId, ChatResponse),
    connNetworkStatuses :: TMap AgentConnId NetworkStatus,
@@ -1287,12 +1288,26 @@ withStoreCtx ctx_ action = do
    handleInternal :: String -> SomeException -> IO (Either StoreError a)
    handleInternal ctxStr e = pure . Left . SEInternalError $ show e <> ctxStr

+withStoreBatch :: (ChatMonad' m, Traversable t) => (DB.Connection -> t (IO (Either ChatError a))) -> m (t (Either ChatError a))
+withStoreBatch actions = do
+  ChatController {chatStore} <- ask
+  liftIO $ withTransaction chatStore $ mapM (`E.catch` handleInternal) . actions
+  where
+    handleInternal :: E.SomeException -> IO (Either ChatError a)
+    handleInternal = pure . Left . ChatError . CEInternalError . show
+
+withStoreBatch' :: (ChatMonad' m, Traversable t) => (DB.Connection -> t (IO a)) -> m (t (Either ChatError a))
+withStoreBatch' actions = withStoreBatch $ fmap (fmap Right) . actions
+
 withAgent :: ChatMonad m => (AgentClient -> ExceptT AgentErrorType m a) -> m a
 withAgent action =
  asks smpAgent
    >>= runExceptT . action
    >>= liftEither . first (`ChatErrorAgent` Nothing)

+withAgent' :: ChatMonad' m => (AgentClient -> m a) -> m a
+withAgent' action = asks smpAgent >>= action
+
 $(JQ.deriveJSON (enumJSON $ dropPrefix "HS") ''HelpSection)

 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CLQ") ''ChatListQuery)
@@ -574,3 +574,32 @@ dbParseACIContent = fmap aciContentDBJSON . J.eitherDecodeStrict' . encodeUtf8
 -- platform specific
 instance FromJSON ACIContent where
  parseJSON = fmap aciContentJSON . J.parseJSON
+
+toCIContentTag :: CIContent e -> Text
+toCIContentTag ciContent = case ciContent of
+  CISndMsgContent _ -> "sndMsgContent"
+  CIRcvMsgContent _ -> "rcvMsgContent"
+  CISndDeleted _ -> "sndDeleted"
+  CIRcvDeleted _ -> "rcvDeleted"
+  CISndCall {} -> "sndCall"
+  CIRcvCall {} -> "rcvCall"
+  CIRcvIntegrityError _ -> "rcvIntegrityError"
+  CIRcvDecryptionError {} -> "rcvDecryptionError"
+  CIRcvGroupInvitation {} -> "rcvGroupInvitation"
+  CISndGroupInvitation {} -> "sndGroupInvitation"
+  CIRcvDirectEvent _ -> "rcvDirectEvent"
+  CIRcvGroupEvent _ -> "rcvGroupEvent"
+  CISndGroupEvent _ -> "sndGroupEvent"
+  CIRcvConnEvent _ -> "rcvConnEvent"
+  CISndConnEvent _ -> "sndConnEvent"
+  CIRcvChatFeature {} -> "rcvChatFeature"
+  CISndChatFeature {} -> "sndChatFeature"
+  CIRcvChatPreference {} -> "rcvChatPreference"
+  CISndChatPreference {} -> "sndChatPreference"
+  CIRcvGroupFeature {} -> "rcvGroupFeature"
+  CISndGroupFeature {} -> "sndGroupFeature"
+  CIRcvChatFeatureRejected _ -> "rcvChatFeatureRejected"
+  CIRcvGroupFeatureRejected _ -> "rcvGroupFeatureRejected"
+  CISndModerated -> "sndModerated"
+  CIRcvModerated -> "rcvModerated"
+  CIInvalidJSON _ -> "invalidJSON"
@@ -0,0 +1,18 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Migrations.M20231214_item_content_tag where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20231214_item_content_tag :: Query
+m20231214_item_content_tag =
+  [sql|
+ALTER TABLE chat_items ADD COLUMN item_content_tag TEXT;
+|]
+
+down_m20231214_item_content_tag :: Query
+down_m20231214_item_content_tag =
+  [sql|
+ALTER TABLE chat_items DROP COLUMN item_content_tag;
+|]
@@ -379,7 +379,8 @@ CREATE TABLE chat_items(
  item_live INTEGER,
  item_deleted_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
  item_deleted_ts TEXT,
-  forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL
+  forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
+  item_content_tag TEXT
 );
 CREATE TABLE chat_item_messages(
  chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
@@ -94,15 +94,15 @@ foreign export ccall "chat_password_hash" cChatPasswordHash :: CString -> CStrin

 foreign export ccall "chat_valid_name" cChatValidName :: CString -> IO CString

-foreign export ccall "chat_encrypt_media" cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
+foreign export ccall "chat_encrypt_media" cChatEncryptMedia :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CString

 foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString

-foreign export ccall "chat_write_file" cChatWriteFile :: CString -> Ptr Word8 -> CInt -> IO CJSONString
+foreign export ccall "chat_write_file" cChatWriteFile :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CJSONString

 foreign export ccall "chat_read_file" cChatReadFile :: CString -> CString -> CString -> IO (Ptr Word8)

-foreign export ccall "chat_encrypt_file" cChatEncryptFile :: CString -> CString -> IO CJSONString
+foreign export ccall "chat_encrypt_file" cChatEncryptFile :: StablePtr ChatController -> CString -> CString -> IO CJSONString

 foreign export ccall "chat_decrypt_file" cChatDecryptFile :: CString -> CString -> CString -> CString -> IO CString

@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
@@ -31,7 +32,9 @@ import Data.Word (Word32, Word8)
 import Foreign.C
 import Foreign.Marshal.Alloc (mallocBytes)
 import Foreign.Ptr
+import Foreign.StablePtr
 import Foreign.Storable (poke, pokeByteOff)
+import Simplex.Chat.Controller (ChatController (..))
 import Simplex.Chat.Mobile.Shared
 import Simplex.Chat.Util (chunkSize, encryptFile)
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..), CryptoFileHandle, FTCryptoError (..))
@@ -39,7 +42,7 @@ import qualified Simplex.Messaging.Crypto.File as CF
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Util (catchAll)
-import UnliftIO (Handle, IOMode (..), withFile)
+import UnliftIO (Handle, IOMode (..), atomically, withFile)

 data WriteFileResult
  = WFResult {cryptoArgs :: CryptoFileArgs}
@@ -47,16 +50,17 @@ data WriteFileResult

 $(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "WF") ''WriteFileResult)

-cChatWriteFile :: CString -> Ptr Word8 -> CInt -> IO CJSONString
-cChatWriteFile cPath ptr len = do
+cChatWriteFile :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CJSONString
+cChatWriteFile cc cPath ptr len = do
+  c <- deRefStablePtr cc
  path <- peekCString cPath
  s <- getByteString ptr len
-  r <- chatWriteFile path s
+  r <- chatWriteFile c path s
  newCStringFromLazyBS $ J.encode r

-chatWriteFile :: FilePath -> ByteString -> IO WriteFileResult
-chatWriteFile path s = do
-  cfArgs <- CF.randomArgs
+chatWriteFile :: ChatController -> FilePath -> ByteString -> IO WriteFileResult
+chatWriteFile ChatController {random} path s = do
+  cfArgs <- atomically $ CF.randomArgs random
  let file = CryptoFile path $ Just cfArgs
  either WFError (\_ -> WFResult cfArgs)
    <$> runCatchExceptT (withExceptT show $ CF.writeFile file $ LB.fromStrict s)
@@ -87,19 +91,20 @@ chatReadFile path keyStr nonceStr = runCatchExceptT $ do
  let file = CryptoFile path $ Just $ CFArgs key nonce
  withExceptT show $ CF.readFile file

-cChatEncryptFile :: CString -> CString -> IO CJSONString
-cChatEncryptFile cFromPath cToPath = do
+cChatEncryptFile :: StablePtr ChatController -> CString -> CString -> IO CJSONString
+cChatEncryptFile cc cFromPath cToPath = do
+  c <- deRefStablePtr cc
  fromPath <- peekCString cFromPath
  toPath <- peekCString cToPath
-  r <- chatEncryptFile fromPath toPath
+  r <- chatEncryptFile c fromPath toPath
  newCAString . LB'.unpack $ J.encode r

-chatEncryptFile :: FilePath -> FilePath -> IO WriteFileResult
-chatEncryptFile fromPath toPath =
+chatEncryptFile :: ChatController -> FilePath -> FilePath -> IO WriteFileResult
+chatEncryptFile ChatController {random} fromPath toPath =
  either WFError WFResult <$> runCatchExceptT encrypt
  where
    encrypt = do
-      cfArgs <- liftIO CF.randomArgs
+      cfArgs <- atomically $ CF.randomArgs random
      encryptFile fromPath toPath cfArgs
      pure cfArgs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}

 module Simplex.Chat.Mobile.WebRTC
  ( cChatEncryptMedia,
@@ -21,11 +22,14 @@ import Data.Either (fromLeft)
 import Data.Word (Word8)
 import Foreign.C (CInt, CString, newCAString)
 import Foreign.Ptr (Ptr)
+import Foreign.StablePtr
+import Simplex.Chat.Controller (ChatController (..))
 import Simplex.Chat.Mobile.Shared
 import qualified Simplex.Messaging.Crypto as C
+import UnliftIO (atomically)

-cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
-cChatEncryptMedia = cTransformMedia chatEncryptMedia
+cChatEncryptMedia :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CString
+cChatEncryptMedia = cTransformMedia . chatEncryptMedia

 cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
 cChatDecryptMedia = cTransformMedia chatDecryptMedia
@@ -39,11 +43,12 @@ cTransformMedia f cKey cFrame cFrameLen = do
    putFrame s = when (B.length s <= fromIntegral cFrameLen) $ putByteString cFrame s
 {-# INLINE cTransformMedia #-}

-chatEncryptMedia :: ByteString -> ByteString -> ExceptT String IO ByteString
-chatEncryptMedia keyStr frame = do
+chatEncryptMedia :: StablePtr ChatController -> ByteString -> ByteString -> ExceptT String IO ByteString
+chatEncryptMedia cc keyStr frame = do
+  ChatController {random} <- liftIO $ deRefStablePtr cc
  len <- checkFrameLen frame
  key <- decodeKey keyStr
-  iv <- liftIO C.randomGCMIV
+  iv <- atomically $ C.randomGCMIV random
  (tag, frame') <- withExceptT show $ C.encryptAESNoPad key iv $ B.take len frame
  pure $ frame' <> BA.convert (C.unAuthTag tag) <> C.unGCMIV iv

@@ -142,7 +142,7 @@ startRemoteHost rh_ rcAddrPrefs_ port_ = do
    Just (rhId, multicast) -> do
      rh@RemoteHost {hostPairing} <- withStore $ \db -> getRemoteHost db rhId
      pure (RHId rhId, multicast, Just $ remoteHostInfo rh $ Just RHSStarting, hostPairing) -- get from the database, start multicast if requested
-    Nothing -> (RHNew,False,Nothing,) <$> rcNewHostPairing
+    Nothing -> withAgent $ \a -> (RHNew,False,Nothing,) <$> rcNewHostPairing a
  sseq <- startRemoteHostSession rhKey
  ctrlAppInfo <- mkCtrlAppInfo
  (localAddrs, invitation, rchClient, vars) <- handleConnectError rhKey sseq . withAgent $ \a -> rcConnectHost a pairing (J.toJSON ctrlAppInfo) multicast rcAddrPrefs_ port_
@@ -352,7 +352,7 @@ storeRemoteFile rhId encrypted_ localPath = do
      tmpDir <- getChatTempDirectory
      createDirectoryIfMissing True tmpDir
      tmpFile <- tmpDir `uniqueCombine` takeFileName localPath
-      cfArgs <- liftIO CF.randomArgs
+      cfArgs <- atomically . CF.randomArgs =<< asks random
      liftError (ChatError . CEFileWrite tmpFile) $ encryptFile localPath tmpFile cfArgs
      pure $ CryptoFile tmpFile $ Just cfArgs

@@ -78,7 +78,7 @@ $(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse)

 mkRemoteHostClient :: ChatMonad m => HTTP2Client -> HostSessKeys -> SessionCode -> FilePath -> HostAppInfo -> m RemoteHostClient
 mkRemoteHostClient httpClient sessionKeys sessionCode storePath HostAppInfo {encoding, deviceName, encryptFiles} = do
-  drg <- asks $ agentDRG . smpAgent
+  drg <- asks random
  counter <- newTVarIO 1
  let HostSessKeys {hybridKey, idPrivKey, sessPrivKey} = sessionKeys
      signatures = RSSign {idPrivKey, sessPrivKey}
@@ -95,7 +95,7 @@ mkRemoteHostClient httpClient sessionKeys sessionCode storePath HostAppInfo {enc

 mkCtrlRemoteCrypto :: ChatMonad m => CtrlSessKeys -> SessionCode -> m RemoteCrypto
 mkCtrlRemoteCrypto CtrlSessKeys {hybridKey, idPubKey, sessPubKey} sessionCode = do
-  drg <- asks $ agentDRG . smpAgent
+  drg <- asks random
  counter <- newTVarIO 1
  let signatures = RSVerify {idPubKey, sessPubKey}
  pure RemoteCrypto {drg, counter, sessionCode, hybridKey, signatures}
@@ -24,7 +24,7 @@ type EncryptedFile = ((Handle, Word32), C.CbNonce, LC.SbState)

 prepareEncryptedFile :: RemoteCrypto -> (Handle, Word32) -> ExceptT RemoteProtocolError IO EncryptedFile
 prepareEncryptedFile RemoteCrypto {drg, hybridKey} f = do
-  nonce <- atomically $ C.pseudoRandomCbNonce drg
+  nonce <- atomically $ C.randomCbNonce drg
  sbState <- liftEitherWith (const $ PRERemoteControl RCEEncrypt) $ LC.kcbInit hybridKey nonce
  pure (f, nonce, sbState)

@@ -399,18 +399,19 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
        -- user and IDs
        user_id, created_by_msg_id, contact_id, group_id, group_member_id,
        -- meta
-        item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, forwarded_by_group_member_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at,
+        item_sent, item_ts, item_content, item_content_tag, item_text, item_status, shared_msg_id,
+        forwarded_by_group_member_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at,
        -- quote
        quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id
-      ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+      ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
    |]
    ((userId, msgId_) :. idsRow :. itemRow :. quoteRow)
  ciId <- insertedRowId db
  forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt
  pure ciId
  where
-    itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId, Maybe GroupMemberId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime)
-    itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId, forwardedByMember) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed
+    itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe SharedMsgId, Maybe GroupMemberId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime)
+    itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId, forwardedByMember) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed
    idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64)
    idsRow = case chatDirection of
      CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing)
@@ -92,6 +92,7 @@ import Simplex.Chat.Migrations.M20231113_group_forward
 import Simplex.Chat.Migrations.M20231114_remote_control
 import Simplex.Chat.Migrations.M20231126_remote_ctrl_address
 import Simplex.Chat.Migrations.M20231207_chat_list_pagination
+import Simplex.Chat.Migrations.M20231214_item_content_tag
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))

 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -183,7 +184,8 @@ schemaMigrations =
    ("20231113_group_forward", m20231113_group_forward, Just down_m20231113_group_forward),
    ("20231114_remote_control", m20231114_remote_control, Just down_m20231114_remote_control),
    ("20231126_remote_ctrl_address", m20231126_remote_ctrl_address, Just down_m20231126_remote_ctrl_address),
-    ("20231207_chat_list_pagination", m20231207_chat_list_pagination, Just down_m20231207_chat_list_pagination)
+    ("20231207_chat_list_pagination", m20231207_chat_list_pagination, Just down_m20231207_chat_list_pagination),
+    ("20231214_item_content_tag", m20231214_item_content_tag, Just down_m20231214_item_content_tag)
  ]

 -- | The list of migrations in ascending order by date
@@ -15,7 +15,7 @@ import qualified Control.Exception as E
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
-import Crypto.Random (ChaChaDRG, randomBytesGenerate)
+import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson.TH as J
 import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
@@ -35,6 +35,7 @@ import Simplex.Chat.Types.Preferences
 import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
 import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Protocol (SubscriptionMode (..))
 import Simplex.Messaging.Util (allFinally)
@@ -389,7 +390,4 @@ createWithRandomBytes size gVar create = tryCreate 3
          | otherwise -> throwError . SEInternalError $ show e

 encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ByteString
-encodedRandomBytes gVar = fmap B64.encode . randomBytes gVar
-
-randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString
-randomBytes gVar = atomically . stateTVar gVar . randomBytesGenerate
+encodedRandomBytes gVar n = atomically $ B64.encode <$> C.randomBytes n gVar
@@ -473,7 +473,9 @@ chatItemDeletedText ChatItem {meta = CIMeta {itemDeleted}, content} membership_
      _ -> ""

 viewUsersList :: [UserInfo] -> [StyledString]
-viewUsersList = mapMaybe userInfo . sortOn ldn
+viewUsersList us =
+  let ss = mapMaybe userInfo $ sortOn ldn us
+   in if null ss then ["no users"] else ss
  where
    ldn (UserInfo User {localDisplayName = n} _) = T.toLower n
    userInfo (UserInfo User {localDisplayName = n, profile = LocalProfile {fullName}, activeUser, showNtfs, viewPwdHash} count)