Merge origin/master into sh/namespace

The names (simplex_name / RSLV) feature and master's badge feature both
extended the contact/group profile row layer. Resolution keeps both, with
simplex_name ordered last (chronological - it is the newer column):
- Profile/LocalProfile gain badge + simplex_name; simplex_name last in the
  data types, record builds, schema, and SQL row types/SELECTs/INSERTs
- SQL row types, SELECTs and INSERT/UPDATE lists carry both badge_* and
  simplex_name columns (simplex_name after badge)
- migration lists ordered by date (master 0601/0602 before names 0603+)
- SQLite chat_schema.sql regenerated; Postgres chat_schema.sql hand-merged

Verified: lib + test suite build; SchemaDump, Operators, Protocol and
direct/group profile round-trip tests pass.

tests/BadgeTests.hs

@@ -0,0 +1,142 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module BadgeTests (badgeTests) where
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+import qualified Data.Aeson as J
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Chat.Badges
+import Simplex.Messaging.Crypto.BBS
+import Test.Hspec
+
+badgeTests :: Spec
+badgeTests = do
+  it "full workflow: request, issue, verify credential, generate and verify proof" testFullWorkflow
+  it "should reject badge with tampered type" testTamperedType
+  it "should reject badge with tampered expiry" testTamperedExpiry
+  it "should reject badge with wrong server key" testWrongKey
+  it "should report a key index missing from configured keys" testUnknownKeyIdx
+  it "should compute badge status correctly" testExpiryCheck
+  it "should treat lifetime badges as always active" testLifetimeBadge
+  it "should accept unknown badge types" testUnknownBadgeType
+  it "credential serializes to a paste-able token and back" testCredentialSerialization
+
+proofOf :: BadgeProof -> BBSProof
+proofOf (BadgeProof _ _ p _) = p
+
+proofInfo :: BadgeProof -> BadgeInfo
+proofInfo (BadgeProof _ _ _ i) = i
+
+testKeyIdx :: Int
+testKeyIdx = 1
+
+keysFor :: BBSPublicKey -> Map Int BBSPublicKey
+keysFor = M.singleton testKeyIdx
+
+testFullWorkflow :: IO ()
+testFullWorkflow = do
+  Right (pk, sk) <- bbsKeyGen
+  drg <- C.newRandom
+  mk <- generateMasterKey drg
+  let req = BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Just futureTime, badgeExtra = ""}}
+  Just vreq <- verifyPayment (BPRedeemCode "TEST") req
+  Right cred <- issueBadge testKeyIdx sk vreq
+  let BadgeCredential idx mk' _ _ = cred
+  idx `shouldBe` testKeyIdx
+  mk' `shouldBe` mk
+  verifyCredential pk cred >>= (`shouldBe` True)
+  Right badge <- generateBadgeProof pk cred (BBSPresHeader "nonce-1")
+  -- the proof inherits the credential's key index, so receivers find the right key
+  let BadgeProof {badgeKeyIdx} = badge
+  badgeKeyIdx `shouldBe` testKeyIdx
+  verifyBadge (keysFor pk) badge >>= (`shouldBe` Just True)
+  Right badge2 <- generateBadgeProof pk cred (BBSPresHeader "nonce-2")
+  verifyBadge (keysFor pk) badge2 >>= (`shouldBe` Just True)
+  proofOf badge `shouldNotBe` proofOf badge2
+
+testTamperedType :: IO ()
+testTamperedType = do
+  (pk, BadgeProof idx ph p info) <- issueBadgeProof BTSupporter (Just futureTime)
+  verifyBadge (keysFor pk) (BadgeProof idx ph p info {badgeType = BTLegend}) >>= (`shouldBe` Just False)
+
+testTamperedExpiry :: IO ()
+testTamperedExpiry = do
+  (pk, BadgeProof idx ph p info) <- issueBadgeProof BTSupporter (Just futureTime)
+  verifyBadge (keysFor pk) (BadgeProof idx ph p info {badgeExpiry = Just pastTime}) >>= (`shouldBe` Just False)
+
+testWrongKey :: IO ()
+testWrongKey = do
+  (_, badge) <- issueBadgeProof BTSupporter (Just futureTime)
+  Right (pk2, _) <- bbsKeyGen
+  verifyBadge (keysFor pk2) badge >>= (`shouldBe` Just False)
+
+testUnknownKeyIdx :: IO ()
+testUnknownKeyIdx = do
+  (pk, badge) <- issueBadgeProof BTSupporter (Just futureTime)
+  -- a key index not in the configured keys cannot be verified at all (Nothing)
+  verifyBadge (M.singleton (testKeyIdx + 1) pk) badge >>= (`shouldBe` Nothing)
+
+testExpiryCheck :: IO ()
+testExpiryCheck = do
+  now <- getCurrentTime
+  let info expiry = BadgeInfo {badgeType = BTSupporter, badgeExpiry = expiry, badgeExtra = ""}
+      futureInfo = info (Just futureTime)
+  mkBadgeStatus now (Just True) futureInfo `shouldBe` BSActive
+  mkBadgeStatus now (Just True) (info (Just (addUTCTime (-nominalDay) now))) `shouldBe` BSExpired
+  mkBadgeStatus now (Just True) (info (Just pastTime)) `shouldBe` BSExpiredOld
+  mkBadgeStatus now (Just False) futureInfo `shouldBe` BSFailed
+  mkBadgeStatus now Nothing futureInfo `shouldBe` BSUnknownKey
+
+testLifetimeBadge :: IO ()
+testLifetimeBadge = do
+  now <- getCurrentTime
+  (pk, badge) <- issueBadgeProof BTInvestor Nothing
+  verifyBadge (keysFor pk) badge >>= (`shouldBe` Just True)
+  mkBadgeStatus now (Just True) (proofInfo badge) `shouldBe` BSActive
+
+testUnknownBadgeType :: IO ()
+testUnknownBadgeType = do
+  (pk, badge) <- issueBadgeProof (BTUnknown "future_type") (Just futureTime)
+  verifyBadge (keysFor pk) badge >>= (`shouldBe` Just True)
+
+testCredentialSerialization :: IO ()
+testCredentialSerialization = do
+  Right (pk, sk) <- bbsKeyGen
+  drg <- C.newRandom
+  mk <- generateMasterKey drg
+  let mkCred expiry = do
+        Right cred <- issueBadge testKeyIdx sk (VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = expiry, badgeExtra = ""}})
+        pure cred
+  dated <- mkCred (Just futureTime)
+  lifetime <- mkCred Nothing
+  J.eitherDecode (J.encode dated) `shouldBe` Right dated
+  J.eitherDecode (J.encode lifetime) `shouldBe` Right lifetime
+  -- a decoded credential still verifies against the issuing key
+  case J.eitherDecode (J.encode dated) of
+    Right cred -> verifyCredential pk cred >>= (`shouldBe` True)
+    Left e -> expectationFailure e
+
+-- Helpers
+
+futureTime :: UTCTime
+futureTime = posixSecondsToUTCTime 4102444800 -- 2099-12-31
+
+pastTime :: UTCTime
+pastTime = posixSecondsToUTCTime 1577836800 -- 2020-01-01
+
+issueBadgeProof :: BadgeType -> Maybe UTCTime -> IO (BBSPublicKey, BadgeProof)
+issueBadgeProof bt expiry = do
+  Right (pk, sk) <- bbsKeyGen
+  drg <- C.newRandom
+  mk <- generateMasterKey drg
+  let vreq = VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = bt, badgeExpiry = expiry, badgeExtra = ""}}
+  Right cred <- issueBadge testKeyIdx sk vreq
+  Right badge <- generateBadgeProof pk cred (BBSPresHeader "test-nonce")
+  pure (pk, badge)

