Merge remote-tracking branch 'origin/master' into ab/wallet

tests/BadgeTests.hs

@@ -27,14 +27,16 @@ import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Code
 import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service
+import Simplex.Chat.Badges.Types (BadgeIssueFailure (..))
 import Simplex.Chat (defaultChatConfig)
 import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..), badgeRetryInterval, chatErrorAgent)
-import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeRetryAfter, badgeStalledInterval)
+import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval)
 import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), AgentServiceError (..), SMPAgentError (..))
 import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay)
 import Simplex.Messaging.Crypto.BBS
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BrokerErrorType (..), NetworkError (..))
+import Simplex.Messaging.Protocol (BrokerErrorType (..), ErrorType (AUTH), NetworkError (..))
+import Simplex.Messaging.Util (tshow)
 import Simplex.Messaging.Version.Internal (Version (..))
 import Test.Hspec
 
@@ -83,6 +85,11 @@ badgeTests = do
     it "backs off to the cap" testRetryBackoff
     it "floors the wait a service asks for, and honours anything above it" testServiceRetryFloor
     it "sends retryAfter with the transient service codes and no other" testServiceRetryAfter
+  describe "recording a failed renewal" $ do
+    it "records the agent error a request failed with, not the chat error around it" testIssueFailureClassification
+    it "waits for the credential to lapse on internal, as on a refusal the service marks transient" testServiceErrorTransience
+    it "stores every failure so that it reads back, whatever the service called its code" testIssueFailureEncoding
+    it "bounds and strips a code this version does not know" testServiceErrorCodeBounded
   describe "service protocol JSON" $ do
     it "redeemBadgeCode request matches the schema" testRedeemRequestJSON
     it "badgeCredential response matches the schema" testCredentialResponseJSON
@@ -677,6 +684,66 @@ testServiceRetryAfter = do
     (\code -> badgeErrorRetryAfter code `shouldBe` Nothing)
     [BSEBadRequest, BSEUnsupportedVersion, BSEUnknownPurchaseKey, BSECodeInvalid, BSECodeUsed, BSECodeExpired, BSEUnknown "future_code"]
 
