Merge branch 'master' into f/public-groups

tests/ChatTests/Direct.hs

@@ -122,6 +122,7 @@ chatDirectTests = do
     it "create user with same servers" testCreateUserSameServers
     it "delete user" testDeleteUser
     it "delete user with chat tags" testDeleteUserChatTags
+    it "rejects raw chat TTL updates for another user's chat" testRejectCrossUserChatTTL
     it "users have different chat item TTL configuration, chat items expire" testUsersDifferentCIExpirationTTL
     it "chat items expire after restart for all users according to per user configuration" testUsersRestartCIExpiration
     it "chat items only expire for users who configured expiration" testEnableCIExpirationOnlyForOneUser
@@ -2096,6 +2097,25 @@ testDeleteUserChatTags =
       alice ##> "/users"
       alice <## "alisa (active)"
 
+testRejectCrossUserChatTTL :: HasCallStack => TestParams -> IO ()
+testRejectCrossUserChatTTL =
+  testChat2 aliceProfile bobProfile $
+    \alice bob -> do
+      connectUsers alice bob
+
+      alice #$> ("/_ttl 1 @2 2", id, "ok")
+      alice #$> ("/ttl @bob", id, "old messages are set to be deleted after: 2 second(s)")
+
+      alice ##> "/create user alisa"
+      showActiveUser alice "alisa"
+
+      alice ##> "/_ttl 2 @2 9"
+      alice <##. "chat db error:"
+
+      alice ##> "/user alice"
+      showActiveUser alice "alice (Alice)"
+      alice #$> ("/ttl @bob", id, "old messages are set to be deleted after: 2 second(s)")
+
 testUsersDifferentCIExpirationTTL :: HasCallStack => TestParams -> IO ()
 testUsersDifferentCIExpirationTTL ps = do
   withNewTestChat ps "bob" bobProfile $ \bob -> do

tests/MessageBatching.hs

@@ -12,14 +12,31 @@ import qualified Data.ByteString as B
 import Data.ByteString.Internal (c2w)
 import Data.Either (partitionEithers)
 import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.String (IsString (..))
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
+import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
+import Simplex.Chat.Delivery
+  ( DeliveryJobScope (DJSGroup, jobSpec),
+    DeliveryJobSpec (DJDeliveryJob, includePending),
+    MessageDeliveryTask (MessageDeliveryTask, brokerTs, fwdSender, jobScope, senderGMId, taskId, verifiedMsg),
+    deliveryTaskId,
+  )
 import Simplex.Chat.Messages.Batch
 import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..))
 import Simplex.Chat.Messages (SndMessage (..))
-import Simplex.Chat.Protocol (maxEncodedMsgLength)
-import Simplex.Chat.Types (SharedMsgId (..))
+import Simplex.Chat.Protocol
+  ( ChatMessage (ChatMessage),
+    ChatMsgEvent (XMsgNew),
+    FwdSender (FwdChannel),
+    GrpMsgForward (GrpMsgForward),
+    MsgContent (MCText),
+    VerifiedMsg (VMUnsigned),
+    maxEncodedMsgLength,
+    mcSimple,
+  )
+import Simplex.Chat.Types (SharedMsgId (..), chatInitialVRange)
 import Simplex.Messaging.Encoding (Large (..), smpEncodeList)
 import Test.Hspec
 
@@ -28,6 +45,8 @@ batchingTests = describe "message batching tests" $ do
   testBatchingCorrectness
   testBinaryBatchingCorrectness
   it "image x.msg.new and x.msg.file.descr should fit into single batch" testImageFitsSingleBatch
+  it "does not create a relay delivery body when every task is oversized" testRelayBatchAllLarge
+  it "classifies a task that fits raw but not as a framed singleton as large" testRelayBatchSingletonOverflow
 
 instance IsString SndMessage where
   fromString s = SndMessage {msgId, sharedMsgId = SharedMsgId "", msgBody = s', signedMsg_ = Nothing}
@@ -131,6 +150,37 @@ testImageFitsSingleBatch = do
 
   runBatcherTest' BMJson maxEncodedMsgLength [msg xMsgNewStr, msg descrStr] [] [batched]
 
+testRelayBatchAllLarge :: IO ()
+testRelayBatchAllLarge = do
+  let task1 = deliveryTask 1 "one"
+      task2 = deliveryTask 2 "two"
+      (body_, accepted, large) = batchDeliveryTasks1 chatInitialVRange 1 (task1 :| [task2])
+  body_ `shouldBe` Nothing
+  map deliveryTaskId accepted `shouldBe` []
+  map deliveryTaskId large `shouldBe` [1, 2]
+
+deliveryTask :: Int64 -> T.Text -> MessageDeliveryTask
+deliveryTask taskId text =
+  MessageDeliveryTask
+    { taskId,
+      jobScope = DJSGroup {jobSpec = DJDeliveryJob {includePending = False}},
+      senderGMId = 1,
+      fwdSender = FwdChannel,
+      brokerTs = systemToUTCTime $ MkSystemTime 0 0,
+      verifiedMsg =
+        VMUnsigned
+          (ChatMessage chatInitialVRange Nothing $ XMsgNew $ mcSimple $ MCText text)
+    }
+
+testRelayBatchSingletonOverflow :: IO ()
+testRelayBatchSingletonOverflow = do
+  let task = deliveryTask 1 "overflow"
+      elemLen = B.length $ encodeFwdElement (GrpMsgForward (fwdSender task) (brokerTs task)) (verifiedMsg task)
+      (body_, accepted, large) = batchDeliveryTasks1 chatInitialVRange (elemLen + 2) (task :| [])
+  body_ `shouldBe` Nothing
+  map deliveryTaskId accepted `shouldBe` []
+  map deliveryTaskId large `shouldBe` [1]
+
 runBatcherTest :: BatchMode -> Int -> [SndMessage] -> [ChatError] -> [ByteString] -> Spec
 runBatcherTest mode maxLen msgs expectedErrors expectedBatches =
   it