tests/Bots/BroadcastTests.hs

@@ -33,7 +33,7 @@ withBroadcastBot opts test =
     bot = simplexChatCore testCfg (mkChatOpts opts) $ broadcastBot opts
 
 broadcastBotProfile :: Profile
-broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", shortDescr = Nothing, image = Nothing, contactLink = Nothing, simplexName = Nothing, peerType = Just CPTBot, preferences = Nothing}
+broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, simplexName = Nothing}
 
 mkBotOpts :: TestParams -> [KnownContact] -> BroadcastBotOpts
 mkBotOpts ps publishers =

tests/Bots/DirectoryTests.hs

@@ -27,8 +27,10 @@ import Simplex.Chat.Controller (ChatConfig (..))
 import qualified Simplex.Chat.Markdown as MD
 import Simplex.Chat.Options (CoreChatOpts (..))
 import Simplex.Chat.Options.DB
+import Simplex.Chat.Protocol (memberSupportVoiceVersion)
 import Simplex.Chat.Types (ChatPeerType (..), Profile (..))
 import Simplex.Chat.Types.Shared (GroupMemberRole (..))
+import Simplex.Messaging.Version
 import System.FilePath ((</>))
 import Test.Hspec hiding (it)
 
@@ -96,7 +98,7 @@ directoryServiceTests = do
     it "should update subscriber count periodically" testLinkCheckUpdatesCount
 
 directoryProfile :: Profile
-directoryProfile = Profile {displayName = "SimpleX Directory", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, simplexName = Nothing, peerType = Just CPTBot, preferences = Nothing}
+directoryProfile = Profile {displayName = "SimpleX Directory", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, simplexName = Nothing}
 
 mkDirectoryOpts :: TestParams -> [KnownContact] -> Maybe KnownGroup -> Maybe FilePath -> DirectoryOpts
 mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder =
@@ -1492,7 +1494,7 @@ testVoiceCaptchaOldClient ps@TestParams {tmpPath} = do
   setPermissions mockScript $ setOwnerExecutable True $ setOwnerReadable True $ setOwnerWritable True emptyPermissions
   withDirectoryServiceVoiceCaptcha ps mockScript $ \superUser dsLink ->
     withNewTestChat ps "bob" bobProfile $ \bob ->
-      withNewTestChatCfg ps testCfgVPrev "cath" cathProfile $ \cath -> do
+      withNewTestChatCfg ps testCfg {chatVRange = (chatVRange testCfg) {maxVersion = prevVersion memberSupportVoiceVersion}} "cath" cathProfile $ \cath -> do
         bob `connectVia` dsLink
         registerGroup superUser bob "privacy" "Privacy"
         bob #> "@'SimpleX Directory' /role 1"

tests/ChatClient.hs

@@ -24,11 +24,12 @@ import Control.Monad.Reader
 import Data.Functor (($>))
 import Data.List (dropWhileEnd, find)
 import Data.Maybe (isNothing)
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Network.Socket
 import Simplex.Chat
-import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg)
+import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), WebPreviewConfig (..), defaultSimpleNetCfg)
 import Simplex.Chat.Core
 import Simplex.Chat.Library.Commands
 import Simplex.Chat.Options
@@ -153,6 +154,7 @@ testCoreOpts =
       tbqSize = 16,
       deviceName = Nothing,
       chatRelay = False,
+      webPreviewConfig = Nothing,
       highlyAvailable = False,
       yesToUpMigrations = False,
       migrationBackupPath = Nothing,
@@ -162,6 +164,9 @@ testCoreOpts =
 relayTestOpts :: ChatOpts
 relayTestOpts = testOpts {coreOptions = testCoreOpts {chatRelay = True}}
 
+relayWebTestOpts :: Text -> FilePath -> Maybe FilePath -> ChatOpts
+relayWebTestOpts webDomain webDir webCorsFile = testOpts {coreOptions = testCoreOpts {chatRelay = True, webPreviewConfig = Just WebPreviewConfig {webDomain, webJsonDir = webDir, webCorsFile, webUpdateInterval = 300, webPreviewItemCount = 50}}}
+
 #if !defined(dbPostgres)
 getTestOpts :: Bool -> ScrubbedBytes -> ChatOpts
 getTestOpts maintenance dbKey = testOpts {coreOptions = testCoreOpts {maintenance, dbOptions = (dbOptions testCoreOpts) {dbKey}}}
@@ -212,7 +217,7 @@ testCfg =
       shortLinkPresetServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001"],
       testView = True,
       tbqSize = 16,
-      channelSubscriberRole = GRMember, -- starting role is GRMember to test members sending messages
+      channelSubscriberRole = GRObserver,
       confirmMigrations = MCYesUp
     }
 
@@ -582,7 +587,6 @@ smpServerCfg =
       allowSMPProxy = True,
       serverClientConcurrency = 16,
       namesConfig = Nothing,
-      namesResolverCall_ = Nothing,
       information = Nothing,
       startOptions = StartOptions {maintenance = False, compactLog = False, logLevel = LogError, skipWarnings = False, confirmMigrations = MCYesUp}
     }

tests/ChatTests/ChatRelays.hs

@@ -1,11 +1,14 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module ChatTests.ChatRelays where
 
 import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Groups (memberJoinChannel, memberJoinChannel', prepareChannel, prepareChannel', prepareChannel1Relay, setupRelay)
+import ChatTests.Profiles (addTestBadge, issueTestBadge, testBadgeKeys)
 import ChatTests.Utils
 import Control.Concurrent (threadDelay)
 import qualified Data.Aeson as J
@@ -14,10 +17,17 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import ProtocolTests (testGroupProfile)
+import Simplex.Chat.Controller (ChatConfig (..))
 import Simplex.Chat.Protocol (LinkOwnerSig, MsgChatLink (..), MsgContent (..))
 import Simplex.Chat.Types (GroupProfile (..))
+import Simplex.Chat.Controller (CorsOrigin (..))
+import Simplex.Chat.Web (WebChannelPreview (..), WebMessage (..), extractOrigin, removeStaleFiles, writeCorsConfig)
+import Simplex.Messaging.Crypto.BBS (bbsKeyGen)
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Util (decodeJSON)
+import qualified Data.Set as S
+import System.Directory (createDirectoryIfMissing, doesFileExist, listDirectory)
+import System.FilePath (takeExtension, (</>))
 import Test.Hspec hiding (it)
 
 chatRelayTests :: SpecWith TestParams
@@ -28,10 +38,57 @@ chatRelayTests = do
     it "re-add soft-deleted relay by same name" testReAddRelaySameName
     it "test chat relay" testChatRelayTest
     it "relay profile updated in address" testRelayProfileUpdateInAddress
+  describe "relay capabilities" $ do
+    it "relay sends webDomain in capabilities" testRelayWebCapabilities
+  describe "web preview" $ do
+    it "render messages and members" testWebPreviewRender
+    it "incremental render adds new messages" testWebPreviewIncremental
+    it "edited and deleted messages" testWebPreviewEditedDeleted
+    it "reactions in rendered messages" testWebPreviewReactions
+    it "non-public group produces no file" testWebPreviewNonPublic
+    it "multiple channels produce multiple files" testWebPreviewMultipleChannels
+    it "channel deletion removes preview file" testWebPreviewChannelDeleted
+    it "removeStaleFiles preserves non-base64url files" testWebPreviewStaleCleanup
+    it "generate CORS config" testWebPreviewCors
+    it "extractOrigin strips path from URL" testExtractOrigin
   describe "share channel card" $ do
     it "share channel card in direct chat" testShareChannelDirect
     it "share channel card in group" testShareChannelGroup
     it "share channel card in channel" testShareChannelChannel
