mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-08-27 00:39:51 +00:00
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
This commit is contained in:
Evgeny
+22
-2
@@ -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.
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -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 =
|
||||
|
||||
Reference in New Issue
Block a user