mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-09-17 05:55:01 +00:00
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.
This commit is contained in:
shum
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+741
-87
File diff suppressed because it is too large
Load Diff
+233
-8
@@ -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\"")
|
||||
|
||||
@@ -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 =
|
||||
|
||||
Reference in New Issue
Block a user