+  describe "channel badges" $ do
+    it "subscriber and owner see each other's badges forwarded by the relay" testChannelMemberBadges
+
+-- A channel owner and a subscriber each hold a supporter badge; their member profiles only reach
+-- each other forwarded by the relay. Both sides should still see the other's active badge.
+testChannelMemberBadges :: HasCallStack => TestParams -> IO ()
+testChannelMemberBadges ps = do
+  Right (pk, sk) <- bbsKeyGen
+  let cfg = testCfg {badgePublicKeys = testBadgeKeys pk}
+  withNewTestChatCfgOpts ps cfg testOpts "alice" aliceProfile $ \alice ->
+    withNewTestChatCfgOpts ps cfg relayTestOpts "bob" bobProfile $ \bob ->
+      withNewTestChatCfgOpts ps cfg testOpts "cath" cathProfile $ \cath -> do
+        addTestBadge alice =<< issueTestBadge sk Nothing
+        addTestBadge cath =<< issueTestBadge sk Nothing
+        (shortLink, fullLink) <- prepareChannel1Relay "team" alice bob
+        memberJoinChannel "team" [bob] [alice] shortLink fullLink cath
+        -- a channel message lets the relay-forwarded member profiles settle on both sides
+        alice #> "#team hi"
+        bob <# "#team> hi"
+        cath <# "#team> hi [>>]"
+        threadDelay 1000000
+        -- owner and subscriber are connected only via the relay, so /i shows the badge then "member not connected" for both
+        alice ##> "/i #team cath"
+        alice <## "group ID: 1"
+        alice <##. "member ID: "
+        alice <## "supporter badge - active"
+        alice <## "no expiry"
+        alice <## "member not connected"
+        cath ##> "/i #team alice"
+        cath <## "group ID: 1"
+        cath <##. "member ID: "
+        cath <## "supporter badge - active"
+        cath <## "no expiry"
+        cath <## "member not connected"
 
 testGetSetChatRelays :: HasCallStack => TestParams -> IO ()
 testGetSetChatRelays ps =
@@ -325,6 +382,238 @@ testShareChannelChannel ps =
 getTermLine2 :: TestCC -> IO (String, String)
 getTermLine2 c = (,) <$> getTermLine c <*> getTermLine c
 