+-- The app shows the recorded failure in a sentence, so an agent error is stored as the agent
+-- error and not as the chat error wrapping it, whether or not it can clear on its own.
+testIssueFailureClassification :: IO ()
+testIssueFailureClassification = do
+  let failureFor = badgeIssueFailure . chatErrorAgent
+      timeout = BROKER "localhost" TIMEOUT
+      auth = SMP "localhost" AUTH
+  failureFor (AGENT (A_SERVICE ASETimeout)) `shouldBe` BIFServiceTimeout
+  failureFor timeout `shouldBe` BIFNetwork {agentError = tshow timeout}
+  failureFor auth `shouldBe` BIFUnexpected {message = tshow auth}
+  badgeIssueFailure (ChatError (CECommandError "unexpected badge service response")) `shouldBe` BIFUnexpected {message = "unexpected badge service response"}
+
+-- A refusal the service marks transient is not worth a word before the credential lapses. Internal
+-- comes without retryAfter so that a failing service is not pressed, not because the fault is
+-- final, so it waits the same way; any other refusal is told at once.
+testServiceErrorTransience :: IO ()
+testServiceErrorTransience = do
+  badgeFailureTransient BIFServiceError {code = BSERateLimited, retryable = True} `shouldBe` True
+  badgeFailureTransient BIFServiceError {code = BSEInternal, retryable = False} `shouldBe` True
+  badgeFailureTransient BIFServiceError {code = BSEUnknownPurchaseKey, retryable = False} `shouldBe` False
+  badgeFailureTransient BIFServiceError {code = BSEUnknown "future_code", retryable = False} `shouldBe` False
+  badgeFailureTransient BIFServiceError {code = BSEUnknown "future_code", retryable = True} `shouldBe` True
+
+-- The failure is stored as text and read back by getBadgePurchase, so every value this version
+-- writes must read back as itself, and any other value must still read: a row it cannot parse
+-- would otherwise fail every read of the purchase.
+testIssueFailureEncoding :: IO ()
+testIssueFailureEncoding = do
+  mapM_
+    (\f -> strDecode (strEncode f) `shouldBe` Right f)
+    [ BIFServiceError {code = BSEUnknownPurchaseKey, retryable = False},
+      BIFServiceError {code = BSERateLimited, retryable = True},
+      BIFServiceError {code = BSEUnknown "future_code", retryable = True},
+      BIFServiceError {code = BSEUnknown "code with spaces", retryable = False},
+      BIFServiceError {code = BSEUnknown "", retryable = False},
+      BIFServiceTimeout,
+      BIFNetwork {agentError = "BROKER \"smp://x\" NETWORK"},
+      BIFInvalidCredential,
+      BIFUnexpected {message = "unexpected badge service response"},
+      BIFUnexpected {message = "several words and : punctuation"}
+    ]
+  -- the row the CLI prints, and what a reader of the database sees
+  strEncode BIFServiceError {code = BSECodeUsed, retryable = False} `shouldBe` "service_error final code_used"
+  strEncode BIFServiceError {code = BSERateLimited, retryable = True} `shouldBe` "service_error retry rate_limited"
+  strEncode BIFServiceTimeout `shouldBe` "service_timeout"
+  -- a row a later version wrote, or one edited by hand, still reads - as the text it holds
+  strDecode "future_failure with text" `shouldBe` Right BIFUnexpected {message = "future_failure with text"}
+  strDecode "service_timeout trailing" `shouldBe` Right BIFUnexpected {message = "service_timeout trailing"}
+  strDecode "service_error maybe code_used" `shouldBe` Right BIFUnexpected {message = "service_error maybe code_used"}
+
+-- The text of a code this version does not know is chosen by the service, and the app shows it in
+-- a sentence of its own - so it is bounded and stripped of anything but a code before it is stored.
+testServiceErrorCodeBounded :: IO ()
+testServiceErrorCodeBounded = do
+  badgeServiceErrorText BSECodeUsed `shouldBe` "code_used"
+  badgeServiceErrorText (BSEUnknown "future_code") `shouldBe` "future_code"
+  badgeServiceErrorText (BSEUnknown "two words") `shouldBe` "twowords"
+  badgeServiceErrorText (BSEUnknown (T.replicate 100 "a")) `shouldBe` T.replicate 32 "a"
+  badgeServiceErrorText (BSEUnknown "Visit evil.example.com!") `shouldBe` "isitevilexamplecom"
+
 -- The client replicates entry_credit_type / entry_debit_type verbatim, so a stored tag that
 -- disagreed with the wire tag would put a different row on each side.
 testEntryTypeColumns :: IO ()

tests/Bots/BadgeServiceTests.hs

@@ -20,6 +20,7 @@ import Control.Concurrent.STM (atomically, readTMVar)
 import Control.Monad (forM_, void, when)
 import Control.Exception (finally)
 import qualified Data.Aeson as J
+import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (toLower)
 import Data.Either (isLeft, isRight)
@@ -41,8 +42,10 @@ import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatRespon
 import Simplex.Chat.Core (sendChatCmdStr)
 import Simplex.Chat.Options (CoreChatOpts (..))
 import Simplex.Chat.Options.DB
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
+import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..))
 import Simplex.Messaging.Agent.Store.Common (withTransaction)
-import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
+import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Chat.Types (ChatPeerType (..), Profile (..))
 import qualified Simplex.Messaging.Crypto as C
@@ -83,6 +86,11 @@ badgeServiceTests = do
   it "should retire when entitlement ends, not when the credential expires" testRetiresWhenEntitlementEnds
   it "should alert that support ended, survive a restart, and go silent once acknowledged" testEndedAlert
   it "should raise a snoozed alert once more when the snooze lapses" testSnoozedAlertReturns
+  it "should alert that renewal failed when the service refuses it" testIssueFailedAlert
+  it "should wait for the shown credential to lapse before alerting on a failure that can clear" testIssueFailedWaitsForExpiry
+  it "should silence an acknowledged run of failures, and alert again on the next run" testIssueFailedAckAndNewRun
+  it "should record no failure when the service issues nothing because the months ran out" testNoCredentialMonthsRanOut
+  it "should record a failure when the service issues nothing though months are left" testNoCredentialMonthsLeft
   it "should renew a badge on a profile that is not active, without switching to it" testRenewalKeepsActiveProfile
   it "should broadcast the current profile when a renewal presents a badge" testRenewalKeepsProfileEdits
   it "should present the month already issued when a previous pass did not" testPresentationCatchesUp
