diff --git a/simplex-chat.cabal b/simplex-chat.cabal index bd3ca6e353..24ccf24ded 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -84,6 +84,7 @@ library Simplex.Chat.Store.Shared Simplex.Chat.Styled Simplex.Chat.Types + Simplex.Chat.Types.MemberRelations Simplex.Chat.Types.Preferences Simplex.Chat.Types.Shared Simplex.Chat.Types.UITheme @@ -544,6 +545,7 @@ test-suite simplex-chat-test JSONFixtures JSONTests MarkdownTests + MemberRelationsTests MessageBatching OperatorTests ProtocolTests diff --git a/src/Simplex/Chat/Types/MemberRelations.hs b/src/Simplex/Chat/Types/MemberRelations.hs new file mode 100644 index 0000000000..7245b22472 --- /dev/null +++ b/src/Simplex/Chat/Types/MemberRelations.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE LambdaCase #-} + +module Simplex.Chat.Types.MemberRelations + ( MemberRelation (..), + getRelation, + setRelation, + setRelations, + ) +where + +import Control.Monad +import Data.Bits ((.&.), (.|.), complement) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Internal (toForeignPtr, unsafeCreate) +import Data.Int (Int64) +import Data.Word (Word8) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Utils (copyBytes, fillBytes) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (peekByteOff, pokeByteOff) + +data MemberRelation + = MRNew + | MRIntroduced + | MRConnected + deriving (Eq, Show) + +toRelationInt :: MemberRelation -> Word8 +toRelationInt = \case + MRNew -> 0 + MRIntroduced -> 1 + MRConnected -> 2 + +fromRelationInt :: Word8 -> MemberRelation +fromRelationInt = \case + 0 -> MRNew + 1 -> MRIntroduced + 2 -> MRConnected + _ -> MRNew + +-- | Get the relation status of a member at a given index from the relations vector. +-- Returns 'MRNew' if the vector is not long enough (lazy initialization). +getRelation :: Int64 -> ByteString -> MemberRelation +getRelation i v + | i < 0 || fromIntegral i >= B.length v = MRNew + | otherwise = fromRelationInt $ (v `B.index` fromIntegral i) .&. relationMask + + +-- | Set the relation status of a member at a given index in the relations vector. +-- Expands the vector lazily if needed (padding with zeros for 'MRNew' relation). +setRelation :: Int64 -> MemberRelation -> ByteString -> ByteString +setRelation i r v + | i >= 0 = setRelations [(i, r)] v + | otherwise = v + +-- | Set multiple relations at once. +-- Expands the vector lazily if needed (padding with zeros for 'MRNew' relation). +setRelations :: [(Int64, MemberRelation)] -> ByteString -> ByteString +setRelations [] v = v +setRelations relations v = + let (fp, off, len) = toForeignPtr v + newLen = max len $ fromIntegral $ maximum (map fst relations) + 1 + in unsafeCreate newLen $ \ptr -> do + withForeignPtr fp $ \vPtr -> copyBytes ptr (vPtr `plusPtr` off) len + when (newLen > len) $ fillBytes (ptr `plusPtr` len) 0 (newLen - len) + forM_ relations $ \(ix, r) -> when (ix >= 0) $ do + let i = fromIntegral ix + b <- peekByteOff ptr i + let b' = (b .&. complement relationMask) .|. toRelationInt r + pokeByteOff ptr i b' + +relationMask :: Word8 +relationMask = 0x07 -- reserving 3 bits diff --git a/tests/MemberRelationsTests.hs b/tests/MemberRelationsTests.hs new file mode 100644 index 0000000000..968dcbec43 --- /dev/null +++ b/tests/MemberRelationsTests.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE OverloadedStrings #-} + +module MemberRelationsTests where + +import Control.Monad +import qualified Data.ByteString as B +import Simplex.Chat.Types.MemberRelations +import Test.Hspec + +memberRelationsTests :: Spec +memberRelationsTests = do + describe "MemberRelation vector operations" $ do + describe "getRelation" $ do + it "returns MRNew for empty vector" $ do + getRelation 0 B.empty `shouldBe` MRNew + getRelation 5 B.empty `shouldBe` MRNew + getRelation 100 B.empty `shouldBe` MRNew + + it "returns MRNew for negative index" $ do + getRelation (-1) B.empty `shouldBe` MRNew + getRelation (-5) (B.pack [0xFF]) `shouldBe` MRNew + + it "returns MRNew for index beyond vector length" $ do + let vec = B.pack [0x00] + getRelation 10 vec `shouldBe` MRNew + + it "reads single relation from byte" $ do + let vec = B.pack [0x01] + getRelation 0 vec `shouldBe` MRIntroduced + + it "reads multiple relations" $ do + let vec = B.pack [0, 0, 1, 2] + getRelation 0 vec `shouldBe` MRNew + getRelation 1 vec `shouldBe` MRNew + getRelation 2 vec `shouldBe` MRIntroduced + getRelation 3 vec `shouldBe` MRConnected + + it "reads multiple relations 2" $ do + let vec = B.pack [1, 1, 0, 0, 2, 2, 0, 0] + getRelation 0 vec `shouldBe` MRIntroduced + getRelation 1 vec `shouldBe` MRIntroduced + getRelation 4 vec `shouldBe` MRConnected + getRelation 5 vec `shouldBe` MRConnected + + it "ignore reserved bits" $ do + let vec = B.pack [0xF9] -- 11111001 + getRelation 0 vec `shouldBe` MRIntroduced + + describe "setRelation" $ do + it "sets relation in empty vector (lazy expansion)" $ do + let vec = setRelation 0 MRIntroduced B.empty + getRelation 0 vec `shouldBe` MRIntroduced + + it "ignores negative index" $ do + let vec = setRelation (-1) MRIntroduced B.empty + vec `shouldBe` B.empty + + it "expands vector to required length" $ do + let vec = setRelation 5 MRConnected B.empty + B.length vec `shouldBe` 6 + getRelation 5 vec `shouldBe` MRConnected + -- Other positions should be MRNew (0) + getRelation 0 vec `shouldBe` MRNew + getRelation 10 vec `shouldBe` MRNew + B.length vec `shouldBe` 6 + + it "updates existing relation without affecting others" $ do + -- Start: [01][01][00][00] + let vec1 = setRelation 0 MRIntroduced B.empty + let vec2 = setRelation 1 MRIntroduced vec1 + -- Update: [01][10][00][00] + let vec3 = setRelation 1 MRConnected vec2 + getRelation 0 vec3 `shouldBe` MRIntroduced + getRelation 1 vec3 `shouldBe` MRConnected + + it "updates relation in specific byte of multi-byte vector" $ do + let vec1 = setRelation 0 MRIntroduced B.empty + let vec2 = setRelation 10 MRConnected vec1 + B.length vec2 `shouldBe` 11 + getRelation 0 vec2 `shouldBe` MRIntroduced + getRelation 10 vec2 `shouldBe` MRConnected + forM_ [1..9] $ \i -> getRelation i vec2 `shouldBe` MRNew + + it "handles setting relation at last position in byte" $ do + let vec = setRelation 3 MRConnected B.empty + getRelation 3 vec `shouldBe` MRConnected + + it "preserves vector when setting same value" $ do + let vec1 = setRelation 0 MRIntroduced B.empty + let vec2 = setRelation 0 MRIntroduced vec1 + vec2 `shouldBe` vec1 + getRelation 0 vec2 `shouldBe` MRIntroduced + + it "preserves reserved bits" $ do + let v = B.pack [0xF8] -- 11111000 + getRelation 0 v `shouldBe` MRNew + let v' = setRelation 0 MRIntroduced v + getRelation 0 v' `shouldBe` MRIntroduced + B.unpack v' `shouldBe` [0xF9] -- 11111001 + + describe "setRelations" $ do + it "returns same vector for empty list" $ do + let vec = B.pack [0x42] + setRelations [] vec `shouldBe` vec + + it "sets multiple relations in empty vector" $ do + let updates = [(0, MRIntroduced), (1, MRConnected), (2, MRIntroduced)] + let vec = setRelations updates B.empty + getRelation 0 vec `shouldBe` MRIntroduced + getRelation 1 vec `shouldBe` MRConnected + getRelation 2 vec `shouldBe` MRIntroduced + getRelation 3 vec `shouldBe` MRNew -- Unset position + + it "sets multiple relations 1" $ do + let updates = [(0, MRIntroduced), (1, MRConnected), (2, MRConnected), (3, MRIntroduced)] + let vec = setRelations updates B.empty + B.length vec `shouldBe` 4 + getRelation 0 vec `shouldBe` MRIntroduced + getRelation 1 vec `shouldBe` MRConnected + getRelation 2 vec `shouldBe` MRConnected + getRelation 3 vec `shouldBe` MRIntroduced + + it "sets multiple relations 2" $ do + let updates = [(0, MRIntroduced), (5, MRConnected), (10, MRIntroduced)] + let vec = setRelations updates B.empty + B.length vec `shouldBe` 11 + getRelation 0 vec `shouldBe` MRIntroduced + getRelation 5 vec `shouldBe` MRConnected + getRelation 10 vec `shouldBe` MRIntroduced + getRelation 7 vec `shouldBe` MRNew -- Unset position between + + it "handles sparse updates (few indices in large range)" $ do + -- Sparse: 3 updates in large group + let updates = [(0, MRIntroduced), (100, MRConnected), (5000, MRIntroduced)] + let vec = setRelations updates B.empty + getRelation 0 vec `shouldBe` MRIntroduced + getRelation 100 vec `shouldBe` MRConnected + getRelation 5000 vec `shouldBe` MRIntroduced + getRelation 50 vec `shouldBe` MRNew -- Untouched position + + it "handles dense updates (many consecutive indices)" $ do + -- Dense: many consecutive updates + let updates = [(i, if even i then MRIntroduced else MRConnected) | i <- [0 .. 99]] + let vec = setRelations updates B.empty + all (\i -> getRelation i vec == (if even i then MRIntroduced else MRConnected)) [0 .. 99] `shouldBe` True + + it "handles unsorted input correctly" $ do + let updates = [(10, MRConnected), (2, MRIntroduced), (5, MRConnected), (0, MRIntroduced)] + let vec = setRelations updates B.empty + getRelation 0 vec `shouldBe` MRIntroduced + getRelation 2 vec `shouldBe` MRIntroduced + getRelation 5 vec `shouldBe` MRConnected + getRelation 10 vec `shouldBe` MRConnected + + it "handles duplicate indices (last one wins)" $ do + let updates = [(0, MRIntroduced), (0, MRConnected), (0, MRIntroduced)] + let vec = setRelations updates B.empty + getRelation 0 vec `shouldBe` MRIntroduced + + it "preserves existing relations not in update list" $ do + let vec1 = setRelation 0 MRConnected B.empty + let vec2 = setRelation 5 MRIntroduced vec1 + let updates = [(10, MRConnected)] + let vec3 = setRelations updates vec2 + getRelation 0 vec3 `shouldBe` MRConnected + getRelation 5 vec3 `shouldBe` MRIntroduced + getRelation 10 vec3 `shouldBe` MRConnected + + describe "edge cases and invariants" $ do + it "round-trip: set then get returns same value" $ do + let vec1 = setRelation 42 MRConnected B.empty + getRelation 42 vec1 `shouldBe` MRConnected + + it "multiple round-trips preserve values" $ do + let vec1 = setRelation 0 MRIntroduced B.empty + let vec2 = setRelation 1 MRConnected vec1 + let vec3 = setRelation 2 MRIntroduced vec2 + getRelation 0 vec3 `shouldBe` MRIntroduced + getRelation 1 vec3 `shouldBe` MRConnected + getRelation 2 vec3 `shouldBe` MRIntroduced + + it "setRelations equivalent to multiple setRelation calls" $ do + let updates = [(0, MRIntroduced), (5, MRConnected), (10, MRIntroduced)] + let vecBatch = setRelations updates B.empty + let vecSeq = setRelation 10 MRIntroduced $ setRelation 5 MRConnected $ setRelation 0 MRIntroduced B.empty + vecBatch `shouldBe` vecSeq + getRelation 0 vecBatch `shouldBe` getRelation 0 vecSeq + getRelation 5 vecBatch `shouldBe` getRelation 5 vecSeq + getRelation 10 vecBatch `shouldBe` getRelation 10 vecSeq + + it "handles large group size (10000 members)" $ do + let updates = [(0, MRIntroduced), (5000, MRConnected), (9999, MRIntroduced)] + let vec = setRelations updates B.empty + B.length vec `shouldBe` 10000 + getRelation 0 vec `shouldBe` MRIntroduced + getRelation 5000 vec `shouldBe` MRConnected + getRelation 9999 vec `shouldBe` MRIntroduced + + it "all status values can be stored and retrieved" $ do + let vec1 = setRelation 0 MRNew B.empty + let vec2 = setRelation 1 MRIntroduced vec1 + let vec3 = setRelation 2 MRConnected vec2 + getRelation 0 vec3 `shouldBe` MRNew + getRelation 1 vec3 `shouldBe` MRIntroduced + getRelation 2 vec3 `shouldBe` MRConnected + + it "vector length is minimal (lazy expansion)" $ do + let vec = setRelation 3 MRConnected B.empty + B.length vec `shouldBe` 4 diff --git a/tests/Test.hs b/tests/Test.hs index e4e76fd43e..e1a5a58c7d 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -13,6 +13,7 @@ import Control.Logger.Simple import Data.Time.Clock.System import JSONTests import MarkdownTests +import MemberRelationsTests import MessageBatching import ProtocolTests import OperatorTests @@ -59,6 +60,7 @@ main = do #endif describe "SimpleX chat markdown" markdownTests describe "JSON Tests" jsonTests + describe "Member relations" memberRelationsTests describe "SimpleX chat view" viewTests describe "SimpleX chat protocol" protocolTests describe "Valid names" validNameTests