+testRelayWebCapabilities :: HasCallStack => TestParams -> IO ()
+testRelayWebCapabilities ps =
+  withNewTestChat ps "alice" aliceProfile $ \alice ->
+    withNewTestChatOpts ps (relayWebTestOpts "relay.example.com" (tmpPath ps </> "web_cap") Nothing) "bob" bobProfile $ \relay -> do
+      rName <- userName relay
+      relay ##> "/ad"
+      (relaySLink, _cLink) <- getContactLinks relay True
+      alice ##> ("/relays name=" <> rName <> " " <> relaySLink)
+      alice <## "ok"
+      alice ##> "/public group relays=1 #news"
+      alice <## "group #news is created"
+      alice <## "wait for selected relay(s) to join, then you can invite members via group link"
+      concurrentlyN_
+        [ do
+            alice <## "#news: group link relays updated, current relays:"
+            alice <### [EndsWith ": active, web: relay.example.com"]
+            alice <## "group link:"
+            _ <- getTermLine alice
+            pure (),
+          relay <## "#news: you joined the group as relay"
+        ]
+
+-- Helper: set up relay with web config + channel
+withWebChannel :: TestParams -> String -> (TestCC -> TestCC -> FilePath -> IO ()) -> IO ()
+withWebChannel ps gName test = do
+  let webDir = tmpPath ps </> "web_" <> gName
+      corsFile = tmpPath ps </> "cors_" <> gName <> ".conf"
+  withNewTestChat ps "alice" aliceProfile $ \alice ->
+    withNewTestChatOpts ps (relayWebTestOpts "relay.example.com" webDir (Just corsFile)) "bob" bobProfile $ \relay -> do
+      _ <- setupRelay alice relay
+      createChannelWithRelayWeb gName alice relay
+      test alice relay webDir
+
+createChannelWithRelayWeb :: HasCallStack => String -> TestCC -> TestCC -> IO ()
+createChannelWithRelayWeb gName owner relay = do
+  owner ##> ("/public group relays=1 #" <> gName)
+  owner <## ("group #" <> gName <> " is created")
+  owner <## "wait for selected relay(s) to join, then you can invite members via group link"
+  concurrentlyN_
+    [ do
+        owner <## ("#" <> gName <> ": group link relays updated, current relays:")
+        owner <### [EndsWith ": active, web: relay.example.com"]
+        owner <## "group link:"
+        _ <- getTermLine owner
+        pure (),
+      relay <## ("#" <> gName <> ": you joined the group as relay")
+    ]
+
+-- Poll for a JSON preview file written by the worker that satisfies predicate, with timeout
+waitPreviewWith :: HasCallStack => FilePath -> (WebChannelPreview -> Bool) -> IO WebChannelPreview
+waitPreviewWith webDir check = go 50
+  where
+    go :: Int -> IO WebChannelPreview
+    go 0 = error "waitPreview: timed out waiting for matching JSON file"
+    go n = do
+      files <- filter (\f -> takeExtension f == ".json") <$> listDirectory webDir
+      case files of
+        [f] -> do
+          jsonBytes <- LB.readFile (webDir </> f)
+          case J.eitherDecode jsonBytes of
+            Right p | check p -> pure p
+            _ -> threadDelay 100000 >> go (n - 1)
+        _ -> threadDelay 100000 >> go (n - 1)
+
+waitPreview :: HasCallStack => FilePath -> IO WebChannelPreview
+waitPreview webDir = waitPreviewWith webDir (const True)
+
+testWebPreviewRender :: HasCallStack => TestParams -> IO ()
+testWebPreviewRender ps =
+  withWebChannel ps "news" $ \alice relay webDir -> do
+    alice #> "#news hello from the channel"
+    relay <# "#news> hello from the channel"
+    alice #> "#news second message"
+    relay <# "#news> second message"
+    wPreview <- waitPreviewWith webDir (\p -> length (messages p) >= 2)
+    let GroupProfile {displayName = chName} = channel wPreview
+    chName `shouldBe` "news"
+    length (messages wPreview) `shouldBe` 2
+    content (messages wPreview !! 0) `shouldBe` MCText "hello from the channel"
+    content (messages wPreview !! 1) `shouldBe` MCText "second message"
+    length (members wPreview) `shouldSatisfy` (>= 1)
+    all (\m -> ts m > read "2020-01-01 00:00:00 UTC") (messages wPreview) `shouldBe` True
+    jsonFiles <- filter (\f -> takeExtension f == ".json") <$> listDirectory webDir
+    length jsonFiles `shouldBe` 1
+
+testWebPreviewIncremental :: HasCallStack => TestParams -> IO ()
+testWebPreviewIncremental ps =
+  withWebChannel ps "inc" $ \alice relay webDir -> do
+    alice #> "#inc first"
+    relay <# "#inc> first"
+    p1 <- waitPreviewWith webDir (\p -> length (messages p) >= 1)
+    length (messages p1) `shouldBe` 1
+    content (messages p1 !! 0) `shouldBe` MCText "first"
+    alice #> "#inc second"
+    relay <# "#inc> second"
+    alice #> "#inc third"
+    relay <# "#inc> third"
+    p2 <- waitPreviewWith webDir (\p -> length (messages p) >= 3)
+    length (messages p2) `shouldBe` 3
+    content (messages p2 !! 0) `shouldBe` MCText "first"
+    content (messages p2 !! 1) `shouldBe` MCText "second"
+    content (messages p2 !! 2) `shouldBe` MCText "third"
+
+testWebPreviewEditedDeleted :: HasCallStack => TestParams -> IO ()
+testWebPreviewEditedDeleted ps =
+  withWebChannel ps "ed" $ \alice relay webDir -> do
+    alice #> "#ed msg one"
+    relay <# "#ed> msg one"
+    alice #> "#ed msg two"
+    relay <# "#ed> msg two"
+    msgId2 <- lastItemId alice
+    alice #> "#ed msg three"
+    relay <# "#ed> msg three"
+    msgId3 <- lastItemId alice
+    alice ##> ("/_update item #1 " <> msgId2 <> " text msg two edited")
+    alice <# "#ed [edited] msg two edited"
+    relay <# "#ed> [edited] msg two edited"
+    alice #$> ("/_delete item #1 " <> msgId3 <> " broadcast", id, "message marked deleted")
+    relay <# "#ed> [marked deleted] msg three"
+    p <- waitPreviewWith webDir (\p -> length (messages p) == 2 && any edited (messages p))
+    length (messages p) `shouldBe` 2
+    content (messages p !! 0) `shouldBe` MCText "msg one"
+    content (messages p !! 1) `shouldBe` MCText "msg two edited"
+    edited (messages p !! 0) `shouldBe` False
+    edited (messages p !! 1) `shouldBe` True
+
+testWebPreviewReactions :: HasCallStack => TestParams -> IO ()
+testWebPreviewReactions ps =
+  withWebChannel ps "react" $ \alice relay webDir -> do
+    alice #> "#react hello"
+    relay <# "#react> hello"
+    alice ##> "+1 #react hello"
+    alice <## "added 👍"
+    relay <# "#react alice> > hello"
+    relay <## "    + 👍"
+    p <- waitPreviewWith webDir (\p -> not (null (messages p)) && not (null (reactions (head (messages p)))))
+    length (messages p) `shouldBe` 1
+    length (reactions (messages p !! 0)) `shouldSatisfy` (>= 1)
+
+testWebPreviewNonPublic :: HasCallStack => TestParams -> IO ()
+testWebPreviewNonPublic ps = do
+  let webDir = tmpPath ps </> "web_nonpub"
+  withNewTestChat ps "alice" aliceProfile $ \alice ->
+    withNewTestChatOpts ps (relayWebTestOpts "relay.example.com" webDir Nothing) "bob" bobProfile $ \relay -> do
+      _ <- setupRelay alice relay
+      alice ##> "/g private"
+      alice <## "group #private is created"
+      alice <## "to add members use /a private <name> or /create link #private"
+      alice #> "#private hello"
+      threadDelay 2000000
+      files <- filter (\f -> takeExtension f == ".json") <$> listDirectory webDir
+      length files `shouldBe` 0
+
+testWebPreviewMultipleChannels :: HasCallStack => TestParams -> IO ()
+testWebPreviewMultipleChannels ps = do
+  let webDir = tmpPath ps </> "web_multi"
+  withNewTestChat ps "alice" aliceProfile $ \alice ->
+    withNewTestChatOpts ps (relayWebTestOpts "relay.example.com" webDir Nothing) "bob" bobProfile $ \relay -> do
+      _ <- setupRelay alice relay
+      createChannelWithRelayWeb "ch1" alice relay
+      createChannelWithRelayWeb "ch2" alice relay
+      alice #> "#ch1 msg in ch1"
+      relay <# "#ch1> msg in ch1"
+      alice #> "#ch2 msg in ch2"
+      relay <# "#ch2> msg in ch2"
+      threadDelay 2000000
+      files <- filter (\f -> takeExtension f == ".json") <$> listDirectory webDir
+      length files `shouldBe` 2
+
+testWebPreviewChannelDeleted :: HasCallStack => TestParams -> IO ()
+testWebPreviewChannelDeleted ps =
+  withWebChannel ps "del" $ \alice relay webDir -> do
+    alice #> "#del hello"
+    relay <# "#del> hello"
+    _ <- waitPreviewWith webDir (\p -> not (null (messages p)))
+    jsonFiles <- filter (\f -> takeExtension f == ".json") <$> listDirectory webDir
+    length jsonFiles `shouldBe` 1
+    let previewFile = webDir </> head jsonFiles
+    alice ##> "/d #del"
+    alice <## "#del: you deleted the group (signed)"
+    relay <## "#del: alice deleted the group (signed)"
+    relay <## "use /d #del to delete the local copy of the group"
+    waitFileDeleted previewFile 50
+
+testWebPreviewStaleCleanup :: HasCallStack => TestParams -> IO ()
+testWebPreviewStaleCleanup ps = do
+  let webDir = tmpPath ps </> "web_stale_unit"
+      activeFile = "abc123.json"
+      staleFile = "AAAA_stale.json"
+      safeFile = "my.config.json"
+  createDirectoryIfMissing True webDir
+  writeFile (webDir </> activeFile) "{}"
+  writeFile (webDir </> staleFile) "{}"
+  writeFile (webDir </> safeFile) "{}"
+  removeStaleFiles webDir (S.singleton activeFile)
+  doesFileExist (webDir </> staleFile) `shouldReturn` False
+  doesFileExist (webDir </> safeFile) `shouldReturn` True
+  doesFileExist (webDir </> activeFile) `shouldReturn` True
+
+waitFileDeleted :: HasCallStack => FilePath -> Int -> IO ()
+waitFileDeleted _ 0 = error "waitFileDeleted: timed out"
+waitFileDeleted path n =
+  doesFileExist path >>= \case
+    False -> pure ()
+    True -> threadDelay 100000 >> waitFileDeleted path (n - 1)
+
+testWebPreviewCors :: HasCallStack => TestParams -> IO ()
+testWebPreviewCors ps = do
+  let corsFile = tmpPath ps </> "simplex-cors.conf"
+      entries =
+        [ ("abc123.json", CorsAny),
+          ("def456.json", CorsOrigins ["https://owner-site.com"]),
+          ("ghi789.json", CorsOrigins [])
+        ]
+  writeCorsConfig entries corsFile
+  corsContent <- readFile corsFile
+  corsContent `shouldContain` "/channel/abc123.json \"*\""
+  corsContent `shouldContain` "/channel/def456.json \"https://owner-site.com\""
+  corsContent `shouldContain` "# ghi789.json (no origin configured)"
+  corsContent `shouldContain` "Access-Control-Allow-Origin"
+  corsContent `shouldContain` "Access-Control-Allow-Methods"
+
+testExtractOrigin :: HasCallStack => TestParams -> IO ()
+testExtractOrigin _ps = do
+  extractOrigin "https://owner.example.com/channel.html" `shouldBe` Just "https://owner.example.com"
+  extractOrigin "https://owner.example.com/path/to/page?q=1#frag" `shouldBe` Just "https://owner.example.com"
+  extractOrigin "https://owner.example.com:8443/page" `shouldBe` Just "https://owner.example.com:8443"
+  extractOrigin "https://owner.example.com" `shouldBe` Just "https://owner.example.com"
+  extractOrigin "http://localhost:3000/preview" `shouldBe` Just "http://localhost:3000"
+  extractOrigin "ftp://example.com/file" `shouldBe` Nothing
+  extractOrigin "not-a-url" `shouldBe` Nothing
+
 -- Create a public group with relay=1, wait for relay to join
 createChannelWithRelay :: HasCallStack => String -> TestCC -> TestCC -> IO ()
 createChannelWithRelay gName owner relay = do

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/ChatTests/Profiles.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -18,11 +19,18 @@ import Control.Monad.Except
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Text as T
-import Simplex.Chat.Controller (ChatConfig (..), ChatHooks (..), defaultChatHooks)
+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import qualified Data.Map.Strict as M
+import Simplex.Chat.Badges (BadgeCredential, BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeType (..), generateMasterKey, issueBadge, verifyPayment)
+import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatHooks (..), defaultChatHooks, mkStoreCxt)
 import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
 import Simplex.Chat.Protocol (currentChatVersion)
 import Simplex.Chat.Store.Shared (createContact)
 import Simplex.Chat.Types (ConnStatus (..), Profile (..), GroupRejectionReason (..))
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSPublicKey, BBSSecretKey, bbsKeyGen)
 import Simplex.Chat.Types.Shared (GroupMemberRole (..))
 import Simplex.Chat.Types.UITheme
 import Simplex.Messaging.Agent.Env.SQLite
