fixes

src/Simplex/Chat/Badges.hs

@@ -311,7 +311,13 @@ data ProofPresHeader
   | PHLink ByteString
   | PHUnknown Char ByteString
   deriving (Eq, Show)
-  deriving (ToJSON, FromJSON) via (StrJSON "ProofPresHeader" ProofPresHeader)
+
+instance ToJSON ProofPresHeader where
+  toJSON = toJSON . BBSPresHeader . strEncode
+  toEncoding = toEncoding . BBSPresHeader . strEncode
+
+instance FromJSON ProofPresHeader where
+  parseJSON v = parseJSON v >>= \(BBSPresHeader ph) -> either fail pure $ strDecode ph
 
 instance StrEncoding ProofPresHeader where
   strEncode = \case

src/Simplex/Chat/Library/Commands.hs

@@ -1663,7 +1663,7 @@ processChatCommand cxt nm = \case
   APISetUserUIThemes uId uiThemes -> withUser $ \user@User {userId} -> do
     user'@User {userId = uId'} <- withFastStore $ \db -> do
       user' <- getUser db uId
-      liftIO $ setUserUIThemes db user uiThemes
+      liftIO $ setUserUIThemes db user' uiThemes
       pure user'
     when (userId == uId') $ chatWriteVar currentUser $ Just (user :: User) {uiThemes}
     ok user'
@@ -4043,7 +4043,7 @@ processChatCommand cxt nm = \case
           p'' = (p' :: Profile) {contactDomain = if isJust contactLink then claim else Nothing}
        in updateProfile_ user' p'' True $ withFastStore $ \db -> updateUserProfile db user' p''
     updateProfile_ :: User -> Profile -> Bool -> CM User -> CM ChatResponse
-    updateProfile_ user@User {userId, profile = p@LocalProfile {displayName = n}} p'@Profile {displayName = n', image = img'} shouldUpdateAddressData updateUser
+    updateProfile_ user@User {userId, profile = p@LocalProfile {displayName = n, image = img}} p'@Profile {displayName = n', image = img'} shouldUpdateAddressData updateUser
       | p' == fromLocalProfile p = pure $ CRUserProfileNoChange user
       | n /= n' = do
           checkValidName n'
@@ -4053,7 +4053,7 @@ processChatCommand cxt nm = \case
       | otherwise = update
       where
         update = do
-          checkProfileImageSize img'
+          when (img /= img') $ checkProfileImageSize img'
           checkProfileSize p'
           when shouldUpdateAddressData $ do
             ts <- liftIO getCurrentTime
@@ -4148,10 +4148,10 @@ processChatCommand cxt nm = \case
               lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct'
           pure $ CRContactPrefsUpdated user ct ct'
     runUpdateGroupProfile :: User -> GroupInfoKeys -> GroupProfile -> Bool -> CM ChatResponse
-    runUpdateGroupProfile user (GIK gInfo@GroupInfo {businessChat, groupProfile = p@GroupProfile {displayName = n}} gks) p'@GroupProfile {displayName = n', image = img', memberAdmission = ma'} domainVerified = do
+    runUpdateGroupProfile user (GIK gInfo@GroupInfo {businessChat, groupProfile = p@GroupProfile {displayName = n, image = img}} gks) p'@GroupProfile {displayName = n', image = img', memberAdmission = ma'} domainVerified = do
       assertUserGroupRole gInfo GROwner
       when (n /= n') $ checkValidName n'
-      checkProfileImageSize img'
+      when (img /= img') $ checkProfileImageSize img'
       checkGroupProfileSize p'
       when (useRelays' gInfo && isJust (ma' >>= review)) $ throwCmdError "Admission review is not supported in channels"
       -- updateGroupProfile clears domain verification; re-set it when the caller already re-resolved the name

src/Simplex/Chat/Store/Groups.hs

@@ -3568,7 +3568,7 @@ createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupI
   where
     VersionRange minV maxV = vr cxt
     newOwnerProfile currentTs = do
-      (ldn, pId, _) <- createNewMemberProfile_ db cxt user (profileFromName $ nameFromMemberId memberId) currentTs
+      (ldn, pId, _, _) <- createNewMemberProfile_ db cxt user (profileFromName $ nameFromMemberId memberId) Nothing currentTs
       pure (ldn, pId)
     contactNameAndProfile ctId = do
       Contact {localDisplayName = ldn, profile = LocalProfile {profileId = pId}} <- getContact db cxt user ctId

tests/BadgeTests.hs

@@ -51,6 +51,7 @@ badgeTests = do
   it "should accept unknown badge types" testUnknownBadgeType
   it "credential serializes to a paste-able token and back" testCredentialSerialization
   it "presentation headers encode and decode" testPresHeaderEncoding
+  it "presentation headers with binary bytes round-trip through JSON" testPresHeaderJSON
   it "should reject a proof presented under another chat binding" testOtherChatBinding
   it "should accept a profile proof only with the header of its chat" testProfileProofHeader
   describe "redemption codes" $ do
@@ -212,6 +213,23 @@ testPresHeaderEncoding =
       PHUnknown 'Z' "payload"
     ]
 
+testPresHeaderJSON :: IO ()
+testPresHeaderJSON =
+  mapM_
+    ( \ph -> do
+        J.eitherDecode (J.encode ph) `shouldBe` Right ph
+        J.toJSON ph `shouldBe` J.toJSON (BBSPresHeader $ strEncode ph)
+    )
+    [ PHChat binaryBytes,
+      PHFileInv {chatBinding = binaryBytes, fileSize = 139737},
+      PHFileDescr {chatBinding = binaryBytes, fileSize = 139737, descrHash = binaryBytes, fileExpires = Just futureTime},
+      PHRequest binaryBytes,
+      PHLink binaryBytes,
+      PHUnknown 'Z' binaryBytes
+    ]
+  where
+    binaryBytes = "\0\1\31\34\92\127\128\195\255"
+
 testOtherChatBinding :: IO ()
 testOtherChatBinding = do
   let ph = PHFileInv {chatBinding = aliceBinding, fileSize = 139737}

tests/ChatTests/Names.hs

@@ -66,7 +66,7 @@ testConnectByName ps = withSmpServerAndNames ps $ \reg ->
       pure ()
 
 testUpdateProfileKeepsName :: HasCallStack => TestParams -> IO ()
-testUpdateProfileKeepsName ps = withSmpServerAndNames $ \reg ->
+testUpdateProfileKeepsName ps = withSmpServerAndNames ps $ \reg ->
   testChat2 aliceProfile bobProfile (test reg) ps
   where
     aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" [])
@@ -103,7 +103,7 @@ testUpdateProfileKeepsName ps = withSmpServerAndNames $ \reg ->
       pure ()
 
 testAddressSharingOffRemovesName :: HasCallStack => TestParams -> IO ()
-testAddressSharingOffRemovesName ps = withSmpServerAndNames $ \reg ->
+testAddressSharingOffRemovesName ps = withSmpServerAndNames ps $ \reg ->
   testChat2 aliceProfile bobProfile (test reg) ps
   where
     aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" [])
@@ -143,7 +143,7 @@ testAddressSharingOffRemovesName ps = withSmpServerAndNames $ \reg ->
       pure ()
 
 testAddressDeleteRemovesName :: HasCallStack => TestParams -> IO ()
-testAddressDeleteRemovesName ps = withSmpServerAndNames $ \reg ->
+testAddressDeleteRemovesName ps = withSmpServerAndNames ps $ \reg ->
   testChat2 aliceProfile bobProfile (test reg) ps
   where
     aliceName = SimplexNameInfo NTContact (SimplexDomain TLDSimplex "alice" [])

tests/ChatTests/Profiles.hs

@@ -20,7 +20,6 @@ import Control.Monad.Except
 import Control.Monad.Reader (runReaderT)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
-import Data.List (isSuffixOf)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
@@ -47,6 +46,11 @@ import Simplex.Messaging.Util (decodeJSON, encodeJSON)
 import Simplex.Messaging.Version (mkVersionRange)
 import System.Directory (copyFile, createDirectoryIfMissing)
 import Test.Hspec hiding (it)
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple (Only (..))
+#else
+import Database.SQLite.Simple (Only (..))
+#endif
 
 chatProfileTests :: SpecWith TestParams
 chatProfileTests = do
@@ -59,6 +63,7 @@ chatProfileTests = do
     it "profile description round-trips and shows in contact info" testProfileDescriptionShown
     it "member profile description is redacted for members without a direct contact" testMemberDescriptionRedacted
     it "update user profile with image" testUpdateProfileImage
+    it "stored image over the limit is kept, a new one is rejected" testUpdateProfileStoredLargeImage
     it "reject profile image that is too large" testSetProfileImageTooLarge
     it "set profile image from file" testSetProfileImageFromFile
     it "use multiword profile names" testMultiWordProfileNames
@@ -265,8 +270,8 @@ testUpdateProfileAddressDataError ps = do
       bob <## "disconnected 1 connections on server localhost"
   where
     serverCfg' =
-      smpServerCfg
-        { transports = [("7003", transport @TLS, False)],
+      (smpServerCfg ps)
+        { transports = [(smpTestPort2 ps, transport @TLS, False)],
           serverStoreCfg = persistentServerStoreCfg (tmpPath ps)
         }
     opts' =
@@ -806,8 +811,8 @@ testUserBadgeAddressConnectRetry ps = do
       bob <## "disconnected 1 connections on server localhost"
   where
     serverCfg' =
-      smpServerCfg
-        { transports = [("7003", transport @TLS, False)],
+      (smpServerCfg ps)
+        { transports = [(smpTestPort2 ps, transport @TLS, False)],
           serverStoreCfg = persistentServerStoreCfg (tmpPath ps)
         }
     opts' =
@@ -849,8 +854,8 @@ testUserBadgeInvitationConnectRetry ps = do
       bob <## "disconnected 1 connections on server localhost"
   where
     serverCfg' =
-      smpServerCfg
-        { transports = [("7003", transport @TLS, False)],
+      (smpServerCfg ps)
+        { transports = [(smpTestPort2 ps, transport @TLS, False)],
           serverStoreCfg = persistentServerStoreCfg (tmpPath ps)
         }
     opts' =
@@ -1106,6 +1111,21 @@ testUpdateProfileImage =
       bob <## "use @alice2 <message> to send messages"
       (bob </)
 
+testUpdateProfileStoredLargeImage :: HasCallStack => TestParams -> IO ()
+testUpdateProfileStoredLargeImage =
+  testChat2 aliceProfile bobProfile $
+    \alice bob -> do
+      connectUsers alice bob
+      let image = "data:image/png;base64," <> replicate 13000 'A'
+      withCCTransaction alice $ \db ->
+        DB.execute db "UPDATE contact_profiles SET image = ? WHERE contact_profile_id = (SELECT contact_profile_id FROM contacts WHERE is_user = 1)" (Only image)
+      alice ##> "/p alisa"
+      alice <## "user profile is changed to alisa (your 1 contacts are notified)"
+      bob <## "contact alice changed to alisa"
+      bob <## "use @alisa <message> to send messages"
+      alice #> "@bob hi"
+      bob <# "alisa> hi"
+
 testSetProfileImageTooLarge :: HasCallStack => TestParams -> IO ()
 testSetProfileImageTooLarge =
   testChat2 aliceProfile bobProfile $
@@ -4101,7 +4121,6 @@ testShortLinkInvitationConnectRetry ps = testChatCfgOpts2 cfg' opts' aliceProfil
         { transports = [(smpTestPort2 ps, transport @TLS, False)],
           serverStoreCfg = persistentServerStoreCfg tmp
         }
-    cfg' = testCfg {agentConfig = testAgentCfg {persistErrorInterval = 0}}
     opts' =
       testOpts
         { coreOptions =