From 7a3b30cca5f42793ea64b2ac53f53b867548e6d5 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 25 Jul 2025 21:15:46 +0100 Subject: [PATCH] core: backward compatible JSON parser for remote controller/host (#6105) * core: backward compatible JSON parser for remote controller/host * forward compatible JSON parsers for chats and content --- docs/CONTRIBUTING.md | 24 ++++- src/Simplex/Chat/Messages.hs | 136 ++++++++++++++----------- src/Simplex/Chat/Messages/CIContent.hs | 16 ++- src/Simplex/Chat/Terminal/Output.hs | 4 +- src/Simplex/Chat/View.hs | 15 ++- 5 files changed, 122 insertions(+), 73 deletions(-) diff --git a/docs/CONTRIBUTING.md b/docs/CONTRIBUTING.md index e7ce63ea54..f163335388 100644 --- a/docs/CONTRIBUTING.md +++ b/docs/CONTRIBUTING.md @@ -1,9 +1,9 @@ --- title: Contributing guide -revision: 31.01.2023 +revision: 25.07.2025 --- -| Updated 31.01.2023 | Languages: EN, [FR](/docs/lang/fr/CONTRIBUTING.md), [CZ](/docs/lang/cs/CONTRIBUTING.md), [PL](/docs/lang/pl/CONTRIBUTING.md) | +| Updated 25.07.2025 | Languages: EN, [FR](/docs/lang/fr/CONTRIBUTING.md), [CZ](/docs/lang/cs/CONTRIBUTING.md), [PL](/docs/lang/pl/CONTRIBUTING.md) | # Contributing guide @@ -113,3 +113,23 @@ import Control.Monad ``` [This PR](https://github.com/simplex-chat/simplex-chat/pull/2975/files) has all the differences. + + +## Improving compatibility between versions for remote desktop connection + +UI already can handle failed JSON conversions of chats and chat items, and it helps both debugging and downgrading. + +While we can increase versions for remote connections to make different versions incompatible, it degrades remote connection UX, as in many cases users can't upgrade mobile or desktop apps at the same time because of different release cycles. + +It is especially problematic for Android app users, as they can only downgrade via Export/Import - older version can't be installed on top of newer version. + +PR #6105 improved it by: +- adding CInfoInvalidJSON constructor, so that chats that cannot be parsed will show as "invalid chat" via remote connection (as when UI has field not present in API), +- changing JSON parsing for CIContent, so that it falls back to CIInvalidJSON in platform-specific JSON parser. + +To avoid "invalid" chats in the list we need to maintain forward compatibility on JSON encoding level of AChat type and subtypes: +- add new fields as optional to these types, +- add `omittedField` method to FromJSON instances of types of new fields to provide a default value, where appropriate, +- define primitive non-optional fields as newtype with `omittedField` in JSON instance. + +To avoid fallback to invalid JSON in chat items we should do the same for ChatItem type and subtypes. It's especially important when adding fields to types used for all CIContent, as otherwise all items will be broken. diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 24a2d11dc8..6f31ef638c 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -24,6 +24,7 @@ import Data.Aeson (FromJSON, ToJSON, (.:)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE import qualified Data.Aeson.TH as JQ +import qualified Data.Aeson.Types as JT import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy.Char8 as LB @@ -61,6 +62,61 @@ import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) data ChatType = CTDirect | CTGroup | CTLocal | CTContactRequest | CTContactConnection deriving (Eq, Show, Ord) +$(JQ.deriveJSON (enumJSON $ dropPrefix "CT") ''ChatType) + +data SChatType (c :: ChatType) where + SCTDirect :: SChatType 'CTDirect + SCTGroup :: SChatType 'CTGroup + SCTLocal :: SChatType 'CTLocal + SCTContactRequest :: SChatType 'CTContactRequest + SCTContactConnection :: SChatType 'CTContactConnection + +deriving instance Show (SChatType c) + +instance TestEquality SChatType where + testEquality SCTDirect SCTDirect = Just Refl + testEquality SCTGroup SCTGroup = Just Refl + testEquality SCTLocal SCTLocal = Just Refl + testEquality SCTContactRequest SCTContactRequest = Just Refl + testEquality SCTContactConnection SCTContactConnection = Just Refl + testEquality _ _ = Nothing + +data AChatType = forall c. ChatTypeI c => ACT (SChatType c) + +class ChatTypeI (c :: ChatType) where + chatTypeI :: SChatType c + +instance ChatTypeI 'CTDirect where chatTypeI = SCTDirect + +instance ChatTypeI 'CTGroup where chatTypeI = SCTGroup + +instance ChatTypeI 'CTLocal where chatTypeI = SCTLocal + +instance ChatTypeI 'CTContactRequest where chatTypeI = SCTContactRequest + +instance ChatTypeI 'CTContactConnection where chatTypeI = SCTContactConnection + +toChatType :: SChatType c -> ChatType +toChatType = \case + SCTDirect -> CTDirect + SCTGroup -> CTGroup + SCTLocal -> CTLocal + SCTContactRequest -> CTContactRequest + SCTContactConnection -> CTContactConnection + +aChatType :: ChatType -> AChatType +aChatType = \case + CTDirect -> ACT SCTDirect + CTGroup -> ACT SCTGroup + CTLocal -> ACT SCTLocal + CTContactRequest -> ACT SCTContactRequest + CTContactConnection -> ACT SCTContactConnection + +checkChatType :: forall t c c'. (ChatTypeI c, ChatTypeI c') => t c' -> Either String (t c) +checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of + Just Refl -> Right x + Nothing -> Left "bad chat type" + data GroupChatScope = GCSMemberSupport {groupMemberId_ :: Maybe GroupMemberId} -- Nothing means own conversation with support deriving (Eq, Show, Ord) @@ -113,6 +169,7 @@ data ChatInfo (c :: ChatType) where LocalChat :: NoteFolder -> ChatInfo 'CTLocal ContactRequest :: UserContactRequest -> ChatInfo 'CTContactRequest ContactConnection :: PendingContactConnection -> ChatInfo 'CTContactConnection + CInfoInvalidJSON :: SChatType c -> J.Object -> ChatInfo c -- this constructor is needed to catch JSON errors for Remote connection parsing deriving instance Show (ChatInfo c) @@ -146,13 +203,14 @@ memberEventForwardScope m@GroupMember {memberRole, memberStatus} | memberRole >= GRModerator = Just GFSAll | otherwise = Just GFSMain -chatInfoToRef :: ChatInfo c -> ChatRef +chatInfoToRef :: ChatInfo c -> Maybe ChatRef chatInfoToRef = \case - DirectChat Contact {contactId} -> ChatRef CTDirect contactId Nothing - GroupChat GroupInfo {groupId} scopeInfo -> ChatRef CTGroup groupId (toChatScope <$> scopeInfo) - LocalChat NoteFolder {noteFolderId} -> ChatRef CTLocal noteFolderId Nothing - ContactRequest UserContactRequest {contactRequestId} -> ChatRef CTContactRequest contactRequestId Nothing - ContactConnection PendingContactConnection {pccConnId} -> ChatRef CTContactConnection pccConnId Nothing + DirectChat Contact {contactId} -> Just $ ChatRef CTDirect contactId Nothing + GroupChat GroupInfo {groupId} scopeInfo -> Just $ ChatRef CTGroup groupId (toChatScope <$> scopeInfo) + LocalChat NoteFolder {noteFolderId} -> Just $ ChatRef CTLocal noteFolderId Nothing + ContactRequest UserContactRequest {contactRequestId} -> Just $ ChatRef CTContactRequest contactRequestId Nothing + ContactConnection PendingContactConnection {pccConnId} -> Just $ ChatRef CTContactConnection pccConnId Nothing + CInfoInvalidJSON {} -> Nothing chatInfoMembership :: ChatInfo c -> Maybe GroupMember chatInfoMembership = \case @@ -165,10 +223,17 @@ data JSONChatInfo | JCInfoLocal {noteFolder :: NoteFolder} | JCInfoContactRequest {contactRequest :: UserContactRequest} | JCInfoContactConnection {contactConnection :: PendingContactConnection} + | JCInfoInvalidJSON {chatType :: ChatType, json :: J.Object} $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GCSI") ''GroupChatScopeInfo) -$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCInfo") ''JSONChatInfo) +$(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "JCInfo") ''JSONChatInfo) + +instance FromJSON JSONChatInfo where + parseJSON v@(J.Object o) = + $(JQ.mkParseJSON (sumTypeJSON $ dropPrefix "JCInfo") ''JSONChatInfo) v + <|> ((`JCInfoInvalidJSON` o) <$> o .: "type") -- fallback for forward compatible remote parser + parseJSON invalid = JT.typeMismatch "Object" invalid instance ChatTypeI c => FromJSON (ChatInfo c) where parseJSON v = (\(AChatInfo _ c) -> checkChatType c) <$?> J.parseJSON v @@ -184,6 +249,7 @@ jsonChatInfo = \case LocalChat l -> JCInfoLocal l ContactRequest g -> JCInfoContactRequest g ContactConnection c -> JCInfoContactConnection c + CInfoInvalidJSON c o -> JCInfoInvalidJSON (toChatType c) o data AChatInfo = forall c. ChatTypeI c => AChatInfo (SChatType c) (ChatInfo c) @@ -196,6 +262,7 @@ jsonAChatInfo = \case JCInfoLocal l -> AChatInfo SCTLocal $ LocalChat l JCInfoContactRequest g -> AChatInfo SCTContactRequest $ ContactRequest g JCInfoContactConnection c -> AChatInfo SCTContactConnection $ ContactConnection c + JCInfoInvalidJSON cType o -> case aChatType cType of ACT c -> AChatInfo c $ CInfoInvalidJSON c o instance FromJSON AChatInfo where parseJSON v = jsonAChatInfo <$> J.parseJSON v @@ -1087,59 +1154,6 @@ type ChatItemId = Int64 type ChatItemTs = UTCTime -data SChatType (c :: ChatType) where - SCTDirect :: SChatType 'CTDirect - SCTGroup :: SChatType 'CTGroup - SCTLocal :: SChatType 'CTLocal - SCTContactRequest :: SChatType 'CTContactRequest - SCTContactConnection :: SChatType 'CTContactConnection - -deriving instance Show (SChatType c) - -instance TestEquality SChatType where - testEquality SCTDirect SCTDirect = Just Refl - testEquality SCTGroup SCTGroup = Just Refl - testEquality SCTLocal SCTLocal = Just Refl - testEquality SCTContactRequest SCTContactRequest = Just Refl - testEquality SCTContactConnection SCTContactConnection = Just Refl - testEquality _ _ = Nothing - -data AChatType = forall c. ChatTypeI c => ACT (SChatType c) - -class ChatTypeI (c :: ChatType) where - chatTypeI :: SChatType c - -instance ChatTypeI 'CTDirect where chatTypeI = SCTDirect - -instance ChatTypeI 'CTGroup where chatTypeI = SCTGroup - -instance ChatTypeI 'CTLocal where chatTypeI = SCTLocal - -instance ChatTypeI 'CTContactRequest where chatTypeI = SCTContactRequest - -instance ChatTypeI 'CTContactConnection where chatTypeI = SCTContactConnection - -toChatType :: SChatType c -> ChatType -toChatType = \case - SCTDirect -> CTDirect - SCTGroup -> CTGroup - SCTLocal -> CTLocal - SCTContactRequest -> CTContactRequest - SCTContactConnection -> CTContactConnection - -aChatType :: ChatType -> AChatType -aChatType = \case - CTDirect -> ACT SCTDirect - CTGroup -> ACT SCTGroup - CTLocal -> ACT SCTLocal - CTContactRequest -> ACT SCTContactRequest - CTContactConnection -> ACT SCTContactConnection - -checkChatType :: forall t c c'. (ChatTypeI c, ChatTypeI c') => t c' -> Either String (t c) -checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of - Just Refl -> Right x - Nothing -> Left "bad chat type" - data SndMessage = SndMessage { msgId :: MessageId, sharedMsgId :: SharedMsgId, @@ -1369,8 +1383,6 @@ data CIModeration = CIModeration } deriving (Show) -$(JQ.deriveJSON (enumJSON $ dropPrefix "CT") ''ChatType) - instance ChatTypeI c => FromJSON (SChatType c) where parseJSON v = (\(ACT t) -> checkChatType t) . aChatType <$?> J.parseJSON v diff --git a/src/Simplex/Chat/Messages/CIContent.hs b/src/Simplex/Chat/Messages/CIContent.hs index e0bff73e0c..9ee5205ab4 100644 --- a/src/Simplex/Chat/Messages/CIContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -14,10 +14,12 @@ module Simplex.Chat.Messages.CIContent where +import Control.Applicative ((<|>)) import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J import qualified Data.Aeson.TH as JQ import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Lazy as LB import Data.Int (Int64) import Data.Text (Text) import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -686,7 +688,13 @@ $(JQ.deriveJSON defaultJSON ''CIGroupInvitation) $(JQ.deriveJSON (enumJSON $ dropPrefix "CISCall") ''CICallStatus) -- platform specific -$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCI") ''JSONCIContent) +$(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "JCI") ''JSONCIContent) + +-- We only need this fallback for platform specific encoding to support remote desktop link +instance FromJSON JSONCIContent where + parseJSON v = + $(JQ.mkParseJSON (sumTypeJSON $ dropPrefix "JCI") ''JSONCIContent) v + <|> pure (JCIInvalidJSON MDRcv $ safeDecodeUtf8 $ LB.toStrict $ J.encode v) -- platform independent $(JQ.deriveJSON (singleFieldJSON $ dropPrefix "DBJCI") ''DBJSONCIContent) @@ -701,7 +709,11 @@ instance MsgDirectionI d => ToJSON (CIContent d) where toEncoding = J.toEncoding . jsonCIContent instance MsgDirectionI d => FromJSON (CIContent d) where - parseJSON v = (\(ACIContent _ c) -> checkDirection c) <$?> J.parseJSON v + parseJSON v = unwrap <$?> J.parseJSON v + where + unwrap = \case + ACIContent _ (CIInvalidJSON t) -> Right $ CIInvalidJSON @d t -- ignoring direction in ACIContent - it may be incorrect from JSONCIContent parser fallback + ACIContent _ c -> checkDirection c -- platform independent dbParseACIContent :: Text -> Either String ACIContent diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 5731be7b0b..8a37a4c477 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -164,8 +164,8 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} Cha case (chatDirNtf u chat chatDir (isUserMention ci), itemStatus) of (True, CISRcvNew) -> do let itemId = chatItemId' ci - chatRef = chatInfoToRef chat - void $ runReaderT (execChatCommand' (APIChatItemsRead chatRef [itemId]) 0) cc + chatRef_ = chatInfoToRef chat + forM_ chatRef_ $ \chatRef -> runReaderT (execChatCommand' (APIChatItemsRead chatRef [itemId]) 0) cc _ -> pure () logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s getRemoteUser rhId = diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index eb6db90d21..ae20b5730e 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -325,11 +325,13 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte testViewChats chats = [sShow $ map toChatView chats] where toChatView :: AChat -> (Text, Text, Maybe ConnStatus) - toChatView (AChat _ (Chat (DirectChat Contact {localDisplayName, activeConn}) items _)) = ("@" <> localDisplayName, toCIPreview items Nothing, connStatus <$> activeConn) - toChatView (AChat _ (Chat (GroupChat GroupInfo {membership, localDisplayName} _scopeInfo) items _)) = ("#" <> localDisplayName, toCIPreview items (Just membership), Nothing) - toChatView (AChat _ (Chat (LocalChat _) items _)) = ("*", toCIPreview items Nothing, Nothing) - toChatView (AChat _ (Chat (ContactRequest UserContactRequest {localDisplayName}) items _)) = ("<@" <> localDisplayName, toCIPreview items Nothing, Nothing) - toChatView (AChat _ (Chat (ContactConnection PendingContactConnection {pccConnId, pccConnStatus}) items _)) = (":" <> T.pack (show pccConnId), toCIPreview items Nothing, Just pccConnStatus) + toChatView (AChat _ (Chat cInfo items _)) = case cInfo of + DirectChat Contact {localDisplayName, activeConn} -> ("@" <> localDisplayName, toCIPreview items Nothing, connStatus <$> activeConn) + GroupChat GroupInfo {membership, localDisplayName} _scopeInfo -> ("#" <> localDisplayName, toCIPreview items (Just membership), Nothing) + LocalChat _ -> ("*", toCIPreview items Nothing, Nothing) + ContactRequest UserContactRequest {localDisplayName} -> ("<@" <> localDisplayName, toCIPreview items Nothing, Nothing) + ContactConnection PendingContactConnection {pccConnId, pccConnStatus} -> (":" <> T.pack (show pccConnId), toCIPreview items Nothing, Just pccConnStatus) + CInfoInvalidJSON {} -> ("invalid chat info", "", Nothing) toCIPreview :: [CChatItem c] -> Maybe GroupMember -> Text toCIPreview (ci : _) membership_ = testViewItem ci membership_ toCIPreview _ _ = "" @@ -722,6 +724,7 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa context = maybe [] forwardedFrom itemForwarded ContactRequest {} -> [] ContactConnection {} -> [] + CInfoInvalidJSON {} -> ["invalid chat info"] withItemDeleted item = case chatItemDeletedText ci (chatInfoMembership chat) of Nothing -> item Just t -> item <> styled (colored Red) (" [" <> t <> "]") @@ -919,6 +922,7 @@ viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md (_, CIDirectSnd) -> [sentText] (_, CIGroupSnd) -> [sentText] (_, CILocalSnd) -> [sentText] + (CInfoInvalidJSON {}, _) -> [] where view from msg | showReactions = viewReceivedReaction from msg reactionText ts tz sentAt @@ -1025,6 +1029,7 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of LocalChat _ -> ["notes: all messages are removed"] ContactRequest _ -> [] ContactConnection _ -> [] + CInfoInvalidJSON {} -> [] viewContactsList :: [Contact] -> [StyledString] viewContactsList =