@@ -40,6 +48,13 @@ chatProfileTests = do
     it "update user profile and notify contacts" testUpdateProfile
     it "update user profile with image" testUpdateProfileImage
     it "use multiword profile names" testMultiWordProfileNames
+    it "present supporter badge to contacts" testUserBadgeBroadcast
+    it "supporter badge sent to contact connecting after attach" testUserBadgeOnConnect
+    it "supporter badge sent to member joining via group link" testUserBadgeGroupLink
+    it "expired supporter badge shows as expired" testUserBadgeExpired
+    it "long-expired supporter badge is not presented" testUserBadgeExpiredOld
+    it "incognito connection does not carry supporter badge" testUserBadgeIncognito
+    it "supporter badge sent to contact connecting via address" testUserBadgeContactAddress
   describe "user contact link" $ do
     it "create and connect via contact link" testUserContactLink
     it "retry connecting via contact link" testRetryConnectingViaContactLink
@@ -188,6 +203,210 @@ testUpdateProfile =
             bob <## "use @cat <message> to send messages"
         ]
 
+-- the test issuer key under index 1 in the test config
+testBadgeKeys :: BBSPublicKey -> M.Map Int BBSPublicKey
+testBadgeKeys = M.singleton 1
+
+-- issue a supporter badge credential with the given expiry (test issuer)
+issueTestBadge :: BBSSecretKey -> Maybe UTCTime -> IO BadgeCredential
+issueTestBadge sk badgeExpiry = do
+  drg <- C.newRandom
+  mk <- generateMasterKey drg
+  let info = BadgeInfo {badgeType = BTSupporter, badgeExpiry, badgeExtra = ""}
+  Just vreq <- verifyPayment (BPRedeemCode "TEST") BadgeRequest {masterKey = mk, badgeInfo = info}
+  Right cred <- issueBadge 1 sk vreq
+  pure cred
+
+-- the same single-line JSON `simplex-chat badge sign` prints, pasted into the app
+addTestBadge :: HasCallStack => TestCC -> BadgeCredential -> IO ()
+addTestBadge cc cred = do
+  cc ##> ("/badge add " <> T.unpack (encodeJSON cred))
+  cc <## "ok"
+
+testUserBadgeBroadcast :: HasCallStack => TestParams -> IO ()
+testUserBadgeBroadcast ps = do
+  Right (pk, sk) <- bbsKeyGen
+  testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps
+  where
+    test sk alice bob = do
+      connectUsers alice bob
+      addTestBadge alice =<< issueTestBadge sk Nothing
+      -- own badge is shown (add succeeded)
+      alice ##> "/p"
+      alice <## "user profile: alice (Alice, * supporter)"
+      alice <## "use /p <name> [<bio>] to change it"
+      -- the badge XInfo is delivered in order before this message, so the contact has stored it
+      alice #> "@bob hi"
+      bob <# "alice *> hi"
+
+testUserBadgeOnConnect :: HasCallStack => TestParams -> IO ()
+testUserBadgeOnConnect ps = do
+  Right (pk, sk) <- bbsKeyGen
+  testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps
+  where
+    test sk alice bob = do
+      addTestBadge alice =<< issueTestBadge sk Nothing
+      -- a contact connecting after the badge is attached receives it in the connection handshake
+      alice ##> "/c"
+      inv <- getInvitation alice
+      bob ##> ("/c " <> inv)
+      bob <## "confirmation sent!"
+      concurrently_
+        (bob <## "alice (Alice, * supporter): contact is connected")
+        (alice <## "bob (Bob): contact is connected")
+      bob ##> "/i alice"
+      bob <## "contact ID: 2"
+      bob <## "supporter badge - active"
+      bob <## "no expiry"
+      bob <## "receiving messages via: localhost"
+      bob <## "sending messages via: localhost"
+      bob <## "you've shared main profile with this contact"
+      bob <## "connection not verified, use /code command to see security code"
+      bob <## "quantum resistant end-to-end encryption"
+      bob <## currentChatVRangeInfo
+
+testUserBadgeGroupLink :: HasCallStack => TestParams -> IO ()
+testUserBadgeGroupLink ps = do
+  Right (pk, sk) <- bbsKeyGen
+  testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps
+  where
+    test sk alice bob = do
+      addTestBadge alice =<< issueTestBadge sk Nothing
+      alice ##> "/g team"
+      alice <## "group #team is created"
+      alice <## "to add members use /a team <name> or /create link #team"
+      alice ##> "/create link #team"
+      gLink <- getGroupLink alice "team" GRMember True
+      bob ##> ("/c " <> gLink)
+      bob <## "connection request sent!"
+      alice <## "bob (Bob): accepting request to join group #team..."
+      concurrentlyN_
+        [ alice <## "#team: bob joined the group",
+          do
+            bob <## "#team: joining the group..."
+            bob <## "#team: you joined the group"
+        ]
+      -- the host's profile (x.grp.link.mem) is sent over the same connection as group messages,
+      -- so receiving a message guarantees the badge arrived
+      alice #> "#team hello"
+      bob <# "#team alice> hello"
+      -- no prior contact: the host's badge arrives via the group link handshake
+      bob ##> "/i #team alice"
+      bob <## "group ID: 1"
+      bob <##. "member ID: "
+      bob <## "supporter badge - active"
+      bob <## "no expiry"
+      bob <## "receiving messages via: localhost"
+      bob <## "sending messages via: localhost"
+      bob <## "connection not verified, use /code command to see security code"
+      bob <## currentChatVRangeInfo
+
+testUserBadgeContactAddress :: HasCallStack => TestParams -> IO ()
+testUserBadgeContactAddress ps = do
+  Right (pk, sk) <- bbsKeyGen
+  testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps
+  where
+    test sk alice bob = do
+      addTestBadge alice =<< issueTestBadge sk Nothing
+      alice ##> "/ad"
+      (shortLink, cLink) <- getContactLinks alice True
+      -- the address link data carries the badge proof; the connect plan returns it verified, without crypto
+      bob ##> ("/_connect plan 1 " <> shortLink)
+      bob <## "contact address: ok to connect"
+      sLinkData <- getTermLine bob
+      sLinkData `shouldContain` "\"proof\":"
+      sLinkData `shouldContain` "\"localBadge\":{\"badge\":{\"badgeType\":\"supporter\""
+      sLinkData `shouldContain` "\"status\":\"active\""
+      bob ##> ("/c " <> cLink)
+      alice <#? bob
+      alice ##> "/ac bob"
+      alice <## "bob (Bob): accepting contact request, you can send messages to contact"
+      concurrently_
+        (bob <## "alice (Alice, * supporter): contact is connected")
+        (alice <## "bob (Bob): contact is connected")
+      bob ##> "/i alice"
+      bob <## "contact ID: 2"
+      bob <## "supporter badge - active"
+      bob <## "no expiry"
+      bob <## "receiving messages via: localhost"
+      bob <## "sending messages via: localhost"
+      bob <## "you've shared main profile with this contact"
+      bob <## "connection not verified, use /code command to see security code"
+      bob <## "quantum resistant end-to-end encryption"
+      bob <## currentChatVRangeInfo
+
+testUserBadgeExpired :: HasCallStack => TestParams -> IO ()
+testUserBadgeExpired ps = do
+  Right (pk, sk) <- bbsKeyGen
+  -- expired recently (within 31 days), so the badge is still presented and shown as expired
+  expiry <- addUTCTime (-2 * nominalDay) <$> getCurrentTime
+  testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk expiry) ps
+  where
+    test sk expiry alice bob = do
+      addTestBadge alice =<< issueTestBadge sk (Just expiry)
+      -- expired badge: no star
+      alice ##> "/p"
+      alice <## "user profile: alice (Alice)"
+      alice <## "use /p <name> [<bio>] to change it"
+      connectUsers alice bob
+      bob ##> "/i alice"
+      bob <## "contact ID: 2"
+      bob <## "supporter badge - expired"
+      bob <## ("expires " <> formatTime defaultTimeLocale "%Y-%m-%d" expiry)
+      bob <## "receiving messages via: localhost"
+      bob <## "sending messages via: localhost"
+      bob <## "you've shared main profile with this contact"
+      bob <## "connection not verified, use /code command to see security code"
+      bob <## "quantum resistant end-to-end encryption"
+      bob <## currentChatVRangeInfo
+
+testUserBadgeExpiredOld :: HasCallStack => TestParams -> IO ()
+testUserBadgeExpiredOld ps = do
+  Right (pk, sk) <- bbsKeyGen
+  testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps
+  where
+    test sk alice bob = do
+      addTestBadge alice =<< issueTestBadge sk (Just pastDate)
+      -- a badge that expired over a month ago is not presented to contacts at all
+      connectUsers alice bob
+      bob ##> "/i alice"
+      bob <## "contact ID: 2"
+      bob <## "receiving messages via: localhost"
+      bob <## "sending messages via: localhost"
+      bob <## "you've shared main profile with this contact"
+      bob <## "connection not verified, use /code command to see security code"
+      bob <## "quantum resistant end-to-end encryption"
+      bob <## currentChatVRangeInfo
+    pastDate = posixSecondsToUTCTime 1577836800 -- 2020-01-01
+
+testUserBadgeIncognito :: HasCallStack => TestParams -> IO ()
+testUserBadgeIncognito ps = do
+  Right (pk, sk) <- bbsKeyGen
+  testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps
+  where
+    test sk alice bob = do
+      addTestBadge alice =<< issueTestBadge sk Nothing
+      -- an incognito identity must not carry the badge
+      bob ##> "/connect"
+      inv <- getInvitation bob
+      alice ##> ("/connect incognito " <> inv)
+      alice <## "confirmation sent!"
+      aliceIncognito <- getTermLine alice
+      concurrentlyN_
+        [ bob <## (aliceIncognito <> ": contact is connected"),
+          do
+            alice <## ("bob (Bob): contact is connected, your incognito profile for this contact is " <> aliceIncognito)
+            alice <## "use /i bob to print out this incognito profile again"
+        ]
+      bob ##> ("/i " <> aliceIncognito)
+      bob <## "contact ID: 2"
+      bob <## "receiving messages via: localhost"
+      bob <## "sending messages via: localhost"
+      bob <## "you've shared main profile with this contact"
+      bob <## "connection not verified, use /code command to see security code"
+      bob <## "quantum resistant end-to-end encryption"
+      bob <## currentChatVRangeInfo
+
 testUpdateProfileImage :: HasCallStack => TestParams -> IO ()
 testUpdateProfileImage =
   testChat2 aliceProfile bobProfile $
@@ -282,7 +501,7 @@ testMultiWordProfileNames =
     aliceProfile' = baseProfile {displayName = "Alice Jones"}
     bobProfile' = baseProfile {displayName = "Bob James"}
     cathProfile' = baseProfile {displayName = "Cath Johnson"}
-    baseProfile = Profile {displayName = "", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, simplexName = Nothing, peerType = Nothing, preferences = defaultPrefs}
+    baseProfile = Profile {displayName = "", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs, badge = Nothing, simplexName = Nothing}
 
 testUserContactLink :: HasCallStack => TestParams -> IO ()
 testUserContactLink =
@@ -1190,13 +1409,13 @@ testPlanAddressContactViaAddress =
         Left _ -> error "error parsing contact link"
         Right cReq -> do
           let profile = aliceProfile {contactLink = Just cReq}
-          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile
+          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile
           bob @@@ [("@alice", "")]
 
           bob ##> "/delete @alice"
           bob <## "alice: contact is deleted"
 
-          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile
+          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile
           bob @@@ [("@alice", "")]
 
           bob ##> ("/_connect plan 1 " <> cLink)
@@ -1211,7 +1430,7 @@ testPlanAddressContactViaAddress =
           alice ##> "/delete @bob"
           alice <## "bob: contact is deleted"
 
-          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile
+          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile
           bob @@@ [("@alice", "")]
 
           -- GUI api
@@ -1252,13 +1471,13 @@ testPlanAddressContactViaShortAddress =
         Left _ -> error "error parsing contact link"
         Right shortLink -> do
           let profile = aliceProfile {contactLink = Just shortLink}
-          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile
+          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile
           bob @@@ [("@alice", "")]
 
           bob ##> "/delete @alice"
           bob <## "alice: contact is deleted"
 
-          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile
+          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile
           bob @@@ [("@alice", "")]
 
           bob ##> ("/_connect plan 1 " <> sLink)
@@ -1273,7 +1492,7 @@ testPlanAddressContactViaShortAddress =
           alice ##> "/delete @bob"
           alice <## "bob: contact is deleted"
 
-          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db user profile
+          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> let TestCC {chatController = ChatController {config}} = bob in runExceptT $ createContact db (mkStoreCxt config) user profile
           bob @@@ [("@alice", "")]
 
           -- GUI api
@@ -2687,6 +2906,12 @@ testGroupPrefsSimplexLinksForRole = testChat3 aliceProfile bobProfile cathProfil
     bob <## "bad chat command: feature not allowed SimpleX links"
     bob ##> ("/_send #1 json [{\"msgContent\": {\"type\": \"text\", \"text\": \"" <> inv <> "\\ntest\"}}]")
     bob <## "bad chat command: feature not allowed SimpleX links"
+    -- a link split with a space or a newline is still blocked
+    let (lnk1, lnk2) = splitAt 12 inv
+    bob ##> ("#team \"" <> lnk1 <> " " <> lnk2 <> "\"")
+    bob <## "bad chat command: feature not allowed SimpleX links"
+    bob ##> ("#team \"" <> lnk1 <> "\\n" <> lnk2 <> "\"")
+    bob <## "bad chat command: feature not allowed SimpleX links"
     (alice </)
     (cath </)
     bob `send` ("@alice \"" <> inv <> "\\ntest\"")

tests/ChatTests/Utils.hs

@@ -88,7 +88,7 @@ serviceProfile :: Profile
 serviceProfile = mkProfile "service_user" "Service user" Nothing
 
 mkProfile :: T.Text -> T.Text -> Maybe ImageData -> Profile
-mkProfile displayName descr image = Profile {displayName, fullName = "", shortDescr = Just descr, image, contactLink = Nothing, simplexName = Nothing, peerType = Nothing, preferences = defaultPrefs}
+mkProfile displayName descr image = Profile {displayName, fullName = "", shortDescr = Just descr, image, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs, badge = Nothing, simplexName = Nothing}
 
 it :: HasCallStack => String -> (ps -> Expectation) -> SpecWith (Arg (ps -> Expectation))
 it name test =

tests/MarkdownTests.hs

@@ -25,6 +25,7 @@ markdownTests = do
   textColor
   textWithUri
   textWithHyperlink
+  obfuscatedSimplexLinks
   textWithEmail
   textWithPhone
   textWithMentions
@@ -284,6 +285,24 @@ textWithHyperlink = describe "text with HyperLink without link text" do
     "[click here](example.com)" <==> "[click here](example.com)"
     "[click here](https://example.com )" <==> "[click here](https://example.com )"
 
+obfuscatedSimplexLinks :: Spec
+obfuscatedSimplexLinks = describe "SimpleX links obfuscated with whitespace" do
+  let addr = "https://smp6.simplex.im/a#lrdvu2d8A1GumSmoKb2krQmtKhWXq-tyGpHuM7aMwsw"
+      inv = "/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+  let spaced s = T.replace "://" ":// " s -- insert a space right after the scheme
+  it "detects links split with spaces or newlines" do
+    hasObfuscatedSimplexLink addr `shouldBe` True
+    hasObfuscatedSimplexLink (spaced addr) `shouldBe` True
+    hasObfuscatedSimplexLink (T.intercalate "\n" $ T.chunksOf 8 addr) `shouldBe` True
+    hasObfuscatedSimplexLink ("connect with me: " <> spaced addr) `shouldBe` True
+    hasObfuscatedSimplexLink (T.intercalate " " $ T.chunksOf 8 $ "https://simplex.chat" <> inv) `shouldBe` True
+  it "detects a split link followed by other text" do
+    hasObfuscatedSimplexLink (spaced addr <> "\nplease connect") `shouldBe` True
+  it "ignores text without a SimpleX link" do
+    hasObfuscatedSimplexLink "" `shouldBe` False
+    hasObfuscatedSimplexLink "hello there, this is a normal message" `shouldBe` False
+    hasObfuscatedSimplexLink "see https://example.com/page?ref=123 for details" `shouldBe` False
+
 email :: Text -> Markdown
 email = Markdown $ Just Email
 

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

tests/MobileTests.hs

@@ -33,8 +33,10 @@ import Foreign.Storable (peek)
 import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding)
 import JSONFixtures
 import Simplex.Chat
+import Simplex.Chat.Badges (BadgeInfo (..), BadgeRequest (..), BadgeType (..), generateMasterKey, verifyCredential)
 import Simplex.Chat.Controller (ChatController (..), ChatDatabase (..))
 import Simplex.Chat.Mobile hiding (error)
+import Simplex.Chat.Mobile.Badges hiding (error)
 import Simplex.Chat.Mobile.File
 import Simplex.Chat.Mobile.Shared
 import Simplex.Chat.Mobile.WebRTC
@@ -82,6 +84,8 @@ mobileTests = do
     describe "Parsers" $ do
       it "should parse server address" testChatParseServer
       it "should parse and sanitize URI" testChatParseUri
+    describe "Badges" $ do
+      it "should generate key and issue badge via C API, verify credential" testBadgeKeygenIssueCApi
 
 noActiveUser :: LB.ByteString
 noActiveUser =
@@ -310,6 +314,25 @@ testChatParseUri :: TestParams -> IO ()
 testChatParseUri _ = do
   pure ()
 
+-- Generate a server keypair and issue a badge credential via the C FFI,
+-- constructing the request from the typed records, then verify the issued
+-- credential's BBS signature on the Haskell side.
+testBadgeKeygenIssueCApi :: TestParams -> IO ()
+testBadgeKeygenIssueCApi _ = do
+  g <- C.newRandom
+  IssuerKeyPair {publicKey, secretKey} <- ffiResult =<< (peekCString =<< cChatBadgeKeygen)
+  mk <- generateMasterKey g
+  let req = BadgeIssueReq {badgeKeyIdx = 1, secretKey, request = BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Nothing, badgeExtra = ""}}}
+  cred <- ffiResult =<< (peekCString =<< cChatBadgeIssue =<< newCString (LB.unpack (J.encode req)))
+  verifyCredential publicKey cred `shouldReturn` True
+
+-- Decode an FFI `BadgeResult` envelope, returning the result or failing on error.
+ffiResult :: FromJSON r => String -> IO r
+ffiResult s = case J.eitherDecode (LB.pack s) of
+  Right (BadgeResult r) -> pure r
+  Right (BadgeError e) -> error $ "badge FFI error: " <> show e
+  Left e -> error $ "badge FFI decode failed: " <> e <> " in " <> s
+
 jDecode :: FromJSON a => String -> IO (Maybe a)
 jDecode = pure . J.decode . LB.pack
 