@@ -143,6 +151,11 @@ data BadgeServiceEnv = BadgeServiceEnv
     bsController :: ChatController
   }
 
+-- | Stop the service for good: requests sent after it go unanswered until they time out. Stopping
+-- chat unsubscribes its queues, where killing the thread could still let a request arrive mid-teardown.
+stopBadgeService :: ChatController -> IO ()
+stopBadgeService cc = void $ sendChatCmdStr cc "/_stop"
+
 -- | Start the badge service on a fresh issuer key, and hand the test body what depends on it:
 -- the client config trusting that key and addressing the service, the address, and the controller.
 withBadgeService :: HasCallStack => TestParams -> (ChatConfig -> String -> ChatController -> IO ()) -> IO ()
@@ -931,6 +944,236 @@ testEndedAlert ps =
       alice <## "user profile: alice (Alice)"
       alice <## "use /p <name> [<bio>] to change it"
 
+-- A refusal the service will not take back is worth telling the user at once: the badge is still
+-- worn and will start showing as expired.
+testIssueFailedAlert :: HasCallStack => TestParams -> IO ()
+testIssueFailedAlert ps =
+  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueCode cc BTSupporter 3
+      redeemFirstBadge alice code
+      rows <- ledgerRows (chatController alice) "badge_ledger"
+      -- the service no longer knows this purchase, so it refuses with no retryAfter: terminal
+      setServicePurchaseKey cc "not the purchase key"
+      setClockAt bsClock $ fst $ renewalMoments rows
+      alice ##> "/_app activate"
+      alice <## "ok"
+      alice <## badgeServiceRefused
+      alice <##. "badge alert: issue_failed "
+      -- the state reports the failure, when the next attempt is due, and the alert it raised
+      alice <##. "1: supporter"
+      alice <##. "renewal failing since "
+      alice <##. "badge alert: issue_failed "
+      issueErrorRow (chatController alice) >>= \(_, reason) ->
+        reason `shouldBe` Just "service_error final unknown_purchase_key"
+
+-- A failure that can clear on its own is not worth a word while contacts still see the badge as
+-- valid: neither the alert nor the state shows it until the shown credential lapses, which is when
+-- they stop. It is recorded from the first attempt, so the run's start is not lost.
+testIssueFailedWaitsForExpiry :: HasCallStack => TestParams -> IO ()
+testIssueFailedWaitsForExpiry ps =
+  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> do
+    -- the redemption runs against the service, so it keeps the ordinary request timeout
+    (requestAt, presentAt) <- withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueCode cc BTSupporter 3
+      redeemFirstBadge alice code
+      renewalMoments <$> ledgerRows (chatController alice) "badge_ledger"
+    stopBadgeService cc
+    let cfg = failingServiceCfg bsClientCfg
+    -- the request goes unanswered and times out, which is a failure that can clear on its own
+    setClockAt bsClock requestAt
+    failedSince <- withTestChatCfg ps cfg "alice" $ \alice -> do
+      alice <##. "1: supporter"
+      -- the state carries no failure and no alert: /p prints only its own output
+      alice ##> "/p"
+      alice <## "user profile: alice (Alice, * supporter)"
+      alice <## "use /p <name> [<bio>] to change it"
+      (since, reason) <- issueErrorRow (chatController alice)
+      reason `shouldBe` Just "service_timeout"
+      pure since
+    -- the shown credential lapses: from here contacts see the badge as expired, and it is worth a word
+    setClockAt bsClock presentAt
+    withTestChatCfg ps cfg "alice" $ \alice -> do
+      alice <##. "1: supporter"
+      alice <##. "renewal failing since "
+      alice <##. "badge alert: issue_failed "
+      -- still the one run: the alert's episode is when it started, not this pass
+      issueErrorRow (chatController alice) >>= \(since, _) -> since `shouldBe` failedSince
+
+-- Acknowledging answers the run that is failing, not the failure: the error stays on the badge
+-- screen while the alert goes quiet, and a later run raises it again under a new episode.
+testIssueFailedAckAndNewRun :: HasCallStack => TestParams -> IO ()
+testIssueFailedAckAndNewRun ps =
+  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueCode cc BTSupporter 3
+      redeemFirstBadge alice code
+      rows <- ledgerRows (chatController alice) "badge_ledger"
+      purchaseKey <- servicePurchaseKey cc
+      setServicePurchaseKey cc "not the purchase key"
+      let (requestAt, presentAt) = renewalMoments rows
+      setClockAt bsClock requestAt
+      alice ##> "/_app activate"
+      alice <## "ok"
+      alice <## badgeServiceRefused
+      alice <##. "badge alert: issue_failed "
+      alice <##. "1: supporter"
+      alice <##. "renewal failing since "
+      alice <##. "badge alert: issue_failed "
+      episode <- episodeOf . fst <$> issueErrorRow (chatController alice)
+      alice ##> ("/_badge ack 1 1 issue_failed off " <> T.unpack episode)
+      -- the state still carries the error, and no alert with it
+      alice <##. "1: supporter"
+      alice <##. "renewal failing since "
+      -- the ack signalled the worker, and the pass it ran failed again and raised nothing
+      alice <## badgeServiceRefused
+      alice <##. "1: supporter"
+      alice <##. "renewal failing since "
+      ackedEpisode (chatController alice) `shouldReturn` (Just "issue_failed", Just episode)
+      -- the service is back: the month it owes is issued, which ends the run
+      setServicePurchaseKey cc purchaseKey
+      alice ##> "/_app activate"
+      alice <## "ok"
+      renewed <- waitLedgerRows (chatController alice) 3
+      alice <##. "1: supporter"
+      waitIssueErrorCleared (chatController alice)
+      -- the month issued is presented when the one on the profile lapses, and only then is the
+      -- next renewal asked for - so the run that fails next is a new one
+      setClockAt bsClock presentAt
+      alice ##> "/_app activate"
+      alice <## "ok"
+      waitShownIssued (chatController alice)
+      setServicePurchaseKey cc "not the purchase key"
+      setClockAt bsClock $ fst $ renewalMoments renewed
+      alice ##> "/_app activate"
+      alice <## "ok"
+      alice <## badgeServiceRefused
+      alice <##. "badge alert: issue_failed "
+      alice <##. "1: supporter"
+      alice <##. "renewal failing since "
+      alice <##. "badge alert: issue_failed "
+      -- a new run, so acknowledging the first one does not silence this one
+      newEpisode <- episodeOf . fst <$> issueErrorRow (chatController alice)
+      newEpisode `shouldNotBe` episode
+
+-- The service issues nothing when the months it holds have run out - here through a debit the
+-- client had not seen. That is support ending, not a failed renewal: the statement brings the
+-- balance to nothing and the usual alert follows, where a recorded failure would name a
+-- credential that was never issued.
+testNoCredentialMonthsRanOut :: HasCallStack => TestParams -> IO ()
+testNoCredentialMonthsRanOut ps =
+  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueCode cc BTSupporter 3
+      redeemFirstBadge alice code
+      rows <- ledgerRows (chatController alice) "badge_ledger"
+      insertServiceSupportDebit cc
+      -- at the credential's expiry the issued period has ended, so the service holds no current credential either
+      setClockAt bsClock $ snd $ renewalMoments rows
+      alice ##> "/_app activate"
+      alice <## "ok"
+      alice <##. "badge alert: support_ended "
+      issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing)
+      -- the debit is the client's now, and the next pass retires the badge on it
+      rows' <- ledgerRows (chatController alice) "badge_ledger"
+      map (\(_, ch, m, _, _, t) -> (ch, m, t)) rows' `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-2, 0, Just "support")]
+      alice ##> "/_app activate"
+      alice <## "ok"
+      alice <##. "1: supporter"
+      alice <##. "badge alert: support_ended "
+      waitShownBadge (chatController alice) Nothing
+
+-- The service issuing nothing while the ledger still owes a month is a fault the client cannot
+-- resolve, so it is recorded and told at once.
+testNoCredentialMonthsLeft :: HasCallStack => TestParams -> IO ()
+testNoCredentialMonthsLeft ps =
+  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueCode cc BTSupporter 3
+      redeemFirstBadge alice code
+      rows <- ledgerRows (chatController alice) "badge_ledger"
+      zeroServiceLedgerTip cc
+      setClockAt bsClock $ snd $ renewalMoments rows
+      alice ##> "/_app activate"
+      alice <## "ok"
+      alice <## "internal chat error: badge service issued no credential"
+      alice <##. "badge alert: issue_failed "
+      alice <##. "1: supporter"
+      alice <##. "renewal failing since "
+      alice <##. "badge alert: issue_failed "
+      (_, reason) <- issueErrorRow (chatController alice)
+      reason `shouldBe` Just "unexpected badge service issued no credential"
+
+-- | A debit the service wrote on its own, taking back the months the purchase had: copied from
+-- the tip so that it follows it in every column the client checks.
+insertServiceSupportDebit :: ChatController -> IO ()
+insertServiceSupportDebit ChatController {chatStore} =
+  withTransaction chatStore $ \db ->
+    DB.execute_ db . fromString $
+      "INSERT INTO sx_badge_service_badge_ledger"
+        <> " (entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts,"
+        <> "  balance_badge_type, service_created_at, created_at, entry_type, entry_debit_type)"
+        <> " SELECT 'support-debit', badge_purchase_id, -balance_months, 0, balance_start_ts, balance_anchor_ts,"
+        <> "  balance_badge_type, service_created_at, created_at, 'debit', 'support'"
+        <> " FROM sx_badge_service_badge_ledger ORDER BY entry_id DESC LIMIT 1"
+
+-- | The service's tip with its months struck out: nothing to issue, and no row restating the ledger.
+zeroServiceLedgerTip :: ChatController -> IO ()
+zeroServiceLedgerTip ChatController {chatStore} =
+  withTransaction chatStore $ \db ->
+    DB.execute_ db "UPDATE sx_badge_service_badge_ledger SET balance_months = 0 WHERE entry_id = (SELECT MAX(entry_id) FROM sx_badge_service_badge_ledger)"
+
+badgeServiceRefused :: String
+badgeServiceRefused = "bad chat command: badge service error: unknown_purchase_key"
+
+-- | The alert's episode is the start of the run of failures, as the ack command spells it.
+episodeOf :: HasCallStack => Maybe UTCTime -> Text
+episodeOf = maybe (error "no failure recorded") (safeDecodeUtf8 . strEncode)
+
+-- | A client that gives up on an unanswered service request in seconds rather than half a minute,
+-- and does not retry a failed pass on its own - so every pass is one the test asked for.
+failingServiceCfg :: ChatConfig -> ChatConfig
+failingServiceCfg cfg =
+  cfg
+    { agentConfig = (agentConfig cfg) {serviceRequestTimeout = 2},
+      badgeRetryInterval = RetryInterval {initialInterval = 3600000000, increaseAfter = 0, maxInterval = 3600000000}
+    }
+
+-- | The service reaches a purchase by the verified signer's key and no other way, so changing the
+-- key it holds makes it answer unknown_purchase_key, and putting it back makes renewals work again.
+servicePurchaseKey :: HasCallStack => ChatController -> IO ByteString
+servicePurchaseKey ChatController {chatStore} = do
+  rows :: [(Binary ByteString, Int64)] <-
+    withTransaction chatStore $ \db ->
+      DB.query_ db "SELECT purchase_key, badge_purchase_id FROM sx_badge_service_badge_purchases"
+  pure $ case rows of
+    [(Binary k, _)] -> k
+    _ -> error $ "expected one service purchase, got " <> show (length rows)
+
+setServicePurchaseKey :: ChatController -> ByteString -> IO ()
+setServicePurchaseKey ChatController {chatStore} k =
+  withTransaction chatStore $ \db ->
+    DB.execute db "UPDATE sx_badge_service_badge_purchases SET purchase_key = ?" (Only (Binary k))
+
+-- the run of failed renewals the purchase carries: when it started, and the last failure as stored
+issueErrorRow :: HasCallStack => ChatController -> IO (Maybe UTCTime, Maybe Text)
+issueErrorRow ChatController {chatStore} = do
+  rows :: [(Maybe UTCTime, Maybe Text)] <-
+    withTransaction chatStore $ \db ->
+      DB.query_ db "SELECT issue_failed_since, issue_error FROM badge_purchases"
+  pure $ case rows of
+    [r] -> r
+    _ -> error $ "expected one badge purchase, got " <> show (length rows)
+
+-- the clearing is written by the pass that stored the issuance, which the test waits for
+waitIssueErrorCleared :: HasCallStack => ChatController -> IO ()
+waitIssueErrorCleared cc = loop (100 :: Int)
+  where
+    loop 0 = issueErrorRow cc >>= (`shouldBe` (Nothing, Nothing))
+    loop i =
+      issueErrorRow cc >>= \r ->
+        if r == (Nothing, Nothing) then pure () else threadDelay 50000 >> loop (i - 1)
+
 -- A worker runs for every profile, not only the one in use, so presenting a renewed badge must not
 -- make its profile active - the next message would then be sent from the wrong identity.
 testRenewalKeepsActiveProfile :: HasCallStack => TestParams -> IO ()

