mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-08-28 12:04:11 +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
@@ -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