tests/ProtocolTests.hs

@@ -9,7 +9,7 @@ module ProtocolTests where
 import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
-import Simplex.Chat.Library.Internal (redactedMemberProfile, userProfileInGroup')
+import Simplex.Chat.Library.Internal (decodeLinkUserData, encodeShortLinkData, redactedMemberProfile, userProfileInGroup')
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
@@ -26,6 +26,7 @@ protocolTests :: Spec
 protocolTests = do
   decodeChatMessageTest
   outgoingProfileSimplexNameTest
+  shortLinkDataTests
 
 srv :: SMPServer
 srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251")
@@ -107,7 +108,7 @@ testGroupPreferences :: Maybe GroupPreferences
 testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, reactions = Just ReactionsGroupPreference {enable = FEOn}, voice = Just VoiceGroupPreference {enable = FEOn, role = Nothing}, files = Nothing, fullDelete = Nothing, simplexLinks = Nothing, history = Nothing, reports = Nothing, support = Nothing, sessions = Nothing, comments = Nothing, commands = Nothing}
 
 testProfile :: Profile
-testProfile = Profile {displayName = "alice", fullName = "Alice", shortDescr = Nothing, image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), peerType = Nothing, contactLink = Nothing, simplexName = Nothing, preferences = testChatPreferences}
+testProfile = Profile {displayName = "alice", fullName = "Alice", shortDescr = Nothing, image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), peerType = Nothing, contactLink = Nothing, preferences = testChatPreferences, badge = Nothing, simplexName = Nothing}
 
 testGroupProfile :: GroupProfile
 testGroupProfile = GroupProfile {displayName = "team", fullName = "Team", description = Nothing, shortDescr = Nothing, image = Nothing, publicGroup = Nothing, simplexName = Nothing, groupPreferences = testGroupPreferences, memberAdmission = Nothing}
