Merge branch 'master' into master-ghc8107

src/Simplex/Chat/Controller.hs

@@ -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)

src/Simplex/Chat/Messages/CIContent.hs

@@ -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"

src/Simplex/Chat/Migrations/M20231214_item_content_tag.hs

@@ -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;
+|]

src/Simplex/Chat/Migrations/chat_schema.sql

@@ -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,

src/Simplex/Chat/Mobile.hs

@@ -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
 

src/Simplex/Chat/Mobile/File.hs

@@ -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
 

src/Simplex/Chat/Mobile/WebRTC.hs

@@ -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
 

src/Simplex/Chat/Remote.hs

@@ -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
 

src/Simplex/Chat/Remote/Protocol.hs

@@ -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}

src/Simplex/Chat/Remote/Transport.hs

@@ -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)
 

src/Simplex/Chat/Store/Messages.hs

@@ -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)

src/Simplex/Chat/Store/Migrations.hs

@@ -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

src/Simplex/Chat/Store/Shared.hs

@@ -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

src/Simplex/Chat/View.hs

@@ -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)