blade/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2024-12-17 17:20:21 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

core: derive JSON with TH (#3275)

Browse Source 
* core: derive JSON with TH

* fix tests

* simplify events

* reduce diff

* fix

* update simplexmq

* update simplexmq
This commit is contained in:
Evgeny Poberezkin
2023-10-26 15:44:50 +01:00
committed by GitHub
parent 3790752378
commit 16bda26022
23 changed files with 849 additions and 1136 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Protocol.hs
+51 -69
View File
@@ -1,6 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
@@ -11,6 +10,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
@@ -23,6 +23,7 @@ import Data.Aeson (FromJSON, ToJSON, (.:), (.:?), (.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.KeyMap as JM
import qualified Data.Aeson.TH as JQ
import qualified Data.Aeson.Types as JT
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
@@ -40,13 +41,12 @@ import Data.Typeable (Typeable)
import Data.Word (Word32)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic)
import Simplex.Chat.Call
import Simplex.Chat.Types
import Simplex.Chat.Types.Util
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version hiding (version)
@@ -70,14 +70,9 @@ data ConnectionEntity
| SndFileConnection {entityConnection :: Connection, sndFileTransfer :: SndFileTransfer}
| RcvFileConnection {entityConnection :: Connection, rcvFileTransfer :: RcvFileTransfer}
| UserContactConnection {entityConnection :: Connection, userContact :: UserContact}
deriving (Eq, Show, Generic)
deriving (Eq, Show)
instance FromJSON ConnectionEntity where
parseJSON = J.genericParseJSON $ sumTypeJSON fstToLower
instance ToJSON ConnectionEntity where
toJSON = J.genericToJSON $ sumTypeJSON fstToLower
toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower
$(JQ.deriveJSON (sumTypeJSON fstToLower) ''ConnectionEntity)
updateEntityConnStatus :: ConnectionEntity -> ConnStatus -> ConnectionEntity
updateEntityConnStatus connEntity connStatus = case connEntity of
@@ -104,8 +99,6 @@ instance MsgEncodingI 'Binary where encoding = SBinary
instance MsgEncodingI 'Json where encoding = SJson
data ACMEventTag = forall e. MsgEncodingI e => ACMEventTag (SMsgEncoding e) (CMEventTag e)
instance TestEquality SMsgEncoding where
testEquality SBinary SBinary = Just Refl
testEquality SJson SJson = Just Refl
@@ -127,7 +120,6 @@ data AppMessageJson = AppMessageJson
event :: Text,
params :: J.Object
}
deriving (Generic, FromJSON)
data AppMessageBinary = AppMessageBinary
{ msgId :: Maybe SharedMsgId,
@@ -135,10 +127,6 @@ data AppMessageBinary = AppMessageBinary
body :: ByteString
}
instance ToJSON AppMessageJson where
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
instance StrEncoding AppMessageBinary where
strEncode AppMessageBinary {tag, msgId, body} = smpEncode (tag, msgId', Tail body)
where
@@ -167,20 +155,42 @@ instance ToJSON SharedMsgId where
toJSON = strToJSON
toEncoding = strToJEncoding
$(JQ.deriveJSON defaultJSON ''AppMessageJson)
data MsgRef = MsgRef
{ msgId :: Maybe SharedMsgId,
sentAt :: UTCTime,
sent :: Bool,
memberId :: Maybe MemberId -- must be present in all group message references, both referencing sent and received
}
deriving (Eq, Show, Generic)
deriving (Eq, Show)
instance FromJSON MsgRef where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
$(JQ.deriveJSON defaultJSON ''MsgRef)
instance ToJSON MsgRef where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data LinkPreview = LinkPreview {uri :: Text, title :: Text, description :: Text, image :: ImageData, content :: Maybe LinkContent}
deriving (Eq, Show)
data LinkContent = LCPage | LCImage | LCVideo {duration :: Maybe Int} | LCUnknown {tag :: Text, json :: J.Object}
deriving (Eq, Show)
$(pure [])
instance FromJSON LinkContent where
parseJSON v@(J.Object j) =
$(JQ.mkParseJSON (taggedObjectJSON $ dropPrefix "LC") ''LinkContent) v
<|> LCUnknown <$> j .: "type" <*> pure j
parseJSON invalid =
JT.prependFailure "bad LinkContent, " (JT.typeMismatch "Object" invalid)
instance ToJSON LinkContent where
toJSON = \case
LCUnknown _ j -> J.Object j
v -> $(JQ.mkToJSON (taggedObjectJSON $ dropPrefix "LC") ''LinkContent) v
toEncoding = \case
LCUnknown _ j -> JE.value $ J.Object j
v -> $(JQ.mkToEncoding (taggedObjectJSON $ dropPrefix "LC") ''LinkContent) v
$(JQ.deriveJSON defaultJSON ''LinkPreview)
data ChatMessage e = ChatMessage
{ chatVRange :: VersionRange,
@@ -191,19 +201,6 @@ data ChatMessage e = ChatMessage
data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMessage e)
instance MsgEncodingI e => StrEncoding (ChatMessage e) where
strEncode msg = case chatToAppMessage msg of
AMJson m -> LB.toStrict $ J.encode m
AMBinary m -> strEncode m
strP = (\(ACMsg _ m) -> checkEncoding m) <$?> strP
instance StrEncoding AChatMessage where
strEncode (ACMsg _ m) = strEncode m
strP =
A.peekChar' >>= \case
'{' -> ACMsg SJson <$> ((appJsonToCM <=< J.eitherDecodeStrict') <$?> A.takeByteString)
_ -> ACMsg SBinary <$> (appBinaryToCM <$?> strP)
data ChatMsgEvent (e :: MsgEncoding) where
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
@@ -329,11 +326,7 @@ instance Encoding InlineFileChunk where
pure FileChunk {chunkNo = fromIntegral $ c2w c, chunkBytes}
data QuotedMsg = QuotedMsg {msgRef :: MsgRef, content :: MsgContent}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON QuotedMsg where
toEncoding = J.genericToEncoding J.defaultOptions
toJSON = J.genericToJSON J.defaultOptions
deriving (Eq, Show)
cmToQuotedMsg :: AChatMsgEvent -> Maybe QuotedMsg
cmToQuotedMsg = \case
@@ -386,34 +379,6 @@ isQuote = \case
MCQuote {} -> True
_ -> False
data LinkPreview = LinkPreview {uri :: Text, title :: Text, description :: Text, image :: ImageData, content :: Maybe LinkContent}
deriving (Eq, Show, Generic)
data LinkContent = LCPage | LCImage | LCVideo {duration :: Maybe Int} | LCUnknown {tag :: Text, json :: J.Object}
deriving (Eq, Show, Generic)
instance FromJSON LinkPreview where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
instance ToJSON LinkPreview where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
instance FromJSON LinkContent where
parseJSON v@(J.Object j) =
J.genericParseJSON (taggedObjectJSON $ dropPrefix "LC") v
<|> LCUnknown <$> j .: "type" <*> pure j
parseJSON invalid =
JT.prependFailure "bad LinkContent, " (JT.typeMismatch "Object" invalid)
instance ToJSON LinkContent where
toJSON = \case
LCUnknown _ j -> J.Object j
v -> J.genericToJSON (taggedObjectJSON $ dropPrefix "LC") v
toEncoding = \case
LCUnknown _ j -> JE.value $ J.Object j
v -> J.genericToEncoding (taggedObjectJSON $ dropPrefix "LC") v
data MsgContent
= MCText Text
| MCLink {text :: Text, preview :: LinkPreview}
@@ -466,6 +431,21 @@ msgContentTag = \case
data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: Maybe FileInvitation, ttl :: Maybe Int, live :: Maybe Bool}
deriving (Eq, Show)
$(JQ.deriveJSON defaultJSON ''QuotedMsg)
instance MsgEncodingI e => StrEncoding (ChatMessage e) where
strEncode msg = case chatToAppMessage msg of
AMJson m -> LB.toStrict $ J.encode m
AMBinary m -> strEncode m
strP = (\(ACMsg _ m) -> checkEncoding m) <$?> strP
instance StrEncoding AChatMessage where
strEncode (ACMsg _ m) = strEncode m
strP =
A.peekChar' >>= \case
'{' -> ACMsg SJson <$> ((appJsonToCM <=< J.eitherDecodeStrict') <$?> A.takeByteString)
_ -> ACMsg SBinary <$> (appBinaryToCM <$?> strP)
parseMsgContainer :: J.Object -> JT.Parser MsgContainer
parseMsgContainer v =
MCQuote <$> v .: "quote" <*> mc
@@ -545,6 +525,8 @@ instance ToField MsgContent where
instance FromField MsgContent where
fromField = fromTextField_ decodeJSON
data ACMEventTag = forall e. MsgEncodingI e => ACMEventTag (SMsgEncoding e) (CMEventTag e)
data CMEventTag (e :: MsgEncoding) where
XMsgNew_ :: CMEventTag 'Json
XMsgFileDescr_ :: CMEventTag 'Json