@@ -118,6 +119,25 @@ testSimplexName = SimplexNameInfo NTContact (SimplexNameDomain TLDSimplex "alice
 testGroupSimplexName :: SimplexNameInfo
 testGroupSimplexName = SimplexNameInfo NTPublicGroup (SimplexNameDomain TLDSimplex "team" [])
 
+shortLinkDataTests :: Spec
+shortLinkDataTests = describe "Short link data encoding/decoding" $ do
+  it "decodes compressed short-link user data below the decompressed size limit" $ do
+    let value = replicate 11000 'a'
+    decodeLinkUserData (linkData value) `shouldReturn` Just value
+  it "rejects compressed short-link user data above the decompressed size limit" $ do
+    let value = replicate (maxDecompressedMsgLength + 1) 'a'
+    decodeLinkUserData (linkData value) `shouldReturn` (Nothing :: Maybe String)
+  where
+    linkData value =
+      ContactLinkData
+        supportedSMPAgentVRange
+        UserContactData
+          { direct = True,
+            owners = [],
+            relays = [],
+            userData = encodeShortLinkData (value :: String)
+          }
+
 decodeChatMessageTest :: Spec
 decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
   it "x.msg.new simple text" $
@@ -142,7 +162,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
     "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
       ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (mcSimple (MCText "hello")))
   it "x.msg.new chat message with chat version range" $