tests/ChatTests/Groups.hs

@@ -5234,6 +5234,9 @@ testMemberContactAccept =
 
       cath #$> ("/_get chat @3 count=1", chat, [(0, "requested connection from group team")])
 
+      cath ##> "/_connect contact 1 3"
+      cath <## "bad chat command: contact is a member contact request"
+
       cath ##> "/accept_member_contact @bob"
       cath <## "contact bob is accepted, starting connection"
       concurrently_

tests/ChatTests/Profiles.hs

@@ -67,6 +67,7 @@ chatProfileTests = do
     it "rotate address ratchet keys" testRotateAddressRatchetKeys
     it "create address on specified server" testCreateAddressOnServer
     it "retry connecting via contact link" testRetryConnectingViaContactLink
+    it "retry connecting via address in contact profile after address keys rotation" testRetryConnectingContactViaAddress
     it "add contact link to profile" testProfileLink
     it "auto accept contact requests" testUserContactLinkAutoAccept
     it "deduplicate contact requests" testDeduplicateContactRequests
@@ -822,6 +823,50 @@ testRetryConnectingViaContactLink ps = testChatCfgOpts2 cfg' opts' aliceProfile
               }
         }
 
+testRetryConnectingContactViaAddress :: HasCallStack => TestParams -> IO ()
+testRetryConnectingContactViaAddress ps =
+  withNewTestChatOpts ps testOptsNoFullLinks "alice" aliceProfile $ \alice ->
+    withNewTestChatCfgOpts ps cfg' opts' "bob" bobProfile $ \bob -> do
+      alice ##> "/ad"
+      sLink <- getContactLink_ alice True
+      alice ##> "/pa on"
+      alice <## "new contact address set"
+      rotateAddressKeys alice
+      case A.parseOnly strP (B.pack sLink) of
+        Left _ -> error "error parsing contact link"
+        Right shortLink -> do
+          void $ withCCUser bob $ \user -> withCCTransaction bob $ \db -> runExceptT $ createContact db (storeCxt $ chatController bob) user aliceProfile {contactLink = Just shortLink}
+          bob ##> "/_connect contact 1 2"
+          bob <##. "smp agent error: BROKER"
+          rotateAddressKeys alice
+          withSmpServer' serverCfg' $ do
+            bob ##> "/_connect contact 1 2"
+            bob <## "connection request sent!"
+            alice <## "bob (Bob) wants to connect to you!"
+            alice <## "to accept: /ac bob"
+            alice <## "to reject: /rc bob (the sender will NOT be notified)"
+            alice ##> "/ac bob"
+            alice <## "bob (Bob): accepting contact request, you can send messages to contact"
+            concurrently_
+              (bob <## "alice (Alice): contact is connected")
+              (alice <## "bob (Bob): contact is connected")
+            alice <##> bob
+          bob <## "disconnected 1 connections on server localhost"
+  where
+    rotateAddressKeys alice = do
+      alice ##> "/_rotate_address_keys 1"
+      _ <- getContactLink_ alice False
+      alice <## "auto_accept off"
+    serverCfg' = smpServerCfg {transports = [("7003", transport @TLS, False)]}
+    cfg' = testCfg {agentConfig = testAgentCfg {persistErrorInterval = 0}}
+    opts' =
+      testOpts
+        { coreOptions =
+            testCoreOpts
+              { smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003"]
+              }
+        }
+
 testProfileLink :: HasCallStack => TestParams -> IO ()
 testProfileLink =
   testChat3 aliceProfile bobProfile cathProfile $

tests/ProtocolTests.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -12,6 +13,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.List (isInfixOf)
 import qualified Data.List.NonEmpty as L
+import Data.Maybe (fromMaybe)
 import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
 import Simplex.Chat.Library.Internal (decodeLinkUserData, encodeShortLinkData)
 import Simplex.Chat.Protocol
@@ -33,6 +35,41 @@ protocolTests = do
   decodeChatMessageTest
   shortLinkDataTests
   batchLimitTests
+  preferencesJSONTests
+
+preferencesJSONTests :: Spec
+preferencesJSONTests = describe "preferences JSON" $ do
+  it "stores no JSON when preferences encode to what was received" $ do
+    ps <- prefs "{\"voice\":{\"allow\":\"yes\"},\"calls\":{\"allow\":\"no\"}}"
+    storedJSON ps `shouldBe` Nothing
+  it "stores no JSON when group preferences encode to what was received" $ do
+    ps <- groupPrefs "{\"voice\":{\"enable\":\"on\"},\"reactions\":{\"enable\":\"off\"}}"
+    storedJSON ps `shouldBe` Nothing
+  it "stores JSON with a preference that is not defined" $ do
+    let s = "{\"voice\":{\"enable\":\"on\"},\"polls\":{\"enable\":\"on\"}}"
+    ps <- groupPrefs s
+    storedJSON ps `shouldBe` Just (object s)
+    J.toJSON ps `shouldBe` object "{\"voice\":{\"enable\":\"on\"}}"
+  it "stores JSON with a field that is not defined in a preference" $ do
+    let s = "{\"voice\":{\"enable\":\"on\",\"exceptRole\":\"observer\"}}"
+    ps <- groupPrefs s
+    storedJSON ps `shouldBe` Just (object s)
+  it "reads the received preferences from the stored JSON" $
+    groupPrefsFromRow (Just "{\"voice\":{\"enable\":\"on\"}}") (Just "{\"voice\":{\"enable\":\"off\"}}")
+      `shouldBe` groupPrefs_ "{\"voice\":{\"enable\":\"off\"}}"
+  it "reads the stored preferences when the received JSON does not parse" $
+    groupPrefsFromRow (Just "{\"voice\":{\"enable\":\"on\"}}") (Just "{\"voice\":{\"enable\":\"sometimes\"}}")
+      `shouldBe` groupPrefs_ "{\"voice\":{\"enable\":\"on\"}}"
+  where
+    prefs :: ByteString -> IO Preferences
+    prefs = either fail pure . J.eitherDecodeStrict'
+    groupPrefs :: ByteString -> IO GroupPreferences
+    groupPrefs = either fail pure . J.eitherDecodeStrict'
+    groupPrefs_ :: ByteString -> Maybe GroupPreferences
+    groupPrefs_ = J.decodeStrict'
+    storedJSON ps = J.decodeStrictText =<< snd (prefsToRow $ Just ps) :: Maybe J.Value
+    object :: ByteString -> J.Value
+    object s = fromMaybe (error $ "not JSON: " <> B.unpack s) $ J.decodeStrict' s
 
 batchLimitTests :: Spec
 batchLimitTests = describe "Chat message batch limits" $ do
@@ -133,10 +170,10 @@ s #==# msg = do
   s ==# msg
 
 testChatPreferences :: Maybe Preferences
-testChatPreferences = Just Preferences {voice = Just VoicePreference {allow = FAYes}, files = Nothing, fullDelete = Nothing, timedMessages = Nothing, calls = Nothing, reactions = Just ReactionsPreference {allow = FAYes}, sessions = Nothing, commands = Nothing}
+testChatPreferences = Just Preferences {voice = Just VoicePreference {allow = FAYes}, files = Nothing, fullDelete = Nothing, timedMessages = Nothing, calls = Nothing, reactions = Just ReactionsPreference {allow = FAYes}, sessions = Nothing, commands = Nothing, _json = PrefsJSON Nothing}
 
 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, signMessages = Nothing, commands = Nothing}
+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, signMessages = Nothing, commands = Nothing, _json = PrefsJSON Nothing}
 
 testProfile :: Profile
 testProfile = Profile {displayName = "alice", fullName = "Alice", shortDescr = Nothing, description = Nothing, image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), peerType = Nothing, contactLink = Nothing, preferences = testChatPreferences, badge = Nothing, contactDomain = Nothing}