-    "{\"v\":\"1-17\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
+    "{\"v\":\"1-19\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
       ##==## ChatMessage supportedChatVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (mcSimple (MCText "hello")))
   it "x.msg.new quote" $
     "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}}}}"
@@ -227,10 +247,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
       #==# XInfo testProfile
   it "x.info with empty full name" $
     "{\"v\":\"1\",\"event\":\"x.info\",\"params\":{\"profile\":{\"fullName\":\"\",\"displayName\":\"alice\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}"
-      #==# XInfo Profile {displayName = "alice", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, simplexName = Nothing, peerType = Nothing, preferences = testChatPreferences}
+      #==# XInfo Profile {displayName = "alice", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = testChatPreferences, badge = Nothing, simplexName = Nothing}
   it "x.info with simplexName" $
     "{\"v\":\"1\",\"event\":\"x.info\",\"params\":{\"profile\":{\"fullName\":\"\",\"displayName\":\"alice\",\"simplexName\":{\"nameType\":\"contact\",\"nameDomain\":{\"nameTLD\":\"simplex\",\"domain\":\"alice\",\"subDomain\":[]}},\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}"
-      #==# XInfo Profile {displayName = "alice", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, simplexName = Just testSimplexName, peerType = Nothing, preferences = testChatPreferences}
+      #==# XInfo Profile {displayName = "alice", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = testChatPreferences, badge = Nothing, simplexName = Just testSimplexName}
   it "x.contact with xContactId" $
     "{\"v\":\"1\",\"event\":\"x.contact\",\"params\":{\"contactReqId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}"
       #==# XContact testProfile (Just $ XContactId "\1\2\3\4") Nothing Nothing
@@ -259,13 +279,13 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
     "{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
       #==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile, memberKey = Nothing} Nothing
   it "x.grp.mem.new with member chat version range" $
-    "{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-17\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
+    "{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-19\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
       #==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile, memberKey = Nothing} Nothing
   it "x.grp.mem.intro" $
     "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
       #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile, memberKey = Nothing} Nothing
   it "x.grp.mem.intro with member chat version range" $
-    "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-17\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
+    "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-19\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
       #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile, memberKey = Nothing} Nothing
   it "x.grp.mem.intro with member restrictions" $
     "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberRestrictions\":{\"restriction\":\"blocked\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
@@ -280,7 +300,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
     "{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"directConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
       #==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile, memberKey = Nothing} IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq}
   it "x.grp.mem.fwd with member chat version range and w/t directConnReq" $
-    "{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-17\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
+    "{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-19\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}"
       #==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile, memberKey = Nothing} IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing}
   it "x.grp.mem.info" $
     "{\"v\":\"1\",\"event\":\"x.grp.mem.info\",\"params\":{\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}"
@@ -293,7 +313,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
       #==# XGrpMemConAll (MemberId "\1\2\3\4")
   it "x.grp.mem.del" $
     "{\"v\":\"1\",\"event\":\"x.grp.mem.del\",\"params\":{\"memberId\":\"AQIDBA==\"}}"
-      #==# XGrpMemDel (MemberId "\1\2\3\4") False
+      #==# XGrpMemDel (MemberId "\1\2\3\4") False Nothing
   it "x.grp.leave" $
     "{\"v\":\"1\",\"event\":\"x.grp.leave\",\"params\":{}}"
       ==# XGrpLeave
@@ -340,10 +360,11 @@ testUser sn =
             shortDescr = Nothing,
             image = Nothing,
             contactLink = Nothing,
-            simplexName = sn,
             preferences = Nothing,
             peerType = Nothing,
-            localAlias = ""
+            localBadge = Nothing,
+            localAlias = "",
+            simplexName = sn
           },
       fullPreferences = fullPreferences' Nothing,
       activeUser = True,
@@ -368,13 +389,13 @@ outgoingProfileSimplexNameTest = describe "outgoing Profile carries User.profile
     let Profile {simplexName = sn} = userProfileDirect (testUser Nothing) Nothing Nothing True
     sn `shouldBe` Nothing
   it "userProfileDirect with incognito profile suppresses simplexName" $ do
-    let incognito = Profile {displayName = "anon", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, simplexName = Nothing, peerType = Nothing, preferences = Nothing}
+    let incognito = Profile {displayName = "anon", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, simplexName = Nothing}
         Profile {simplexName = sn} = userProfileDirect (testUser (Just testSimplexName)) (Just incognito) Nothing True
     sn `shouldBe` Nothing
   it "userProfileInGroup' passes simplexName through" $ do
     let Profile {simplexName = sn} = userProfileInGroup' (testUser (Just testSimplexName)) True Nothing
     sn `shouldBe` Just testSimplexName
   it "redactedMemberProfile preserves simplexName" $ do
-    let p0 = Profile {displayName = "alice", fullName = "Alice", shortDescr = Nothing, image = Nothing, contactLink = Nothing, simplexName = Just testSimplexName, peerType = Nothing, preferences = Nothing}
+    let p0 = Profile {displayName = "alice", fullName = "Alice", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, simplexName = Just testSimplexName}
         Profile {simplexName = sn} = redactedMemberProfile True p0
     sn `shouldBe` Just testSimplexName

tests/Test.hs

@@ -11,6 +11,7 @@ import ChatTests.DBUtils
 import ChatTests.Utils (xdescribe'')
 import Control.Logger.Simple
 import Data.Time.Clock.System
+import BadgeTests
 import JSONTests
 import MarkdownTests
 import MemberRelationsTests
@@ -61,6 +62,7 @@ main = do
 #endif
       around tmpBracket $ describe "WebRTC encryption" webRTCTests
 #endif
+      describe "Supporter badges" badgeTests
       describe "SimpleX chat markdown" markdownTests
       describe "JSON Tests" jsonTests
       describe "Member relations" memberRelationsTests