From 16bda260225d3ee1715b23cf17cda56adb5f4c37 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 26 Oct 2023 15:44:50 +0100 Subject: [PATCH] core: derive JSON with TH (#3275) * core: derive JSON with TH * fix tests * simplify events * reduce diff * fix * update simplexmq * update simplexmq --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 1 + src/Simplex/Chat/Call.hs | 135 ++---- src/Simplex/Chat/Controller.hs | 286 +++++------ src/Simplex/Chat/Markdown.hs | 42 +- src/Simplex/Chat/Messages.hs | 445 ++++++++---------- src/Simplex/Chat/Messages/CIContent.hs | 184 +------- src/Simplex/Chat/Messages/CIContent/Events.hs | 116 +++++ src/Simplex/Chat/Mobile.hs | 40 +- src/Simplex/Chat/Mobile/File.hs | 13 +- src/Simplex/Chat/Protocol.hs | 120 ++--- src/Simplex/Chat/Remote/Protocol.hs | 1 - src/Simplex/Chat/Remote/Types.hs | 11 +- src/Simplex/Chat/Store/Profiles.hs | 17 +- src/Simplex/Chat/Store/Shared.hs | 15 +- src/Simplex/Chat/Types.hs | 315 +++++-------- src/Simplex/Chat/Types/Preferences.hs | 202 ++++---- src/Simplex/Chat/Types/Util.hs | 3 - src/Simplex/Chat/View.hs | 22 +- stack.yaml | 2 +- tests/MobileTests.hs | 10 +- 23 files changed, 849 insertions(+), 1136 deletions(-) create mode 100644 src/Simplex/Chat/Messages/CIContent/Events.hs diff --git a/cabal.project b/cabal.project index 5c19fcd446..9cc0a7be6a 100644 --- a/cabal.project +++ b/cabal.project @@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: d920a2504b6d4653748da7d297cb13cd0a0f1f48 + tag: 511d793b927b1e2f12999e0829718671b3a8f0cb source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 26188aa774..658da37f6b 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."d920a2504b6d4653748da7d297cb13cd0a0f1f48" = "0r53wn01z044h6myvd458n3hiqsz64kpv59khgybzwdw5mmqnp34"; + "https://github.com/simplex-chat/simplexmq.git"."511d793b927b1e2f12999e0829718671b3a8f0cb" = "14zk7g33x4a1g5d1dihaklvwzll86ks6fk87kf6l6l5back581zi"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/kazu-yamamoto/http2.git"."804fa283f067bd3fd89b8c5f8d25b3047813a517" = "1j67wp7rfybfx3ryx08z6gqmzj85j51hmzhgx47ihgmgr47sl895"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "0kiwhvml42g9anw4d2v0zd1fpc790pj9syg5x3ik4l97fnkbbwpp"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index f061f8ac86..e9036ea604 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -36,6 +36,7 @@ library Simplex.Chat.Markdown Simplex.Chat.Messages Simplex.Chat.Messages.CIContent + Simplex.Chat.Messages.CIContent.Events Simplex.Chat.Migrations.M20220101_initial Simplex.Chat.Migrations.M20220122_v1_1 Simplex.Chat.Migrations.M20220205_chat_item_status diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 2ef5c4356f..e8049dcbb5 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -58,6 +58,7 @@ import Simplex.Chat.Controller import Simplex.Chat.Markdown import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent +import Simplex.Chat.Messages.CIContent.Events import Simplex.Chat.Options import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol diff --git a/src/Simplex/Chat/Call.hs b/src/Simplex/Chat/Call.hs index 7e6e60c8f5..313442838e 100644 --- a/src/Simplex/Chat/Call.hs +++ b/src/Simplex/Chat/Call.hs @@ -1,18 +1,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use newtype instead of data" #-} module Simplex.Chat.Call where -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as J +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) @@ -20,12 +20,11 @@ import Data.Text (Text) import Data.Time.Clock (UTCTime) import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) -import GHC.Generics (Generic) import Simplex.Chat.Types (Contact, ContactId, User) import Simplex.Chat.Types.Util (decodeJSON, encodeJSON) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, fstToLower, singleFieldJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, fstToLower, singleFieldJSON) data Call = Call { contactId :: ContactId, @@ -47,14 +46,7 @@ data CallStateTag | CSTCallOfferSent | CSTCallOfferReceived | CSTCallNegotiated - deriving (Show, Generic) - -instance FromJSON CallStateTag where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CSTCall" - -instance ToJSON CallStateTag where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "CSTCall" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CSTCall" + deriving (Show) callStateTag :: CallState -> CallStateTag callStateTag = \case @@ -93,21 +85,7 @@ data CallState peerCallSession :: WebRTCSession, sharedKey :: Maybe C.Key } - deriving (Show, Generic) - --- database representation -instance FromJSON CallState where - parseJSON = J.genericParseJSON $ singleFieldJSON fstToLower - -instance ToJSON CallState where - toJSON = J.genericToJSON $ singleFieldJSON fstToLower - toEncoding = J.genericToEncoding $ singleFieldJSON fstToLower - -instance ToField CallState where - toField = toField . encodeJSON - -instance FromField CallState where - fromField = fromTextField_ decodeJSON + deriving (Show) newtype CallId = CallId ByteString deriving (Eq, Show) @@ -135,17 +113,13 @@ data RcvCallInvitation = RcvCallInvitation sharedKey :: Maybe C.Key, callTs :: UTCTime } - deriving (Show, Generic, FromJSON) - -instance ToJSON RcvCallInvitation where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Show) data CallType = CallType { media :: CallMedia, capabilities :: CallCapabilities } - deriving (Eq, Show, Generic, FromJSON) + deriving (Eq, Show) defaultCallType :: CallType defaultCallType = CallType CMVideo $ CallCapabilities {encryption = True} @@ -153,95 +127,54 @@ defaultCallType = CallType CMVideo $ CallCapabilities {encryption = True} encryptedCall :: CallType -> Bool encryptedCall CallType {capabilities = CallCapabilities {encryption}} = encryption -instance ToJSON CallType where toEncoding = J.genericToEncoding J.defaultOptions - -- | * Types for chat protocol data CallInvitation = CallInvitation { callType :: CallType, callDhPubKey :: Maybe C.PublicKeyX25519 } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON CallInvitation where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) data CallMedia = CMAudio | CMVideo - deriving (Eq, Show, Generic) - -instance FromJSON CallMedia where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CM" - -instance ToJSON CallMedia where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "CM" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CM" + deriving (Eq, Show) data CallCapabilities = CallCapabilities { encryption :: Bool } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON CallCapabilities where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data CallOffer = CallOffer { callType :: CallType, rtcSession :: WebRTCSession, callDhPubKey :: Maybe C.PublicKeyX25519 } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON CallOffer where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) data WebRTCCallOffer = WebRTCCallOffer { callType :: CallType, rtcSession :: WebRTCSession } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON WebRTCCallOffer where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) data CallAnswer = CallAnswer { rtcSession :: WebRTCSession } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON CallAnswer where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data CallExtraInfo = CallExtraInfo { rtcExtraInfo :: WebRTCExtraInfo } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON CallExtraInfo where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data WebRTCSession = WebRTCSession { rtcSession :: Text, -- LZW compressed JSON encoding of offer or answer rtcIceCandidates :: Text -- LZW compressed JSON encoding of array of ICE candidates } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON WebRTCSession where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data WebRTCExtraInfo = WebRTCExtraInfo { rtcIceCandidates :: Text -- LZW compressed JSON encoding of array of ICE candidates } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON WebRTCExtraInfo where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data WebRTCCallStatus = WCSConnecting | WCSConnected | WCSDisconnected | WCSFailed deriving (Show) @@ -259,3 +192,37 @@ instance StrEncoding WebRTCCallStatus where "disconnected" -> pure WCSDisconnected "failed" -> pure WCSFailed _ -> fail "bad WebRTCCallStatus" + +$(J.deriveJSON (enumJSON $ dropPrefix "CSTCall") ''CallStateTag) + +$(J.deriveJSON (enumJSON $ dropPrefix "CM") ''CallMedia) + +$(J.deriveJSON defaultJSON ''CallCapabilities) + +$(J.deriveJSON defaultJSON ''CallType) + +$(J.deriveJSON defaultJSON ''CallInvitation) + +$(J.deriveJSON defaultJSON ''WebRTCSession) + +$(J.deriveJSON defaultJSON ''CallOffer) + +$(J.deriveJSON defaultJSON ''WebRTCCallOffer) + +$(J.deriveJSON defaultJSON ''CallAnswer) + +$(J.deriveJSON defaultJSON ''WebRTCExtraInfo) + +$(J.deriveJSON defaultJSON ''CallExtraInfo) + +-- database representation +$(J.deriveJSON (singleFieldJSON fstToLower) ''CallState) + +instance ToField CallState where + toField = toField . encodeJSON + +instance FromField CallState where + fromField = fromTextField_ decodeJSON + +$(J.deriveJSON defaultJSON ''RcvCallInvitation) + diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 1bb28f89d2..66ab513a0d 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -2,7 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -41,7 +40,6 @@ import Data.String import Data.Text (Text) import Data.Time (NominalDiffTime, UTCTime) import Data.Version (showVersion) -import GHC.Generics (Generic) import Language.Haskell.TH (Exp, Q, runIO) import Numeric.Natural import qualified Paths_simplex_chat as SC @@ -67,7 +65,7 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus) -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON) import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServerWithAuth, userProtocol) import Simplex.Messaging.TMap (TMap) import Simplex.Messaging.Transport (simplexMQVersion) @@ -196,14 +194,7 @@ data ChatController = ChatController } data HelpSection = HSMain | HSFiles | HSGroups | HSContacts | HSMyAddress | HSIncognito | HSMarkdown | HSMessages | HSSettings | HSDatabase - deriving (Show, Generic) - -instance FromJSON HelpSection where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "HS" - -instance ToJSON HelpSection where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "HS" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HS" + deriving (Show) data ChatCommand = ShowActiveUser @@ -698,28 +689,14 @@ data ConnectionPlan = CPInvitationLink {invitationLinkPlan :: InvitationLinkPlan} | CPContactAddress {contactAddressPlan :: ContactAddressPlan} | CPGroupLink {groupLinkPlan :: GroupLinkPlan} - deriving (Show, Generic) - -instance FromJSON ConnectionPlan where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "CP" - -instance ToJSON ConnectionPlan where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CP" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CP" + deriving (Show) data InvitationLinkPlan = ILPOk | ILPOwnLink | ILPConnecting {contact_ :: Maybe Contact} | ILPKnown {contact :: Contact} - deriving (Show, Generic) - -instance FromJSON InvitationLinkPlan where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "ILP" - -instance ToJSON InvitationLinkPlan where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "ILP" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "ILP" + deriving (Show) data ContactAddressPlan = CAPOk @@ -727,14 +704,7 @@ data ContactAddressPlan | CAPConnectingConfirmReconnect | CAPConnectingProhibit {contact :: Contact} | CAPKnown {contact :: Contact} - deriving (Show, Generic) - -instance FromJSON ContactAddressPlan where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "CAP" - -instance ToJSON ContactAddressPlan where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CAP" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CAP" + deriving (Show) data GroupLinkPlan = GLPOk @@ -742,14 +712,7 @@ data GroupLinkPlan | GLPConnectingConfirmReconnect | GLPConnectingProhibit {groupInfo_ :: Maybe GroupInfo} | GLPKnown {groupInfo :: GroupInfo} - deriving (Show, Generic) - -instance FromJSON GroupLinkPlan where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "GLP" - -instance ToJSON GroupLinkPlan where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "GLP" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "GLP" + deriving (Show) connectionPlanProceed :: ConnectionPlan -> Bool connectionPlanProceed = \case @@ -794,7 +757,7 @@ instance ToJSON AgentQueueId where toEncoding = strToJEncoding data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]} - deriving (Show, Generic, FromJSON) + deriving (Show) data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p) @@ -805,36 +768,17 @@ data UserProtoServers p = UserProtoServers protoServers :: NonEmpty (ServerCfg p), presetServers :: NonEmpty (ProtoServerWithAuth p) } - deriving (Show, Generic) - -instance ProtocolTypeI p => FromJSON (UserProtoServers p) where - parseJSON = J.genericParseJSON J.defaultOptions - -instance ProtocolTypeI p => ToJSON (UserProtoServers p) where - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p) -instance FromJSON AUserProtoServers where - parseJSON v = J.withObject "AUserProtoServers" parse v - where - parse o = do - AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol" - case userProtocol p of - Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v - Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p - -instance ToJSON AUserProtoServers where - toJSON (AUPS s) = J.genericToJSON J.defaultOptions s - toEncoding (AUPS s) = J.genericToEncoding J.defaultOptions s - deriving instance Show AUserProtoServers data ArchiveConfig = ArchiveConfig {archivePath :: FilePath, disableCompression :: Maybe Bool, parentTempDirectory :: Maybe FilePath} - deriving (Show, Generic, FromJSON) + deriving (Show) data DBEncryptionConfig = DBEncryptionConfig {currentKey :: DBEncryptionKey, newKey :: DBEncryptionKey} - deriving (Show, Generic, FromJSON) + deriving (Show) newtype DBEncryptionKey = DBEncryptionKey String deriving (Show) @@ -852,41 +796,25 @@ data ContactSubStatus = ContactSubStatus { contact :: Contact, contactError :: Maybe ChatError } - deriving (Show, Generic, FromJSON) - -instance ToJSON ContactSubStatus where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Show) data MemberSubStatus = MemberSubStatus { member :: GroupMember, memberError :: Maybe ChatError } - deriving (Show, Generic, FromJSON) - -instance ToJSON MemberSubStatus where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Show) data UserContactSubStatus = UserContactSubStatus { userContact :: UserContact, userContactError :: Maybe ChatError } - deriving (Show, Generic, FromJSON) - -instance ToJSON UserContactSubStatus where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Show) data PendingSubStatus = PendingSubStatus { connection :: PendingContactConnection, connError :: Maybe ChatError } - deriving (Show, Generic, FromJSON) - -instance ToJSON PendingSubStatus where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Show) data UserProfileUpdateSummary = UserProfileUpdateSummary { notChanged :: Int, @@ -894,16 +822,14 @@ data UserProfileUpdateSummary = UserProfileUpdateSummary updateFailures :: Int, changedContacts :: [Contact] } - deriving (Show, Generic, FromJSON) - -instance ToJSON UserProfileUpdateSummary where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data ComposedMessage = ComposedMessage { fileSource :: Maybe CryptoFile, quotedItemId :: Maybe ChatItemId, msgContent :: MsgContent } - deriving (Show, Generic) + deriving (Show) -- This instance is needed for backward compatibility, can be removed in v6.0 instance FromJSON ComposedMessage where @@ -918,24 +844,16 @@ instance FromJSON ComposedMessage where parseJSON invalid = JT.prependFailure "bad ComposedMessage, " (JT.typeMismatch "Object" invalid) -instance ToJSON ComposedMessage where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - data XFTPFileConfig = XFTPFileConfig { minFileSize :: Integer } - deriving (Show, Generic, FromJSON) + deriving (Show) defaultXFTPFileConfig :: XFTPFileConfig defaultXFTPFileConfig = XFTPFileConfig {minFileSize = 0} -instance ToJSON XFTPFileConfig where toEncoding = J.genericToEncoding J.defaultOptions - data NtfMsgInfo = NtfMsgInfo {msgTs :: UTCTime, msgFlags :: MsgFlags} - deriving (Show, Generic, FromJSON) - -instance ToJSON NtfMsgInfo where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) crNtfToken :: (DeviceToken, NtfTknStatus, NotificationsMode) -> ChatResponse crNtfToken (token, status, ntfMode) = CRNtfToken {token, status, ntfMode} @@ -945,25 +863,19 @@ data SwitchProgress = SwitchProgress switchPhase :: SwitchPhase, connectionStats :: ConnectionStats } - deriving (Show, Generic, FromJSON) - -instance ToJSON SwitchProgress where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data RatchetSyncProgress = RatchetSyncProgress { ratchetSyncStatus :: RatchetSyncState, connectionStats :: ConnectionStats } - deriving (Show, Generic, FromJSON) - -instance ToJSON RatchetSyncProgress where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data ParsedServerAddress = ParsedServerAddress { serverAddress :: Maybe ServerAddress, parseError :: String } - deriving (Show, Generic, FromJSON) - -instance ToJSON ParsedServerAddress where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data ServerAddress = ServerAddress { serverProtocol :: AProtocolType, @@ -972,9 +884,7 @@ data ServerAddress = ServerAddress keyHash :: String, basicAuth :: String } - deriving (Show, Generic, FromJSON) - -instance ToJSON ServerAddress where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data TimedMessagesEnabled = TMEEnableSetTTL Int @@ -996,22 +906,18 @@ data CoreVersionInfo = CoreVersionInfo simplexmqVersion :: String, simplexmqCommit :: String } - deriving (Show, Generic, FromJSON) - -instance ToJSON CoreVersionInfo where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data SendFileMode = SendFileSMP (Maybe InlineFileMode) | SendFileXFTP - deriving (Show, Generic) + deriving (Show) data SlowSQLQuery = SlowSQLQuery { query :: Text, queryStats :: SlowQueryStats } - deriving (Show, Generic, FromJSON) - -instance ToJSON SlowSQLQuery where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data ChatError = ChatError {errorType :: ChatErrorType} @@ -1020,14 +926,7 @@ data ChatError | ChatErrorDatabase {databaseError :: DatabaseError} | ChatErrorRemoteCtrl {remoteCtrlError :: RemoteCtrlError} | ChatErrorRemoteHost {remoteHostId :: RemoteHostId, remoteHostError :: RemoteHostError} - deriving (Show, Exception, Generic) - -instance FromJSON ChatError where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "Chat" - -instance ToJSON ChatError where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "Chat" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "Chat" + deriving (Show, Exception) data ChatErrorType = CENoActiveUser @@ -1107,14 +1006,7 @@ data ChatErrorType | CEPeerChatVRangeIncompatible | CEInternalError {message :: String} | CEException {message :: String} - deriving (Show, Exception, Generic) - -instance FromJSON ChatErrorType where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "CE" - -instance ToJSON ChatErrorType where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CE" + deriving (Show, Exception) data DatabaseError = DBErrorEncrypted @@ -1122,24 +1014,10 @@ data DatabaseError | DBErrorNoFile {dbFile :: String} | DBErrorExport {sqliteError :: SQLiteError} | DBErrorOpen {sqliteError :: SQLiteError} - deriving (Show, Exception, Generic) - -instance FromJSON DatabaseError where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "DB" - -instance ToJSON DatabaseError where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "DB" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "DB" + deriving (Show, Exception) data SQLiteError = SQLiteErrorNotADatabase | SQLiteError String - deriving (Show, Exception, Generic) - -instance FromJSON SQLiteError where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "SQLite" - -instance ToJSON SQLiteError where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SQLite" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SQLite" + deriving (Show, Exception) throwDBError :: ChatMonad m => DatabaseError -> m () throwDBError = throwError . ChatErrorDatabase @@ -1153,14 +1031,7 @@ data RemoteHostError | RHDisconnected {reason :: Text} -- ^ A session disconnected by a host | RHConnectionLost {reason :: Text} -- ^ A session disconnected due to transport issues | RHProtocolError RemoteProtocolError - deriving (Show, Exception, Generic) - -instance FromJSON RemoteHostError where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RH" - -instance ToJSON RemoteHostError where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RH" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RH" + deriving (Show, Exception) -- TODO review errors, some of it can be covered by HTTP2 errors data RemoteCtrlError @@ -1176,26 +1047,12 @@ data RemoteCtrlError | RCEHTTP2RespStatus {statusCode :: Maybe Int} -- TODO remove | RCEInvalidResponse {responseError :: String} | RCEProtocolError {protocolError :: RemoteProtocolError} - deriving (Show, Exception, Generic) - -instance FromJSON RemoteCtrlError where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RCE" - -instance ToJSON RemoteCtrlError where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RCE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RCE" + deriving (Show, Exception) data ArchiveError = AEImport {chatError :: ChatError} | AEImportFile {file :: String, chatError :: ChatError} - deriving (Show, Exception, Generic) - -instance FromJSON ArchiveError where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "AE" - -instance ToJSON ArchiveError where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "AE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "AE" + deriving (Show, Exception) data RemoteCtrlSession = RemoteCtrlSession { -- | Host (mobile) side of transport to process remote commands and forward notifications @@ -1295,4 +1152,83 @@ withStoreCtx ctx_ action = do handleInternal :: String -> SomeException -> IO (Either StoreError a) handleInternal ctxStr e = pure . Left . SEInternalError $ show e <> ctxStr +$(JQ.deriveJSON (enumJSON $ dropPrefix "HS") ''HelpSection) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "ILP") ''InvitationLinkPlan) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CAP") ''ContactAddressPlan) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GLP") ''GroupLinkPlan) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CP") ''ConnectionPlan) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CE") ''ChatErrorType) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RH") ''RemoteHostError) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RemoteCtrlError) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "SQLite") ''SQLiteError) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "DB") ''DatabaseError) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "Chat") ''ChatError) + +$(JQ.deriveJSON defaultJSON ''ContactSubStatus) + +$(JQ.deriveJSON defaultJSON ''MemberSubStatus) + +$(JQ.deriveJSON defaultJSON ''UserContactSubStatus) + +$(JQ.deriveJSON defaultJSON ''PendingSubStatus) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "AE") ''ArchiveError) + +$(JQ.deriveJSON defaultJSON ''UserProfileUpdateSummary) + +$(JQ.deriveJSON defaultJSON ''NtfMsgInfo) + +$(JQ.deriveJSON defaultJSON ''SwitchProgress) + +$(JQ.deriveJSON defaultJSON ''RatchetSyncProgress) + +$(JQ.deriveJSON defaultJSON ''ServerAddress) + +$(JQ.deriveJSON defaultJSON ''ParsedServerAddress) + +$(JQ.deriveJSON defaultJSON ''CoreVersionInfo) + +$(JQ.deriveJSON defaultJSON ''SlowSQLQuery) + +instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig) + +instance ProtocolTypeI p => FromJSON (UserProtoServers p) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers) + +instance ProtocolTypeI p => ToJSON (UserProtoServers p) where + toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers) + toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) + +instance FromJSON AUserProtoServers where + parseJSON v = J.withObject "AUserProtoServers" parse v + where + parse o = do + AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol" + case userProtocol p of + Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v + Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p + +instance ToJSON AUserProtoServers where + toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s + toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s + $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CR") ''ChatResponse) + +$(JQ.deriveFromJSON defaultJSON ''ArchiveConfig) + +$(JQ.deriveFromJSON defaultJSON ''DBEncryptionConfig) + +$(JQ.deriveJSON defaultJSON ''XFTPFileConfig) + +$(JQ.deriveToJSON defaultJSON ''ComposedMessage) diff --git a/src/Simplex/Chat/Markdown.hs b/src/Simplex/Chat/Markdown.hs index 793fa753e1..391f43fa37 100644 --- a/src/Simplex/Chat/Markdown.hs +++ b/src/Simplex/Chat/Markdown.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use newtype instead of data" #-} @@ -13,6 +13,7 @@ module Simplex.Chat.Markdown where import Control.Applicative (optional, (<|>)) import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ import Data.Attoparsec.Text (Parser) import qualified Data.Attoparsec.Text as A import Data.Char (isDigit) @@ -27,12 +28,11 @@ import Data.String import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import GHC.Generics import Simplex.Chat.Types import Simplex.Chat.Types.Util import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri (..), ConnReqScheme (..), ConnReqUriData (..), ConnectionRequestUri (..), SMPQueue (..)) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fstToLower, sumTypeJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fstToLower, sumTypeJSON) import Simplex.Messaging.Protocol (ProtocolServer (..)) import Simplex.Messaging.Util (safeDecodeUtf8) import System.Console.ANSI.Types @@ -52,17 +52,10 @@ data Format | SimplexLink {linkType :: SimplexLinkType, simplexUri :: Text, smpHosts :: NonEmpty Text} | Email | Phone - deriving (Eq, Show, Generic) + deriving (Eq, Show) data SimplexLinkType = XLContact | XLInvitation | XLGroup - deriving (Eq, Show, Generic) - -instance FromJSON SimplexLinkType where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "XL" - -instance ToJSON SimplexLinkType where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "XL" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "XL" + deriving (Eq, Show) colored :: Color -> Format colored = Colored . FormatColor @@ -70,13 +63,6 @@ colored = Colored . FormatColor markdown :: Format -> Text -> Markdown markdown = Markdown . Just -instance FromJSON Format where - parseJSON = J.genericParseJSON $ sumTypeJSON fstToLower - -instance ToJSON Format where - toJSON = J.genericToJSON $ sumTypeJSON fstToLower - toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower - instance Semigroup Markdown where m <> (Markdown _ "") = m (Markdown _ "") <> m = m @@ -122,10 +108,7 @@ instance ToJSON FormatColor where White -> "white" data FormattedText = FormattedText {format :: Maybe Format, text :: Text} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON FormattedText where - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) instance IsString FormattedText where fromString = FormattedText Nothing . T.pack @@ -133,11 +116,6 @@ instance IsString FormattedText where type MarkdownList = [FormattedText] data ParsedMarkdown = ParsedMarkdown {formattedText :: Maybe MarkdownList} - deriving (Generic) - -instance ToJSON ParsedMarkdown where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} unmarked :: Text -> Markdown unmarked = Markdown Nothing @@ -257,3 +235,11 @@ markdownP = mconcat <$> A.many' fragmentP linkType' ConnReqUriData {crClientData} = case crClientData >>= decodeJSON of Just (CRDataGroup _) -> XLGroup Nothing -> XLContact + +$(JQ.deriveJSON (enumJSON $ dropPrefix "XL") ''SimplexLinkType) + +$(JQ.deriveJSON (sumTypeJSON fstToLower) ''Format) + +$(JQ.deriveJSON defaultJSON ''FormattedText) + +$(JQ.deriveToJSON defaultJSON ''ParsedMarkdown) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 8bc302f5d9..2718b088ba 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} @@ -10,6 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} @@ -20,6 +20,7 @@ import Control.Applicative ((<|>)) 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.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy.Char8 as LB @@ -33,7 +34,6 @@ import Data.Type.Equality import Data.Typeable (Typeable) import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) -import GHC.Generics (Generic) import Simplex.Chat.Markdown import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol @@ -43,17 +43,15 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptSta import Simplex.Messaging.Crypto.File (CryptoFile (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, parseAll, enumJSON, sumTypeJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, parseAll, enumJSON, sumTypeJSON) import Simplex.Messaging.Protocol (MsgBody) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection - deriving (Eq, Show, Ord, Generic) + deriving (Eq, Show, Ord) data ChatName = ChatName {chatType :: ChatType, chatName :: Text} - deriving (Show, Generic, FromJSON) - -instance ToJSON ChatName where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) chatTypeStr :: ChatType -> String chatTypeStr = \case @@ -68,13 +66,6 @@ chatNameStr (ChatName cType name) = chatTypeStr cType <> T.unpack name data ChatRef = ChatRef ChatType Int64 deriving (Eq, Show, Ord) -instance FromJSON ChatType where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "CT" - -instance ToJSON ChatType where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "CT" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CT" - data ChatInfo (c :: ChatType) where DirectChat :: Contact -> ChatInfo 'CTDirect GroupChat :: GroupInfo -> ChatInfo 'CTGroup @@ -113,14 +104,8 @@ data JSONChatInfo | JCInfoGroup {groupInfo :: GroupInfo} | JCInfoContactRequest {contactRequest :: UserContactRequest} | JCInfoContactConnection {contactConnection :: PendingContactConnection} - deriving (Generic) -instance FromJSON JSONChatInfo where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "JCInfo" - -instance ToJSON JSONChatInfo where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCInfo" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCInfo" +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCInfo") ''JSONChatInfo) instance ChatTypeI c => FromJSON (ChatInfo c) where parseJSON v = (\(AChatInfo _ c) -> checkChatType c) <$?> J.parseJSON v @@ -163,14 +148,7 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem reactions :: [CIReactionCount], file :: Maybe (CIFile d) } - deriving (Show, Generic) - -instance (ChatTypeI c, MsgDirectionI d) => FromJSON (ChatItem c d) where - parseJSON = J.genericParseJSON J.defaultOptions - -instance (ChatTypeI c, MsgDirectionI d) => ToJSON (ChatItem c d) where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Show) isMention :: ChatItem c d -> Bool isMention ChatItem {chatDir, quotedItem} = case chatDir of @@ -195,34 +173,14 @@ deriving instance Show (CIDirection c d) data CCIDirection c = forall d. MsgDirectionI d => CCID (SMsgDirection d) (CIDirection c d) -instance ChatTypeI c => FromJSON (CCIDirection c) where - parseJSON v = (\(ACID _ d x) -> checkChatType (CCID d x)) <$?> J.parseJSON v - data ACIDirection = forall c d. (ChatTypeI c, MsgDirectionI d) => ACID (SChatType c) (SMsgDirection d) (CIDirection c d) -instance FromJSON ACIDirection where - parseJSON v = jsonACIDirection <$> J.parseJSON v - data JSONCIDirection = JCIDirectSnd | JCIDirectRcv | JCIGroupSnd | JCIGroupRcv {groupMember :: GroupMember} - deriving (Generic, Show) - -instance FromJSON JSONCIDirection where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "JCI" - -instance ToJSON JSONCIDirection where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCI" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCI" - -instance (ChatTypeI c, MsgDirectionI d) => FromJSON (CIDirection c d) where - parseJSON v = (\(CCID _ x') -> checkDirection x') <$?> J.parseJSON v - -instance ToJSON (CIDirection c d) where - toJSON = J.toJSON . jsonCIDirection - toEncoding = J.toEncoding . jsonCIDirection + deriving (Show) jsonCIDirection :: CIDirection c d -> JSONCIDirection jsonCIDirection = \case @@ -239,26 +197,12 @@ jsonACIDirection = \case JCIGroupRcv m -> ACID SCTGroup SMDRcv $ CIGroupRcv m data CIReactionCount = CIReactionCount {reaction :: MsgReaction, userReacted :: Bool, totalReacted :: Int} - deriving (Show, Generic, FromJSON) - -instance ToJSON CIReactionCount where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data CChatItem c = forall d. MsgDirectionI d => CChatItem (SMsgDirection d) (ChatItem c d) deriving instance Show (CChatItem c) -instance forall c. ChatTypeI c => FromJSON (CChatItem c) where - parseJSON v = J.withObject "CChatItem" parse v - where - parse o = do - CCID d (_ :: CIDirection c d) <- o .: "chatDir" - ci <- J.parseJSON @(ChatItem c d) v - pure $ CChatItem d ci - -instance ChatTypeI c => ToJSON (CChatItem c) where - toJSON (CChatItem _ ci) = J.toJSON ci - toEncoding (CChatItem _ ci) = J.toEncoding ci - cchatItemId :: CChatItem c -> ChatItemId cchatItemId (CChatItem _ ci) = chatItemId' ci @@ -325,51 +269,25 @@ data Chat c = Chat chatItems :: [CChatItem c], chatStats :: ChatStats } - deriving (Show, Generic) - -instance ChatTypeI c => ToJSON (Chat c) where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data AChat = forall c. ChatTypeI c => AChat (SChatType c) (Chat c) deriving instance Show AChat -instance FromJSON AChat where - parseJSON = J.withObject "AChat" $ \o -> do - AChatInfo c chatInfo <- o .: "chatInfo" - chatItems <- o .: "chatItems" - chatStats <- o .: "chatStats" - pure $ AChat c Chat {chatInfo, chatItems, chatStats} - -instance ToJSON AChat where - toJSON (AChat _ c) = J.toJSON c - toEncoding (AChat _ c) = J.toEncoding c - data ChatStats = ChatStats { unreadCount :: Int, minUnreadItemId :: ChatItemId, unreadChat :: Bool } - deriving (Show, Generic, FromJSON) - -instance ToJSON ChatStats where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) -- | type to show a mix of messages from multiple chats data AChatItem = forall c d. (ChatTypeI c, MsgDirectionI d) => AChatItem (SChatType c) (SMsgDirection d) (ChatInfo c) (ChatItem c d) deriving instance Show AChatItem -instance FromJSON AChatItem where - parseJSON = J.withObject "AChatItem" $ \o -> do - AChatInfo c chatInfo <- o .: "chatInfo" - CChatItem d chatItem <- o .: "chatItem" - pure $ AChatItem c d chatInfo chatItem - -instance ToJSON AChatItem where - toJSON (AChatItem _ _ chat item) = J.toJSON $ JSONAnyChatItem chat item - toEncoding (AChatItem _ _ chat item) = J.toEncoding $ JSONAnyChatItem chat item - data JSONAnyChatItem c d = JSONAnyChatItem {chatInfo :: ChatInfo c, chatItem :: ChatItem c d} - deriving (Generic) aChatItems :: AChat -> [AChatItem] aChatItems (AChat ct Chat {chatInfo, chatItems}) = map aChatItem chatItems @@ -387,10 +305,6 @@ updateFileStatus ci@ChatItem {file} status = case file of Just f -> ci {file = Just (f :: CIFile d) {fileStatus = status}} Nothing -> ci -instance (ChatTypeI c, MsgDirectionI d) => ToJSON (JSONAnyChatItem c d) where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions - -- This type is not saved to DB, so all JSON encodings are platform-specific data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta { itemId :: ChatItemId, @@ -406,7 +320,7 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta createdAt :: UTCTime, updatedAt :: UTCTime } - deriving (Show, Generic, FromJSON) + deriving (Show) mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> UTCTime -> UTCTime -> CIMeta c d mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited itemTimed itemLive currentTs itemTs createdAt updatedAt = @@ -415,15 +329,11 @@ mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted item _ -> False in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, itemTimed, itemLive, editable, createdAt, updatedAt} -instance ChatTypeI c => ToJSON (CIMeta c d) where toEncoding = J.genericToEncoding J.defaultOptions - data CITimed = CITimed { ttl :: Int, -- seconds deleteAt :: Maybe UTCTime -- this is initially Nothing for received items, the timer starts when they are read } - deriving (Show, Generic, FromJSON) - -instance ToJSON CITimed where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) ttl' :: CITimed -> Int ttl' CITimed {ttl} = ttl @@ -457,14 +367,7 @@ data CIQuote (c :: ChatType) = CIQuote content :: MsgContent, formattedText :: Maybe MarkdownList } - deriving (Show, Generic) - -instance ChatTypeI c => FromJSON (CIQuote c) where - parseJSON = J.genericParseJSON J.defaultOptions - -instance ToJSON (CIQuote c) where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Show) data CIReaction (c :: ChatType) (d :: MsgDirection) = CIReaction { chatDir :: CIDirection c d, @@ -472,41 +375,15 @@ data CIReaction (c :: ChatType) (d :: MsgDirection) = CIReaction sentAt :: UTCTime, reaction :: MsgReaction } - deriving (Show, Generic) - -instance (ChatTypeI c, MsgDirectionI d) => FromJSON (CIReaction c d) where - parseJSON = J.genericParseJSON J.defaultOptions - -instance ChatTypeI c => ToJSON (CIReaction c d) where - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data AnyCIReaction = forall c d. ChatTypeI c => ACIR (SChatType c) (SMsgDirection d) (CIReaction c d) -instance FromJSON AnyCIReaction where - parseJSON v = J.withObject "AnyCIReaction" parse v - where - parse o = do - ACID c d (_ :: CIDirection c d) <- o .: "chatDir" - ACIR c d <$> J.parseJSON @(CIReaction c d) v - data ACIReaction = forall c d. ChatTypeI c => ACIReaction (SChatType c) (SMsgDirection d) (ChatInfo c) (CIReaction c d) deriving instance Show ACIReaction -instance FromJSON ACIReaction where - parseJSON = J.withObject "ACIReaction" $ \o -> do - ACIR c d reaction <- o .: "chatReaction" - cInfo <- o .: "chatInfo" - pure $ ACIReaction c d cInfo reaction - -instance ToJSON ACIReaction where - toJSON (ACIReaction _ _ cInfo reaction) = J.toJSON $ JSONCIReaction cInfo reaction - toEncoding (ACIReaction _ _ cInfo reaction) = J.toEncoding $ JSONCIReaction cInfo reaction - data JSONCIReaction c d = JSONCIReaction {chatInfo :: ChatInfo c, chatReaction :: CIReaction c d} - deriving (Generic) - -instance ChatTypeI c => ToJSON (JSONCIReaction c d) where toEncoding = J.genericToEncoding J.defaultOptions data CIQDirection (c :: ChatType) where CIQDirectSnd :: CIQDirection 'CTDirect @@ -518,13 +395,6 @@ deriving instance Show (CIQDirection c) data ACIQDirection = forall c. ChatTypeI c => ACIQDirection (SChatType c) (CIQDirection c) -instance ChatTypeI c => FromJSON (CIQDirection c) where - parseJSON v = (\(ACIQDirection _ x) -> checkChatType x) . jsonACIQDirection <$?> J.parseJSON v - -instance ToJSON (CIQDirection c) where - toJSON = J.toJSON . jsonCIQDirection - toEncoding = J.toEncoding . jsonCIQDirection - jsonCIQDirection :: CIQDirection c -> Maybe JSONCIDirection jsonCIQDirection = \case CIQDirectSnd -> Just JCIDirectSnd @@ -556,14 +426,7 @@ data CIFile (d :: MsgDirection) = CIFile fileStatus :: CIFileStatus d, fileProtocol :: FileProtocol } - deriving (Show, Generic) - -instance MsgDirectionI d => FromJSON (CIFile d) where - parseJSON = J.genericParseJSON J.defaultOptions - -instance MsgDirectionI d => ToJSON (CIFile d) where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Show) data FileProtocol = FPSMP | FPXFTP deriving (Eq, Show, Ord) @@ -621,17 +484,6 @@ ciFileEnded = \case CIFSRcvError -> True CIFSInvalid {} -> True -instance MsgDirectionI d => FromJSON (CIFileStatus d) where - parseJSON v = (\(AFS _ s) -> checkDirection s) . aciFileStatusJSON <$?> J.parseJSON v - -instance ToJSON (CIFileStatus d) where - toJSON = J.toJSON . jsonCIFileStatus - toEncoding = J.toEncoding . jsonCIFileStatus - -instance MsgDirectionI d => ToField (CIFileStatus d) where toField = toField . decodeLatin1 . strEncode - -instance FromField ACIFileStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 - data ACIFileStatus = forall d. MsgDirectionI d => AFS (SMsgDirection d) (CIFileStatus d) deriving instance Show ACIFileStatus @@ -689,14 +541,6 @@ data JSONCIFileStatus | JCIFSRcvCancelled | JCIFSRcvError | JCIFSInvalid {text :: Text} - deriving (Generic) - -instance FromJSON JSONCIFileStatus where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "JCIFS" - -instance ToJSON JSONCIFileStatus where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCIFS" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCIFS" jsonCIFileStatus :: CIFileStatus d -> JSONCIFileStatus jsonCIFileStatus = \case @@ -758,19 +602,6 @@ deriving instance Eq (CIStatus d) deriving instance Show (CIStatus d) -instance MsgDirectionI d => FromJSON (CIStatus d) where - parseJSON v = (\(ACIStatus _ s) -> checkDirection s) . jsonACIStatus <$?> J.parseJSON v - -instance ToJSON (CIStatus d) where - toJSON = J.toJSON . jsonCIStatus - toEncoding = J.toEncoding . jsonCIStatus - -instance MsgDirectionI d => ToField (CIStatus d) where toField = toField . decodeLatin1 . strEncode - -instance (Typeable d, MsgDirectionI d) => FromField (CIStatus d) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 - -instance FromField ACIStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 - data ACIStatus = forall d. MsgDirectionI d => ACIStatus (SMsgDirection d) (CIStatus d) deriving instance Show ACIStatus @@ -813,14 +644,7 @@ data JSONCIStatus | JCISRcvNew | JCISRcvRead | JCISInvalid {text :: Text} - deriving (Show, Generic) - -instance FromJSON JSONCIStatus where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "JCIS" - -instance ToJSON JSONCIStatus where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCIS" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCIS" + deriving (Show) jsonCIStatus :: CIStatus d -> JSONCIStatus jsonCIStatus = \case @@ -872,14 +696,7 @@ membersGroupItemStatus memStatusCounts data SndCIStatusProgress = SSPPartial | SSPComplete - deriving (Eq, Show, Generic) - -instance FromJSON SndCIStatusProgress where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "SSP" - -instance ToJSON SndCIStatusProgress where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "SSP" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "SSP" + deriving (Eq, Show) instance StrEncoding SndCIStatusProgress where strEncode = \case @@ -929,13 +746,6 @@ instance ChatTypeI 'CTContactRequest where chatTypeI = SCTContactRequest instance ChatTypeI 'CTContactConnection where chatTypeI = SCTContactConnection -instance ChatTypeI c => FromJSON (SChatType c) where - parseJSON v = (\(ACT t) -> checkChatType t) . aChatType <$?> J.parseJSON v - -instance ToJSON (SChatType c) where - toJSON = J.toJSON . toChatType - toEncoding = J.toEncoding . toChatType - toChatType :: SChatType c -> ChatType toChatType = \case SCTDirect -> CTDirect @@ -1007,9 +817,7 @@ data MsgMetaJSON = MsgMetaJSON serverTs :: UTCTime, sndId :: Int64 } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON MsgMetaJSON where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) msgMetaToJson :: MsgMeta -> MsgMetaJSON msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sndMsgId = sndId} = @@ -1022,9 +830,6 @@ msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId sndId } -msgMetaJson :: MsgMeta -> Text -msgMetaJson = decodeLatin1 . LB.toStrict . J.encode . msgMetaToJson - data MsgDeliveryStatus (d :: MsgDirection) where MDSRcvAgent :: MsgDeliveryStatus 'MDRcv MDSRcvAcknowledged :: MsgDeliveryStatus 'MDRcv @@ -1081,25 +886,11 @@ deriving instance Show (CIDeleted c) data ACIDeleted = forall c. ChatTypeI c => ACIDeleted (SChatType c) (CIDeleted c) -instance ChatTypeI c => FromJSON (CIDeleted c) where - parseJSON v = (\(ACIDeleted _ x) -> checkChatType x) . jsonACIDeleted <$?> J.parseJSON v - -instance ChatTypeI c => ToJSON (CIDeleted c) where - toJSON = J.toJSON . jsonCIDeleted - toEncoding = J.toEncoding . jsonCIDeleted - data JSONCIDeleted = JCIDDeleted {deletedTs :: Maybe UTCTime, chatType :: ChatType} | JCIDBlocked {deletedTs :: Maybe UTCTime} | JCIDModerated {deletedTs :: Maybe UTCTime, byGroupMember :: GroupMember} - deriving (Show, Generic) - -instance FromJSON JSONCIDeleted where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "JCID" - -instance ToJSON JSONCIDeleted where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCID" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCID" + deriving (Show) jsonCIDeleted :: forall d. ChatTypeI d => CIDeleted d -> JSONCIDeleted jsonCIDeleted = \case @@ -1123,9 +914,7 @@ data ChatItemInfo = ChatItemInfo { itemVersions :: [ChatItemVersion], memberDeliveryStatuses :: Maybe [MemberDeliveryStatus] } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON ChatItemInfo where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data ChatItemVersion = ChatItemVersion { chatItemVersionId :: Int64, @@ -1134,9 +923,7 @@ data ChatItemVersion = ChatItemVersion itemVersionTs :: UTCTime, createdAt :: UTCTime } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON ChatItemVersion where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) mkItemVersion :: ChatItem c d -> Maybe ChatItemVersion mkItemVersion ChatItem {content, meta} = version <$> ciMsgContent content @@ -1155,9 +942,7 @@ data MemberDeliveryStatus = MemberDeliveryStatus { groupMemberId :: GroupMemberId, memberDeliveryStatus :: CIStatus 'MDSnd } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON MemberDeliveryStatus where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data CIModeration = CIModeration { moderationId :: Int64, @@ -1166,3 +951,187 @@ data CIModeration = CIModeration moderatedAt :: UTCTime } 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 + +instance ToJSON (SChatType c) where + toJSON = J.toJSON . toChatType + toEncoding = J.toEncoding . toChatType + +$(JQ.deriveJSON defaultJSON ''ChatName) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCID") ''JSONCIDeleted) + +instance ChatTypeI c => FromJSON (CIDeleted c) where + parseJSON v = (\(ACIDeleted _ x) -> checkChatType x) . jsonACIDeleted <$?> J.parseJSON v + +instance ChatTypeI c => ToJSON (CIDeleted c) where + toJSON = J.toJSON . jsonCIDeleted + toEncoding = J.toEncoding . jsonCIDeleted + +$(JQ.deriveJSON defaultJSON ''CITimed) + +$(JQ.deriveJSON (enumJSON $ dropPrefix "SSP") ''SndCIStatusProgress) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCIS") ''JSONCIStatus) + +instance MsgDirectionI d => FromJSON (CIStatus d) where + parseJSON v = (\(ACIStatus _ s) -> checkDirection s) . jsonACIStatus <$?> J.parseJSON v + +instance ToJSON (CIStatus d) where + toJSON = J.toJSON . jsonCIStatus + toEncoding = J.toEncoding . jsonCIStatus + +instance MsgDirectionI d => ToField (CIStatus d) where toField = toField . decodeLatin1 . strEncode + +instance (Typeable d, MsgDirectionI d) => FromField (CIStatus d) where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 + +instance FromField ACIStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 + +$(JQ.deriveJSON defaultJSON ''MemberDeliveryStatus) + +$(JQ.deriveJSON defaultJSON ''ChatItemVersion) + +$(JQ.deriveJSON defaultJSON ''ChatItemInfo) + +instance (ChatTypeI c, MsgDirectionI d) => FromJSON (CIMeta c d) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''CIMeta) + +instance ChatTypeI c => ToJSON (CIMeta c d) where + toJSON = $(JQ.mkToJSON defaultJSON ''CIMeta) + toEncoding = $(JQ.mkToEncoding defaultJSON ''CIMeta) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCIFS") ''JSONCIFileStatus) + +instance MsgDirectionI d => FromJSON (CIFileStatus d) where + parseJSON v = (\(AFS _ s) -> checkDirection s) . aciFileStatusJSON <$?> J.parseJSON v + +instance ToJSON (CIFileStatus d) where + toJSON = J.toJSON . jsonCIFileStatus + toEncoding = J.toEncoding . jsonCIFileStatus + +instance MsgDirectionI d => ToField (CIFileStatus d) where toField = toField . decodeLatin1 . strEncode + +instance FromField ACIFileStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 + +instance MsgDirectionI d => FromJSON (CIFile d) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''CIFile) + +instance MsgDirectionI d => ToJSON (CIFile d) where + toJSON = $(JQ.mkToJSON defaultJSON ''CIFile) + toEncoding = $(JQ.mkToEncoding defaultJSON ''CIFile) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JCI") ''JSONCIDirection) + +instance (ChatTypeI c, MsgDirectionI d) => FromJSON (CIDirection c d) where + parseJSON v = (\(CCID _ x') -> checkDirection x') <$?> J.parseJSON v + +instance ToJSON (CIDirection c d) where + toJSON = J.toJSON . jsonCIDirection + toEncoding = J.toEncoding . jsonCIDirection + +instance ChatTypeI c => FromJSON (CCIDirection c) where + parseJSON v = (\(ACID _ d x) -> checkChatType (CCID d x)) <$?> J.parseJSON v + +instance FromJSON ACIDirection where + parseJSON v = jsonACIDirection <$> J.parseJSON v + +instance ChatTypeI c => FromJSON (CIQDirection c) where + parseJSON v = (\(ACIQDirection _ x) -> checkChatType x) . jsonACIQDirection <$?> J.parseJSON v + +instance ToJSON (CIQDirection c) where + toJSON = J.toJSON . jsonCIQDirection + toEncoding = J.toEncoding . jsonCIQDirection + +instance ChatTypeI c => FromJSON (CIQuote c) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''CIQuote) + +$(JQ.deriveToJSON defaultJSON ''CIQuote) + +$(JQ.deriveJSON defaultJSON ''CIReactionCount) + +instance (ChatTypeI c, MsgDirectionI d) => FromJSON (ChatItem c d) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''ChatItem) + +instance (ChatTypeI c, MsgDirectionI d) => ToJSON (ChatItem c d) where + toJSON = $(JQ.mkToJSON defaultJSON ''ChatItem) + toEncoding = $(JQ.mkToEncoding defaultJSON ''ChatItem) + +instance (ChatTypeI c, MsgDirectionI d) => ToJSON (JSONAnyChatItem c d) where + toJSON = $(JQ.mkToJSON defaultJSON ''JSONAnyChatItem) + toEncoding = $(JQ.mkToEncoding defaultJSON ''JSONAnyChatItem) + +instance FromJSON AChatItem where + parseJSON = J.withObject "AChatItem" $ \o -> do + AChatInfo c chatInfo <- o .: "chatInfo" + CChatItem d chatItem <- o .: "chatItem" + pure $ AChatItem c d chatInfo chatItem + +instance ToJSON AChatItem where + toJSON (AChatItem _ _ chat item) = J.toJSON $ JSONAnyChatItem chat item + toEncoding (AChatItem _ _ chat item) = J.toEncoding $ JSONAnyChatItem chat item + +instance forall c. ChatTypeI c => FromJSON (CChatItem c) where + parseJSON v = J.withObject "CChatItem" parse v + where + parse o = do + CCID d (_ :: CIDirection c d) <- o .: "chatDir" + ci <- J.parseJSON @(ChatItem c d) v + pure $ CChatItem d ci + +instance ChatTypeI c => ToJSON (CChatItem c) where + toJSON (CChatItem _ ci) = J.toJSON ci + toEncoding (CChatItem _ ci) = J.toEncoding ci + +$(JQ.deriveJSON defaultJSON ''ChatStats) + +instance ChatTypeI c => ToJSON (Chat c) where + toJSON = $(JQ.mkToJSON defaultJSON ''Chat) + toEncoding = $(JQ.mkToEncoding defaultJSON ''Chat) + +instance FromJSON AChat where + parseJSON = J.withObject "AChat" $ \o -> do + AChatInfo c chatInfo <- o .: "chatInfo" + chatItems <- o .: "chatItems" + chatStats <- o .: "chatStats" + pure $ AChat c Chat {chatInfo, chatItems, chatStats} + +instance ToJSON AChat where + toJSON (AChat _ c) = J.toJSON c + toEncoding (AChat _ c) = J.toEncoding c + +instance (ChatTypeI c, MsgDirectionI d) => FromJSON (CIReaction c d) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''CIReaction) + +instance ChatTypeI c => ToJSON (CIReaction c d) where + toJSON = $(JQ.mkToJSON defaultJSON ''CIReaction) + toEncoding = $(JQ.mkToEncoding defaultJSON ''CIReaction) + +instance FromJSON AnyCIReaction where + parseJSON v = J.withObject "AnyCIReaction" parse v + where + parse o = do + ACID c d (_ :: CIDirection c d) <- o .: "chatDir" + ACIR c d <$> J.parseJSON @(CIReaction c d) v + +instance ChatTypeI c => ToJSON (JSONCIReaction c d) where + toJSON = $(JQ.mkToJSON defaultJSON ''JSONCIReaction) + toEncoding = $(JQ.mkToEncoding defaultJSON ''JSONCIReaction) + +instance FromJSON ACIReaction where + parseJSON = J.withObject "ACIReaction" $ \o -> do + ACIR c d reaction <- o .: "chatReaction" + cInfo <- o .: "chatInfo" + pure $ ACIReaction c d cInfo reaction + +instance ToJSON ACIReaction where + toJSON (ACIReaction _ _ cInfo reaction) = J.toJSON $ JSONCIReaction cInfo reaction + toEncoding (ACIReaction _ _ cInfo reaction) = J.toEncoding $ JSONCIReaction cInfo reaction + +$(JQ.deriveJSON defaultJSON ''MsgMetaJSON) + +msgMetaJson :: MsgMeta -> Text +msgMetaJson = decodeLatin1 . LB.toStrict . J.encode . msgMetaToJson diff --git a/src/Simplex/Chat/Messages/CIContent.hs b/src/Simplex/Chat/Messages/CIContent.hs index 7836e7232a..2ca9d4ca0c 100644 --- a/src/Simplex/Chat/Messages/CIContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} @@ -14,9 +13,9 @@ module Simplex.Chat.Messages.CIContent where -import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J -import qualified Data.Aeson.TH as JQ +import qualified Data.Aeson.TH as JQ +import Data.Aeson.Types as JT import Data.Int (Int64) import Data.Text (Text) import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -24,25 +23,20 @@ import Data.Type.Equality import Data.Word (Word32) import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) -import GHC.Generics (Generic) +import Simplex.Chat.Messages.CIContent.Events import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Util import Simplex.Messaging.Agent.Protocol (MsgErrorType (..), RatchetSyncState (..), SwitchPhase (..)) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fstToLower, singleFieldJSON, sumTypeJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fstToLower, singleFieldJSON, sumTypeJSON) import Simplex.Messaging.Util (safeDecodeUtf8, tshow, (<$?>)) data MsgDirection = MDRcv | MDSnd - deriving (Eq, Show, Generic) + deriving (Eq, Show) -instance FromJSON MsgDirection where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "MD" - -instance ToJSON MsgDirection where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "MD" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MD" +$(JQ.deriveJSON (enumJSON $ dropPrefix "MD") ''MsgDirection) instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgDirection . msgDirectionIntP @@ -106,14 +100,9 @@ msgDirectionIntP = \case _ -> Nothing data CIDeleteMode = CIDMBroadcast | CIDMInternal - deriving (Show, Generic) + deriving (Show) -instance ToJSON CIDeleteMode where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "CIDM" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CIDM" - -instance FromJSON CIDeleteMode where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CIDM" +$(JQ.deriveJSON (enumJSON $ dropPrefix "CIDM") ''CIDeleteMode) ciDeleteModeToText :: CIDeleteMode -> Text ciDeleteModeToText = \case @@ -163,14 +152,7 @@ ciMsgContent = \case _ -> Nothing data MsgDecryptError = MDERatchetHeader | MDETooManySkipped | MDERatchetEarlier | MDEOther - deriving (Eq, Show, Generic) - -instance ToJSON MsgDecryptError where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "MDE" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MDE" - -instance FromJSON MsgDecryptError where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "MDE" + deriving (Eq, Show) ciRequiresAttention :: forall d. MsgDirectionI d => CIContent d -> Bool ciRequiresAttention content = case msgDirection @d of @@ -204,135 +186,14 @@ ciRequiresAttention content = case msgDirection @d of CIRcvModerated -> True CIInvalidJSON _ -> False -data RcvGroupEvent - = RGEMemberAdded {groupMemberId :: GroupMemberId, profile :: Profile} -- CRJoinedGroupMemberConnecting - | RGEMemberConnected -- CRUserJoinedGroup, CRJoinedGroupMember, CRConnectedToGroupMember - | RGEMemberLeft -- CRLeftMember - | RGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole} - | RGEUserRole {role :: GroupMemberRole} - | RGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRDeletedMember - | RGEUserDeleted -- CRDeletedMemberUser - | RGEGroupDeleted -- CRGroupDeleted - | RGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated - -- RGEInvitedViaGroupLink chat items are not received - they're created when sending group invitations, - -- but being RcvGroupEvent allows them to be assigned to the respective member (and so enable "send direct message") - -- and be created as unread without adding / working around new status for sent items - | RGEInvitedViaGroupLink -- CRSentGroupInvitationViaLink - | RGEMemberCreatedContact -- CRNewMemberContactReceivedInv - deriving (Show, Generic) - -instance FromJSON RcvGroupEvent where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RGE" - -instance ToJSON RcvGroupEvent where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RGE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RGE" - -newtype DBRcvGroupEvent = RGE RcvGroupEvent - -instance FromJSON DBRcvGroupEvent where - parseJSON v = RGE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "RGE") v - -instance ToJSON DBRcvGroupEvent where - toJSON (RGE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "RGE") v - toEncoding (RGE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "RGE") v - -data SndGroupEvent - = SGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole} - | SGEUserRole {role :: GroupMemberRole} - | SGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRUserDeletedMember - | SGEUserLeft -- CRLeftMemberUser - | SGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated - deriving (Show, Generic) - -instance FromJSON SndGroupEvent where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "SGE" - -instance ToJSON SndGroupEvent where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SGE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SGE" - -newtype DBSndGroupEvent = SGE SndGroupEvent - -instance FromJSON DBSndGroupEvent where - parseJSON v = SGE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "SGE") v - -instance ToJSON DBSndGroupEvent where - toJSON (SGE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "SGE") v - toEncoding (SGE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "SGE") v - -data RcvConnEvent - = RCESwitchQueue {phase :: SwitchPhase} - | RCERatchetSync {syncStatus :: RatchetSyncState} - | RCEVerificationCodeReset - deriving (Show, Generic) - -data SndConnEvent - = SCESwitchQueue {phase :: SwitchPhase, member :: Maybe GroupMemberRef} - | SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef} - deriving (Show, Generic) - -instance FromJSON RcvConnEvent where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RCE" - -instance ToJSON RcvConnEvent where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RCE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RCE" - -newtype DBRcvConnEvent = RCE RcvConnEvent - -instance FromJSON DBRcvConnEvent where - parseJSON v = RCE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "RCE") v - -instance ToJSON DBRcvConnEvent where - toJSON (RCE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "RCE") v - toEncoding (RCE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "RCE") v - -instance FromJSON SndConnEvent where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "SCE" - -instance ToJSON SndConnEvent where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SCE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SCE" - -newtype DBSndConnEvent = SCE SndConnEvent - -instance FromJSON DBSndConnEvent where - parseJSON v = SCE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "SCE") v - -instance ToJSON DBSndConnEvent where - toJSON (SCE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "SCE") v - toEncoding (SCE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "SCE") v - -data RcvDirectEvent = - -- RDEProfileChanged {...} - RDEContactDeleted - deriving (Show, Generic) - -instance FromJSON RcvDirectEvent where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RDE" - -instance ToJSON RcvDirectEvent where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RDE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RDE" - -newtype DBRcvDirectEvent = RDE RcvDirectEvent - -instance FromJSON DBRcvDirectEvent where - parseJSON v = RDE <$> J.genericParseJSON (singleFieldJSON $ dropPrefix "RDE") v - -instance ToJSON DBRcvDirectEvent where - toJSON (RDE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "RDE") v - toEncoding (RDE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "RDE") v - newtype DBMsgErrorType = DBME MsgErrorType instance FromJSON DBMsgErrorType where - parseJSON v = DBME <$> J.genericParseJSON (singleFieldJSON fstToLower) v + parseJSON v = DBME <$> $(JQ.mkParseJSON (singleFieldJSON fstToLower) ''MsgErrorType) v instance ToJSON DBMsgErrorType where - toJSON (DBME v) = J.genericToJSON (singleFieldJSON fstToLower) v - toEncoding (DBME v) = J.genericToEncoding (singleFieldJSON fstToLower) v + toJSON (DBME v) = $(JQ.mkToJSON (singleFieldJSON fstToLower) ''MsgErrorType) v + toEncoding (DBME v) = $(JQ.mkToEncoding (singleFieldJSON fstToLower) ''MsgErrorType) v data CIGroupInvitation = CIGroupInvitation { groupId :: GroupId, @@ -341,25 +202,14 @@ data CIGroupInvitation = CIGroupInvitation groupProfile :: GroupProfile, status :: CIGroupInvitationStatus } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON CIGroupInvitation where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) data CIGroupInvitationStatus = CIGISPending | CIGISAccepted | CIGISRejected | CIGISExpired - deriving (Eq, Show, Generic) - -instance FromJSON CIGroupInvitationStatus where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CIGIS" - -instance ToJSON CIGroupInvitationStatus where - toJSON = J.genericToJSON . enumJSON $ dropPrefix "CIGIS" - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CIGIS" + deriving (Eq, Show) ciContentToText :: CIContent d -> Text ciContentToText = \case @@ -685,6 +535,12 @@ ciCallInfoText status duration = case status of CISCallEnded -> "ended " <> durationText duration CISCallError -> "error" +$(JQ.deriveJSON (enumJSON $ dropPrefix "MDE") ''MsgDecryptError) + +$(JQ.deriveJSON (enumJSON $ dropPrefix "CIGIS") ''CIGroupInvitationStatus) + +$(JQ.deriveJSON defaultJSON ''CIGroupInvitation) + $(JQ.deriveJSON (enumJSON $ dropPrefix "CISCall") ''CICallStatus) -- platform specific diff --git a/src/Simplex/Chat/Messages/CIContent/Events.hs b/src/Simplex/Chat/Messages/CIContent/Events.hs new file mode 100644 index 0000000000..42a5add1d6 --- /dev/null +++ b/src/Simplex/Chat/Messages/CIContent/Events.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.Chat.Messages.CIContent.Events where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson.TH as J +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (RatchetSyncState (..), SwitchPhase (..)) +import Simplex.Messaging.Parsers (dropPrefix, singleFieldJSON, sumTypeJSON) + +data RcvGroupEvent + = RGEMemberAdded {groupMemberId :: GroupMemberId, profile :: Profile} -- CRJoinedGroupMemberConnecting + | RGEMemberConnected -- CRUserJoinedGroup, CRJoinedGroupMember, CRConnectedToGroupMember + | RGEMemberLeft -- CRLeftMember + | RGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole} + | RGEUserRole {role :: GroupMemberRole} + | RGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRDeletedMember + | RGEUserDeleted -- CRDeletedMemberUser + | RGEGroupDeleted -- CRGroupDeleted + | RGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated + -- RGEInvitedViaGroupLink chat items are not received - they're created when sending group invitations, + -- but being RcvGroupEvent allows them to be assigned to the respective member (and so enable "send direct message") + -- and be created as unread without adding / working around new status for sent items + | RGEInvitedViaGroupLink -- CRSentGroupInvitationViaLink + | RGEMemberCreatedContact -- CRNewMemberContactReceivedInv + deriving (Show) + +data SndGroupEvent + = SGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole} + | SGEUserRole {role :: GroupMemberRole} + | SGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRUserDeletedMember + | SGEUserLeft -- CRLeftMemberUser + | SGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated + deriving (Show) + +data RcvConnEvent + = RCESwitchQueue {phase :: SwitchPhase} + | RCERatchetSync {syncStatus :: RatchetSyncState} + | RCEVerificationCodeReset + deriving (Show) + +data SndConnEvent + = SCESwitchQueue {phase :: SwitchPhase, member :: Maybe GroupMemberRef} + | SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef} + deriving (Show) + +data RcvDirectEvent = + -- RDEProfileChanged {...} + RDEContactDeleted + deriving (Show) + +-- platform-specific JSON encoding (used in API) +$(J.deriveJSON (sumTypeJSON $ dropPrefix "RGE") ''RcvGroupEvent) + +-- platform-independent JSON encoding (stored in DB) +newtype DBRcvGroupEvent = RGE RcvGroupEvent + +instance FromJSON DBRcvGroupEvent where + parseJSON v = RGE <$> $(J.mkParseJSON (singleFieldJSON $ dropPrefix "RGE") ''RcvGroupEvent) v + +instance ToJSON DBRcvGroupEvent where + toJSON (RGE v) = $(J.mkToJSON (singleFieldJSON $ dropPrefix "RGE") ''RcvGroupEvent) v + toEncoding (RGE v) = $(J.mkToEncoding (singleFieldJSON $ dropPrefix "RGE") ''RcvGroupEvent) v + +-- platform-specific JSON encoding (used in API) +$(J.deriveJSON (sumTypeJSON $ dropPrefix "SGE") ''SndGroupEvent) + +-- platform-independent JSON encoding (stored in DB) +newtype DBSndGroupEvent = SGE SndGroupEvent + +instance FromJSON DBSndGroupEvent where + parseJSON v = SGE <$> $(J.mkParseJSON (singleFieldJSON $ dropPrefix "SGE") ''SndGroupEvent) v + +instance ToJSON DBSndGroupEvent where + toJSON (SGE v) = $(J.mkToJSON (singleFieldJSON $ dropPrefix "SGE") ''SndGroupEvent) v + toEncoding (SGE v) = $(J.mkToEncoding (singleFieldJSON $ dropPrefix "SGE") ''SndGroupEvent) v + +-- platform-specific JSON encoding (used in API) +$(J.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RcvConnEvent) + +-- platform-independent JSON encoding (stored in DB) +newtype DBRcvConnEvent = RCE RcvConnEvent + +instance FromJSON DBRcvConnEvent where + parseJSON v = RCE <$> $(J.mkParseJSON (singleFieldJSON $ dropPrefix "RCE") ''RcvConnEvent) v + +instance ToJSON DBRcvConnEvent where + toJSON (RCE v) = $(J.mkToJSON (singleFieldJSON $ dropPrefix "RCE") ''RcvConnEvent) v + toEncoding (RCE v) = $(J.mkToEncoding (singleFieldJSON $ dropPrefix "RCE") ''RcvConnEvent) v + +-- platform-specific JSON encoding (used in API) +$(J.deriveJSON (sumTypeJSON $ dropPrefix "SCE") ''SndConnEvent) + +-- platform-independent JSON encoding (stored in DB) +newtype DBSndConnEvent = SCE SndConnEvent + +instance FromJSON DBSndConnEvent where + parseJSON v = SCE <$> $(J.mkParseJSON (singleFieldJSON $ dropPrefix "SCE") ''SndConnEvent) v + +instance ToJSON DBSndConnEvent where + toJSON (SCE v) = $(J.mkToJSON (singleFieldJSON $ dropPrefix "SCE") ''SndConnEvent) v + toEncoding (SCE v) = $(J.mkToEncoding (singleFieldJSON $ dropPrefix "SCE") ''SndConnEvent) v + +$(J.deriveJSON (sumTypeJSON $ dropPrefix "RDE") ''RcvDirectEvent) + +-- platform-independent JSON encoding (stored in DB) +newtype DBRcvDirectEvent = RDE RcvDirectEvent + +instance FromJSON DBRcvDirectEvent where + parseJSON v = RDE <$> $(J.mkParseJSON (singleFieldJSON $ dropPrefix "RDE") ''RcvDirectEvent) v + +instance ToJSON DBRcvDirectEvent where + toJSON (RDE v) = $(J.mkToJSON (singleFieldJSON $ dropPrefix "RDE") ''RcvDirectEvent) v + toEncoding (RDE v) = $(J.mkToEncoding (singleFieldJSON $ dropPrefix "RDE") ''RcvDirectEvent) v diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 6203d1218c..be079af8a5 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fobject-code #-} @@ -13,8 +13,8 @@ import Control.Concurrent.STM import Control.Exception (catch, SomeException) import Control.Monad.Except import Control.Monad.Reader -import Data.Aeson (ToJSON (..)) import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ import Data.Bifunctor (first) import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) @@ -32,7 +32,6 @@ import Foreign.Ptr import Foreign.StablePtr import Foreign.Storable (poke) import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding) -import GHC.Generics (Generic) import Simplex.Chat import Simplex.Chat.Controller import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList) @@ -50,12 +49,26 @@ import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), Migrati import Simplex.Messaging.Client (defaultNetworkConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON) import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), BasicAuth (..), CorrId (..), ProtoServerWithAuth (..), ProtocolServer (..)) import Simplex.Messaging.Util (catchAll, liftEitherWith, safeDecodeUtf8) import System.IO (utf8) import System.Timeout (timeout) +data DBMigrationResult + = DBMOk + | DBMInvalidConfirmation + | DBMErrorNotADatabase {dbFile :: String} + | DBMErrorMigration {dbFile :: String, migrationError :: MigrationError} + | DBMErrorSQL {dbFile :: String, migrationSQLError :: String} + deriving (Show) + +$(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "DBM") ''DBMigrationResult) + +data APIResponse = APIResponse {corr :: Maybe CorrId, remoteHostId :: Maybe RemoteHostId, resp :: ChatResponse} + +$(JQ.deriveToJSON defaultJSON ''APIResponse) + foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString foreign export ccall "chat_close_store" cChatCloseStore :: StablePtr ChatController -> IO CString @@ -189,18 +202,6 @@ defaultMobileConfig = getActiveUser_ :: SQLiteStore -> IO (Maybe User) getActiveUser_ st = find activeUser <$> withTransaction st getUsers -data DBMigrationResult - = DBMOk - | DBMInvalidConfirmation - | DBMErrorNotADatabase {dbFile :: String} - | DBMErrorMigration {dbFile :: String, migrationError :: MigrationError} - | DBMErrorSQL {dbFile :: String, migrationSQLError :: String} - deriving (Show, Generic) - -instance ToJSON DBMigrationResult where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "DBM" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "DBM" - chatMigrateInit :: String -> String -> String -> IO (Either DBMigrationResult ChatController) chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do confirmMigrations <- liftEitherWith (const DBMInvalidConfirmation) $ strDecode $ B.pack confirm @@ -264,10 +265,3 @@ chatPasswordHash pwd salt = either (const "") passwordHash salt' where salt' = U.decode salt passwordHash = U.encode . C.sha512Hash . (pwd <>) - -data APIResponse = APIResponse {corr :: Maybe CorrId, remoteHostId :: Maybe RemoteHostId, resp :: ChatResponse} - deriving (Generic) - -instance ToJSON APIResponse where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} diff --git a/src/Simplex/Chat/Mobile/File.hs b/src/Simplex/Chat/Mobile/File.hs index 73978549ff..99860bbfa3 100644 --- a/src/Simplex/Chat/Mobile/File.hs +++ b/src/Simplex/Chat/Mobile/File.hs @@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Simplex.Chat.Mobile.File @@ -19,8 +19,8 @@ where import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class -import Data.Aeson (ToJSON) import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB @@ -32,7 +32,6 @@ import Foreign.C import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr import Foreign.Storable (poke, pokeByteOff) -import GHC.Generics (Generic) import Simplex.Chat.Mobile.Shared import Simplex.Chat.Util (chunkSize, encryptFile) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..), CryptoFileHandle, FTCryptoError (..)) @@ -45,9 +44,8 @@ import UnliftIO (Handle, IOMode (..), withFile) data WriteFileResult = WFResult {cryptoArgs :: CryptoFileArgs} | WFError {writeError :: String} - deriving (Generic) -instance ToJSON WriteFileResult where toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "WF" +$(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "WF") ''WriteFileResult) cChatWriteFile :: CString -> Ptr Word8 -> CInt -> IO CJSONString cChatWriteFile cPath ptr len = do @@ -66,9 +64,6 @@ chatWriteFile path s = do data ReadFileResult = RFResult {fileSize :: Int} | RFError {readError :: String} - deriving (Generic) - -instance ToJSON ReadFileResult where toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RF" cChatReadFile :: CString -> CString -> CString -> IO (Ptr Word8) cChatReadFile cPath cKey cNonce = do @@ -141,3 +136,5 @@ chatDecryptFile fromPath keyStr nonceStr toPath = fromLeft "" <$> runCatchExcept runCatchExceptT :: ExceptT String IO a -> IO (Either String a) runCatchExceptT action = runExceptT action `catchAll` (pure . Left . show) + +$(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "RF") ''ReadFileResult) diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 50d58b2a48..2687299350 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -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 diff --git a/src/Simplex/Chat/Remote/Protocol.hs b/src/Simplex/Chat/Remote/Protocol.hs index 65a851f718..aa4ebe5952 100644 --- a/src/Simplex/Chat/Remote/Protocol.hs +++ b/src/Simplex/Chat/Remote/Protocol.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index de54813a4d..d16955199e 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-} @@ -12,7 +11,7 @@ import Data.Int (Int64) import Data.Text (Text) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, sumTypeJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) import UnliftIO data RemoteHostClient = RemoteHostClient @@ -116,10 +115,10 @@ $(J.deriveJSON (sumTypeJSON $ dropPrefix "RPE") ''RemoteProtocolError) $(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding) -$(J.deriveJSON J.defaultOptions ''RemoteCtrlOOB) +$(J.deriveJSON defaultJSON ''RemoteCtrlOOB) -$(J.deriveJSON J.defaultOptions ''RemoteHostInfo) +$(J.deriveJSON defaultJSON ''RemoteHostInfo) -$(J.deriveJSON J.defaultOptions {J.omitNothingFields = True} ''RemoteCtrl) +$(J.deriveJSON defaultJSON ''RemoteCtrl) -$(J.deriveJSON J.defaultOptions {J.omitNothingFields = True} ''RemoteCtrlInfo) +$(J.deriveJSON defaultJSON ''RemoteCtrlInfo) diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index d4ca3193b3..99689b29d1 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -1,10 +1,10 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -61,8 +61,7 @@ where import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import Data.Functor (($>)) import Data.Int (Int64) import qualified Data.List.NonEmpty as L @@ -73,7 +72,6 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (UTCTime (..), getCurrentTime) import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..)) import Database.SQLite.Simple.QQ (sql) -import GHC.Generics (Generic) import Simplex.Chat.Call import Simplex.Chat.Messages import Simplex.Chat.Protocol @@ -86,6 +84,7 @@ import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode) import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Util (safeDecodeUtf8) @@ -400,17 +399,17 @@ data UserContactLink = UserContactLink { connReqContact :: ConnReqContact, autoAccept :: Maybe AutoAccept } - deriving (Show, Generic, FromJSON) - -instance ToJSON UserContactLink where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data AutoAccept = AutoAccept { acceptIncognito :: IncognitoEnabled, autoReply :: Maybe MsgContent } - deriving (Show, Generic, FromJSON) + deriving (Show) -instance ToJSON AutoAccept where toEncoding = J.genericToEncoding J.defaultOptions +$(J.deriveJSON defaultJSON ''AutoAccept) + +$(J.deriveJSON defaultJSON ''UserContactLink) toUserContactLink :: (ConnReqContact, Bool, IncognitoEnabled, Maybe MsgContent) -> UserContactLink toUserContactLink (connReq, autoAccept, acceptIncognito, autoReply) = diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index d00dce718e..7c1f07191d 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -1,11 +1,11 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} module Simplex.Chat.Store.Shared where @@ -16,8 +16,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG, randomBytesGenerate) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) @@ -28,7 +27,6 @@ import Data.Time.Clock (UTCTime (..), getCurrentTime) import Database.SQLite.Simple (NamedParam (..), Only (..), Query, SQLError, (:.) (..)) import qualified Database.SQLite.Simple as SQL import Database.SQLite.Simple.QQ (sql) -import GHC.Generics (Generic) import Simplex.Chat.Messages import Simplex.Chat.Protocol import Simplex.Chat.Remote.Types @@ -103,14 +101,9 @@ data StoreError | SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId} | SERemoteHostNotFound {remoteHostId :: RemoteHostId} | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId} - deriving (Show, Exception, Generic) + deriving (Show, Exception) -instance FromJSON StoreError where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "SE" - -instance ToJSON StoreError where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SE" +$(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError) insertedRowId :: DB.Connection -> IO Int64 insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()" diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index b3c4ea09b2..057067d85a 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -45,14 +44,13 @@ import Database.SQLite.Simple.FromField (returnError, FromField(..)) import Database.SQLite.Simple.Internal (Field (..)) import Database.SQLite.Simple.Ok import Database.SQLite.Simple.ToField (ToField (..)) -import GHC.Generics (Generic) import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Util import Simplex.FileTransfer.Description (FileDigest) import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId) import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON) import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI) import Simplex.Messaging.Util ((<$?>)) import Simplex.Messaging.Version @@ -264,9 +262,7 @@ data UserContact = UserContact connReqContact :: ConnReqContact, groupId :: Maybe GroupId } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON UserContact where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) userContactGroupId :: UserContact -> Maybe GroupId userContactGroupId UserContact {groupId} = groupId @@ -284,10 +280,7 @@ data UserContactRequest = UserContactRequest updatedAt :: UTCTime, xContactId :: Maybe XContactId } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON UserContactRequest where - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) newtype XContactId = XContactId ByteString deriving (Eq, Show) @@ -341,9 +334,7 @@ optionalFullName displayName fullName | otherwise = " (" <> fullName <> ")" data Group = Group {groupInfo :: GroupInfo, members :: [GroupMember]} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON Group where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) type GroupId = Int64 @@ -359,9 +350,7 @@ data GroupInfo = GroupInfo updatedAt :: UTCTime, chatTs :: Maybe UTCTime } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON GroupInfo where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) groupName' :: GroupInfo -> GroupName groupName' GroupInfo {localDisplayName = g} = g @@ -369,9 +358,7 @@ groupName' GroupInfo {localDisplayName = g} = g data GroupSummary = GroupSummary { currentMembers :: Int } - deriving (Show, Generic, FromJSON) - -instance ToJSON GroupSummary where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) data ContactOrGroup = CGContact Contact | CGGroup Group @@ -386,9 +373,7 @@ data ChatSettings = ChatSettings sendRcpts :: Maybe Bool, favorite :: Bool } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) defaultChatSettings :: ChatSettings defaultChatSettings = @@ -402,18 +387,7 @@ chatHasNtfs :: ChatSettings -> Bool chatHasNtfs ChatSettings {enableNtfs} = enableNtfs /= MFNone data MsgFilter = MFNone | MFAll | MFMentions - deriving (Eq, Show, Generic) - -instance FromJSON MsgFilter where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "MF" - -instance ToJSON MsgFilter where - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MF" - toJSON = J.genericToJSON . enumJSON $ dropPrefix "MF" - -instance FromField MsgFilter where fromField = fromIntField_ msgFilterIntP - -instance ToField MsgFilter where toField = toField . msgFilterInt + deriving (Eq, Show) msgFilterInt :: MsgFilter -> Int msgFilterInt = \case @@ -496,11 +470,7 @@ data Profile = Profile -- - incognito -- - local_alias } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON Profile where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) -- check if profiles match ignoring preferences profilesMatch :: LocalProfile -> LocalProfile -> Bool @@ -522,11 +492,7 @@ data LocalProfile = LocalProfile preferences :: Maybe Preferences, localAlias :: LocalAlias } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON LocalProfile where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) localProfileId :: LocalProfile -> ProfileId localProfileId LocalProfile{profileId} = profileId @@ -546,11 +512,7 @@ data GroupProfile = GroupProfile image :: Maybe ImageData, groupPreferences :: Maybe GroupPreferences } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON GroupProfile where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) newtype ImageData = ImageData Text deriving (Eq, Show) @@ -567,14 +529,6 @@ instance ToField ImageData where toField (ImageData t) = toField t instance FromField ImageData where fromField = fmap ImageData . fromField data CReqClientData = CRDataGroup {groupLinkId :: GroupLinkId} - deriving (Generic) - -instance ToJSON CReqClientData where - toJSON = J.genericToJSON . taggedObjectJSON $ dropPrefix "CRData" - toEncoding = J.genericToEncoding . taggedObjectJSON $ dropPrefix "CRData" - -instance FromJSON CReqClientData where - parseJSON = J.genericParseJSON . taggedObjectJSON $ dropPrefix "CRData" newtype GroupLinkId = GroupLinkId {unGroupLinkId :: ByteString} -- used to identify invitation via group link deriving (Eq, Show) @@ -602,29 +556,19 @@ data GroupInvitation = GroupInvitation groupProfile :: GroupProfile, groupLinkId :: Maybe GroupLinkId } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON GroupInvitation where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) data MemberIdRole = MemberIdRole { memberId :: MemberId, memberRole :: GroupMemberRole } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON MemberIdRole where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data IntroInvitation = IntroInvitation { groupConnReq :: ConnReqInvitation, directConnReq :: Maybe ConnReqInvitation } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON IntroInvitation where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) data MemberInfo = MemberInfo { memberId :: MemberId, @@ -632,11 +576,7 @@ data MemberInfo = MemberInfo v :: Maybe ChatVersionRange, profile :: Profile } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON MemberInfo where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) memberInfo :: GroupMember -> MemberInfo memberInfo GroupMember {memberId, memberRole, memberProfile, activeConn} = @@ -675,16 +615,10 @@ data GroupMember = GroupMember memberContactProfileId :: ProfileId, activeConn :: Maybe Connection } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON GroupMember where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) data GroupMemberRef = GroupMemberRef {groupMemberId :: Int64, profile :: Profile} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON GroupMemberRef where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) groupMemberRef :: GroupMember -> GroupMemberRef groupMemberRef GroupMember {groupMemberId, memberProfile = p} = @@ -744,14 +678,7 @@ instance ToJSON MemberId where toEncoding = strToJEncoding data InvitedBy = IBContact {byContactId :: Int64} | IBUser | IBUnknown - deriving (Eq, Show, Generic) - -instance FromJSON InvitedBy where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "IB" - -instance ToJSON InvitedBy where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "IB" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "IB" + deriving (Eq, Show) toInvitedBy :: Int64 -> Maybe Int64 -> InvitedBy toInvitedBy userCtId (Just ctId) @@ -803,9 +730,7 @@ instance ToJSON GroupMemberRole where data GroupMemberSettings = GroupMemberSettings { showMessages :: Bool } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON GroupMemberSettings where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) defaultMemberSettings :: GroupMemberSettings defaultMemberSettings = GroupMemberSettings {showMessages = True} @@ -986,9 +911,7 @@ data SndFileTransfer = SndFileTransfer fileDescrId :: Maybe Int64, fileInline :: Maybe InlineFileMode } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON SndFileTransfer where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) sndFileTransferConnId :: SndFileTransfer -> ConnId sndFileTransferConnId SndFileTransfer {agentConnId = AgentConnId acId} = acId @@ -1003,24 +926,10 @@ data FileInvitation = FileInvitation fileInline :: Maybe InlineFileMode, fileDescr :: Maybe FileDescr } - deriving (Eq, Show, Generic) - -instance ToJSON FileInvitation where - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - -instance FromJSON FileInvitation where - parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) data FileDescr = FileDescr {fileDescrText :: Text, fileDescrPartNo :: Int, fileDescrComplete :: Bool} - deriving (Eq, Show, Generic) - -instance ToJSON FileDescr where - toEncoding = J.genericToEncoding J.defaultOptions - toJSON = J.genericToJSON J.defaultOptions - -instance FromJSON FileDescr where - parseJSON = J.genericParseJSON J.defaultOptions + deriving (Eq, Show) xftpFileInvitation :: FilePath -> Integer -> FileDescr -> FileInvitation xftpFileInvitation fileName fileSize fileDescr = @@ -1036,7 +945,7 @@ xftpFileInvitation fileName fileSize fileDescr = data InlineFileMode = IFMOffer -- file will be sent inline once accepted | IFMSent -- file is sent inline without acceptance - deriving (Eq, Show, Generic) + deriving (Eq, Show) instance TextEncoding InlineFileMode where textEncode = \case @@ -1072,18 +981,14 @@ data RcvFileTransfer = RcvFileTransfer -- SMP files are encrypted after all chunks are received cryptoArgs :: Maybe CryptoFileArgs } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON RcvFileTransfer where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data XFTPRcvFile = XFTPRcvFile { rcvFileDescription :: RcvFileDescr, agentRcvFileId :: Maybe AgentRcvFileId, agentRcvFileDeleted :: Bool } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON XFTPRcvFile where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data RcvFileDescr = RcvFileDescr { fileDescrId :: Int64, @@ -1091,9 +996,7 @@ data RcvFileDescr = RcvFileDescr fileDescrPartNo :: Int, fileDescrComplete :: Bool } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON RcvFileDescr where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data RcvFileStatus = RFSNew @@ -1101,14 +1004,7 @@ data RcvFileStatus | RFSConnected RcvFileInfo | RFSComplete RcvFileInfo | RFSCancelled (Maybe RcvFileInfo) - deriving (Eq, Show, Generic) - -instance FromJSON RcvFileStatus where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RFS" - -instance ToJSON RcvFileStatus where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RFS" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RFS" + deriving (Eq, Show) rcvFileComplete :: RcvFileStatus -> Bool rcvFileComplete = \case @@ -1123,9 +1019,7 @@ data RcvFileInfo = RcvFileInfo connId :: Maybe Int64, agentConnId :: Maybe AgentConnId } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON RcvFileInfo where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) liveRcvFileTransferInfo :: RcvFileTransfer -> Maybe RcvFileInfo liveRcvFileTransferInfo RcvFileTransfer {fileStatus} = case fileStatus of @@ -1226,14 +1120,7 @@ data FileTransfer sndFileTransfers :: [SndFileTransfer] } | FTRcv {rcvFileTransfer :: RcvFileTransfer} - deriving (Show, Generic) - -instance FromJSON FileTransfer where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "FT" - -instance ToJSON FileTransfer where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "FT" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "FT" + deriving (Show) data FileTransferMeta = FileTransferMeta { fileId :: FileTransferId, @@ -1245,9 +1132,7 @@ data FileTransferMeta = FileTransferMeta chunkSize :: Integer, cancelled :: Bool } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON FileTransferMeta where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data XFTPSndFile = XFTPSndFile { agentSndFileId :: AgentSndFileId, @@ -1255,9 +1140,7 @@ data XFTPSndFile = XFTPSndFile agentSndFileDeleted :: Bool, cryptoArgs :: Maybe CryptoFileArgs } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON XFTPSndFile where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) fileTransferCancelled :: FileTransfer -> Bool fileTransferCancelled (FTSnd FileTransferMeta {cancelled} _) = cancelled @@ -1318,7 +1201,7 @@ data Connection = Connection authErrCounter :: Int, createdAt :: UTCTime } - deriving (Eq, Show, Generic) + deriving (Eq, Show) connReady :: Connection -> Bool connReady Connection {connStatus} = connStatus == ConnReady || connStatus == ConnSndReady @@ -1330,9 +1213,7 @@ connDisabled :: Connection -> Bool connDisabled Connection {authErrCounter} = authErrCounter >= authErrDisableCount data SecurityCode = SecurityCode {securityCode :: Text, verifiedAt :: UTCTime} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON SecurityCode where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) verificationCode :: ByteString -> Text verificationCode = T.pack . unwords . chunks 5 . show . os2ip @@ -1351,13 +1232,6 @@ aConnId Connection {agentConnId = AgentConnId cId} = cId connIncognito :: Connection -> Bool connIncognito Connection {customUserProfileId} = isJust customUserProfileId -instance FromJSON Connection where - parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True} - -instance ToJSON Connection where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - data PendingContactConnection = PendingContactConnection { pccConnId :: Int64, pccAgentConnId :: AgentConnId, @@ -1371,13 +1245,11 @@ data PendingContactConnection = PendingContactConnection createdAt :: UTCTime, updatedAt :: UTCTime } - deriving (Eq, Show, Generic, FromJSON) + deriving (Eq, Show) aConnId' :: PendingContactConnection -> ConnId aConnId' PendingContactConnection {pccAgentConnId = AgentConnId cId} = cId -instance ToJSON PendingContactConnection where toEncoding = J.genericToEncoding J.defaultOptions - data ConnStatus = -- | connection is created by initiating party with agent NEW command (createConnection) ConnNew @@ -1512,7 +1384,7 @@ data NetworkStatus | NSConnected | NSDisconnected | NSError {connectionError :: String} - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show) netStatusStr :: NetworkStatus -> String netStatusStr = \case @@ -1521,20 +1393,11 @@ netStatusStr = \case NSDisconnected -> "disconnected" NSError e -> "error: " <> e -instance FromJSON NetworkStatus where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "NS" - -instance ToJSON NetworkStatus where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "NS" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "NS" - data ConnNetworkStatus = ConnNetworkStatus { agentConnId :: AgentConnId, networkStatus :: NetworkStatus } - deriving (Show, Generic, FromJSON) - -instance ToJSON ConnNetworkStatus where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Show) type CommandId = Int64 @@ -1548,7 +1411,7 @@ data CommandStatus = CSCreated | CSCompleted -- unused - was replaced with deleteCommand | CSError -- internal command error, e.g. not matching connection id or unexpected response, not related to agent message ERR - deriving (Show, Generic) + deriving (Show) instance FromField CommandStatus where fromField = fromTextField_ textDecode @@ -1575,7 +1438,7 @@ data CommandFunction | CFAcceptContact | CFAckMessage | CFDeleteConn -- not used - deriving (Eq, Show, Generic) + deriving (Eq, Show) instance FromField CommandFunction where fromField = fromTextField_ textDecode @@ -1641,14 +1504,7 @@ data ServerCfg p = ServerCfg tested :: Maybe Bool, enabled :: Bool } - deriving (Show, Generic) - -instance ProtocolTypeI p => ToJSON (ServerCfg p) where - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - -instance ProtocolTypeI p => FromJSON (ServerCfg p) where - parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True} + deriving (Show) newtype ChatVersionRange = ChatVersionRange {fromChatVRange :: VersionRange} deriving (Eq, Show) @@ -1674,14 +1530,95 @@ instance ToJSON JVersionRange where toJSON (JVersionRange (VersionRange minV maxV)) = J.object ["minVersion" .= minV, "maxVersion" .= maxV] toEncoding (JVersionRange (VersionRange minV maxV)) = J.pairs $ "minVersion" .= minV <> "maxVersion" .= maxV -$(JQ.deriveJSON defOpts ''UserPwdHash) +$(JQ.deriveJSON defaultJSON ''UserContact) -$(JQ.deriveJSON defOpts ''User) +$(JQ.deriveJSON defaultJSON ''Profile) -$(JQ.deriveJSON defOpts ''NewUser) +$(JQ.deriveJSON defaultJSON ''LocalProfile) -$(JQ.deriveJSON defOpts ''UserInfo) +$(JQ.deriveJSON defaultJSON ''UserContactRequest) -$(JQ.deriveJSON defOpts ''Contact) +$(JQ.deriveJSON defaultJSON ''GroupProfile) -$(JQ.deriveJSON defOpts ''ContactRef) +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "IB") ''InvitedBy) + +$(JQ.deriveJSON defaultJSON ''GroupMemberSettings) + +$(JQ.deriveJSON defaultJSON ''SecurityCode) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "NS") ''NetworkStatus) + +$(JQ.deriveJSON defaultJSON ''ConnNetworkStatus) + +$(JQ.deriveJSON defaultJSON ''Connection) + +$(JQ.deriveJSON defaultJSON ''PendingContactConnection) + +$(JQ.deriveJSON defaultJSON ''GroupMember) + +$(JQ.deriveJSON (enumJSON $ dropPrefix "MF") ''MsgFilter) + +$(JQ.deriveJSON defaultJSON ''ChatSettings) + +$(JQ.deriveJSON defaultJSON ''GroupInfo) + +$(JQ.deriveJSON defaultJSON ''Group) + +$(JQ.deriveJSON defaultJSON ''GroupSummary) + +instance FromField MsgFilter where fromField = fromIntField_ msgFilterIntP + +instance ToField MsgFilter where toField = toField . msgFilterInt + +$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "CRData") ''CReqClientData) + +$(JQ.deriveJSON defaultJSON ''MemberIdRole) + +$(JQ.deriveJSON defaultJSON ''GroupInvitation) + +$(JQ.deriveJSON defaultJSON ''IntroInvitation) + +$(JQ.deriveJSON defaultJSON ''MemberInfo) + +$(JQ.deriveJSON defaultJSON ''GroupMemberRef) + +$(JQ.deriveJSON defaultJSON ''FileDescr) + +$(JQ.deriveJSON defaultJSON ''FileInvitation) + +$(JQ.deriveJSON defaultJSON ''SndFileTransfer) + +$(JQ.deriveJSON defaultJSON ''RcvFileDescr) + +$(JQ.deriveJSON defaultJSON ''XFTPRcvFile) + +$(JQ.deriveJSON defaultJSON ''RcvFileInfo) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RFS") ''RcvFileStatus) + +$(JQ.deriveJSON defaultJSON ''RcvFileTransfer) + +$(JQ.deriveJSON defaultJSON ''XFTPSndFile) + +$(JQ.deriveJSON defaultJSON ''FileTransferMeta) + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "FT") ''FileTransfer) + +$(JQ.deriveJSON defaultJSON ''UserPwdHash) + +$(JQ.deriveJSON defaultJSON ''User) + +$(JQ.deriveJSON defaultJSON ''NewUser) + +$(JQ.deriveJSON defaultJSON ''UserInfo) + +$(JQ.deriveJSON defaultJSON ''Contact) + +$(JQ.deriveJSON defaultJSON ''ContactRef) + +instance ProtocolTypeI p => ToJSON (ServerCfg p) where + toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerCfg) + toJSON = $(JQ.mkToJSON defaultJSON ''ServerCfg) + +instance ProtocolTypeI p => FromJSON (ServerCfg p) where + parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerCfg) diff --git a/src/Simplex/Chat/Types/Preferences.hs b/src/Simplex/Chat/Types/Preferences.hs index c7555e18a8..da13da742f 100644 --- a/src/Simplex/Chat/Types/Preferences.hs +++ b/src/Simplex/Chat/Types/Preferences.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -12,6 +11,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} @@ -24,7 +24,7 @@ module Simplex.Chat.Types.Preferences where import Control.Applicative ((<|>)) import Data.Aeson (FromJSON (..), ToJSON (..)) -import qualified Data.Aeson as J +import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Data.Maybe (fromMaybe, isJust) @@ -32,11 +32,10 @@ import Data.Text (Text) import qualified Data.Text as T import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) -import GHC.Generics (Generic) import GHC.Records.Compat import Simplex.Chat.Types.Util import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, sumTypeJSON) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON) import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>)) data ChatFeature @@ -45,7 +44,7 @@ data ChatFeature | CFReactions | CFVoice | CFCalls - deriving (Show, Generic) + deriving (Show) data SChatFeature (f :: ChatFeature) where SCFTimedMessages :: SChatFeature 'CFTimedMessages @@ -71,13 +70,6 @@ chatFeatureNameText = \case chatFeatureNameText' :: SChatFeature f -> Text chatFeatureNameText' = chatFeatureNameText . chatFeature -instance ToJSON ChatFeature where - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CF" - toJSON = J.genericToJSON . enumJSON $ dropPrefix "CF" - -instance FromJSON ChatFeature where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CF" - allChatFeatures :: [AChatFeature] allChatFeatures = [ ACF SCFTimedMessages, @@ -149,17 +141,7 @@ data Preferences = Preferences voice :: Maybe VoicePreference, calls :: Maybe CallsPreference } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON Preferences where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - -instance ToField Preferences where - toField = toField . encodeJSON - -instance FromField Preferences where - fromField = fromTextField_ decodeJSON + deriving (Eq, Show) data GroupFeature = GFTimedMessages @@ -168,7 +150,7 @@ data GroupFeature | GFReactions | GFVoice | GFFiles - deriving (Show, Generic) + deriving (Show) data SGroupFeature (f :: GroupFeature) where SGFTimedMessages :: SGroupFeature 'GFTimedMessages @@ -200,13 +182,6 @@ groupFeatureAllowed' :: GroupFeatureI f => SGroupFeature f -> FullGroupPreferenc groupFeatureAllowed' feature prefs = getField @"enable" (getGroupPreference feature prefs) == FEOn -instance ToJSON GroupFeature where - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "GF" - toJSON = J.genericToJSON . enumJSON $ dropPrefix "GF" - -instance FromJSON GroupFeature where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "GF" - allGroupFeatures :: [AGroupFeature] allGroupFeatures = [ AGF SGFTimedMessages, @@ -263,17 +238,7 @@ data GroupPreferences = GroupPreferences voice :: Maybe VoiceGroupPreference, files :: Maybe FilesGroupPreference } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON GroupPreferences where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - -instance ToField GroupPreferences where - toField = toField . encodeJSON - -instance FromField GroupPreferences where - fromField = fromTextField_ decodeJSON + deriving (Eq, Show) setGroupPreference :: forall f. GroupFeatureI f => SGroupFeature f -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences setGroupPreference f enable prefs_ = setGroupPreference_ f pref prefs @@ -312,9 +277,7 @@ data FullPreferences = FullPreferences voice :: VoicePreference, calls :: CallsPreference } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON FullPreferences where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) -- full collection of group preferences defined in the app - it is used to ensure we include all preferences and to simplify processing -- if some of the preferences are not defined in GroupPreferences, defaults from defaultGroupPrefs are used here. @@ -326,9 +289,7 @@ data FullGroupPreferences = FullGroupPreferences voice :: VoiceGroupPreference, files :: FilesGroupPreference } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON FullGroupPreferences where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) -- merged preferences of user for a given contact - they differentiate between specific preferences for the contact and global user preferences data ContactUserPreferences = ContactUserPreferences @@ -338,30 +299,17 @@ data ContactUserPreferences = ContactUserPreferences voice :: ContactUserPreference VoicePreference, calls :: ContactUserPreference CallsPreference } - deriving (Eq, Show, Generic, FromJSON) + deriving (Eq, Show) data ContactUserPreference p = ContactUserPreference { enabled :: PrefEnabled, userPreference :: ContactUserPref p, contactPreference :: p } - deriving (Eq, Show, Generic) + deriving (Eq, Show) data ContactUserPref p = CUPContact {preference :: p} | CUPUser {preference :: p} - deriving (Eq, Show, Generic) - -instance ToJSON ContactUserPreferences where toEncoding = J.genericToEncoding J.defaultOptions - -instance FromJSON p => FromJSON (ContactUserPreference p) where parseJSON = J.genericParseJSON J.defaultOptions - -instance ToJSON p => ToJSON (ContactUserPreference p) where toEncoding = J.genericToEncoding J.defaultOptions - -instance FromJSON p => FromJSON (ContactUserPref p) where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "CUP" - -instance ToJSON p => ToJSON (ContactUserPref p) where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CUP" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CUP" + deriving (Eq, Show) toChatPrefs :: FullPreferences -> Preferences toChatPrefs FullPreferences {timedMessages, fullDelete, reactions, voice, calls} = @@ -404,31 +352,19 @@ data TimedMessagesPreference = TimedMessagesPreference { allow :: FeatureAllowed, ttl :: Maybe Int } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON TimedMessagesPreference where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + deriving (Eq, Show) data FullDeletePreference = FullDeletePreference {allow :: FeatureAllowed} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON FullDeletePreference where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data ReactionsPreference = ReactionsPreference {allow :: FeatureAllowed} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON ReactionsPreference where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data VoicePreference = VoicePreference {allow :: FeatureAllowed} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON VoicePreference where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) data CallsPreference = CallsPreference {allow :: FeatureAllowed} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON CallsPreference where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) class (Eq (FeaturePreference f), HasField "allow" (FeaturePreference f) FeatureAllowed) => FeatureI f where type FeaturePreference (f :: ChatFeature) = p | p -> f @@ -477,47 +413,33 @@ instance FeatureI 'CFCalls where data GroupPreference = GroupPreference {enable :: GroupFeatureEnabled} - deriving (Eq, Show, Generic, FromJSON) + deriving (Eq, Show) data TimedMessagesGroupPreference = TimedMessagesGroupPreference { enable :: GroupFeatureEnabled, ttl :: Maybe Int } - deriving (Eq, Show, Generic, FromJSON) + deriving (Eq, Show) data DirectMessagesGroupPreference = DirectMessagesGroupPreference {enable :: GroupFeatureEnabled} - deriving (Eq, Show, Generic, FromJSON) + deriving (Eq, Show) data FullDeleteGroupPreference = FullDeleteGroupPreference {enable :: GroupFeatureEnabled} - deriving (Eq, Show, Generic, FromJSON) + deriving (Eq, Show) data ReactionsGroupPreference = ReactionsGroupPreference {enable :: GroupFeatureEnabled} - deriving (Eq, Show, Generic, FromJSON) + deriving (Eq, Show) data VoiceGroupPreference = VoiceGroupPreference {enable :: GroupFeatureEnabled} - deriving (Eq, Show, Generic, FromJSON) + deriving (Eq, Show) data FilesGroupPreference = FilesGroupPreference {enable :: GroupFeatureEnabled} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON GroupPreference where toEncoding = J.genericToEncoding J.defaultOptions - -instance ToJSON TimedMessagesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions - -instance ToJSON DirectMessagesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions - -instance ToJSON ReactionsGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions - -instance ToJSON FullDeleteGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions - -instance ToJSON VoiceGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions - -instance ToJSON FilesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference f) GroupFeatureEnabled) => GroupFeatureI f where type GroupFeaturePreference (f :: GroupFeature) = p | p -> f @@ -619,7 +541,7 @@ data FeatureAllowed = FAAlways -- allow unconditionally | FAYes -- allow, if peer allows it | FANo -- do not allow - deriving (Eq, Show, Generic) + deriving (Eq, Show) instance FromField FeatureAllowed where fromField = fromBlobField_ strDecode @@ -645,7 +567,7 @@ instance ToJSON FeatureAllowed where toEncoding = strToJEncoding data GroupFeatureEnabled = FEOn | FEOff - deriving (Eq, Show, Generic) + deriving (Eq, Show) instance FromField GroupFeatureEnabled where fromField = fromBlobField_ strDecode @@ -718,11 +640,7 @@ toGroupPreferences groupPreferences = pref f = Just $ getGroupPreference f groupPreferences data PrefEnabled = PrefEnabled {forUser :: Bool, forContact :: Bool} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON PrefEnabled where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions + deriving (Eq, Show) prefEnabled :: FeatureI f => Bool -> FeaturePreference f -> FeaturePreference f -> PrefEnabled prefEnabled asymmetric user contact = case (getField @"allow" user, getField @"allow" contact) of @@ -784,3 +702,69 @@ getContactUserPreference f ps = case f of SCFReactions -> ps.reactions SCFVoice -> ps.voice SCFCalls -> ps.calls + +$(J.deriveJSON (enumJSON $ dropPrefix "CF") ''ChatFeature) + +$(J.deriveJSON (enumJSON $ dropPrefix "GF") ''GroupFeature) + +$(J.deriveJSON defaultJSON ''TimedMessagesPreference) + +$(J.deriveJSON defaultJSON ''FullDeletePreference) + +$(J.deriveJSON defaultJSON ''ReactionsPreference) + +$(J.deriveJSON defaultJSON ''VoicePreference) + +$(J.deriveJSON defaultJSON ''CallsPreference) + +$(J.deriveJSON defaultJSON ''Preferences) + +instance ToField Preferences where + toField = toField . encodeJSON + +instance FromField Preferences where + fromField = fromTextField_ decodeJSON + +$(J.deriveJSON defaultJSON ''GroupPreference) + +$(J.deriveJSON defaultJSON ''TimedMessagesGroupPreference) + +$(J.deriveJSON defaultJSON ''DirectMessagesGroupPreference) + +$(J.deriveJSON defaultJSON ''ReactionsGroupPreference) + +$(J.deriveJSON defaultJSON ''FullDeleteGroupPreference) + +$(J.deriveJSON defaultJSON ''VoiceGroupPreference) + +$(J.deriveJSON defaultJSON ''FilesGroupPreference) + +$(J.deriveJSON defaultJSON ''GroupPreferences) + +instance ToField GroupPreferences where + toField = toField . encodeJSON + +instance FromField GroupPreferences where + fromField = fromTextField_ decodeJSON + +$(J.deriveJSON defaultJSON ''FullPreferences) + +$(J.deriveJSON defaultJSON ''FullGroupPreferences) + +$(J.deriveJSON defaultJSON ''PrefEnabled) + +instance FromJSON p => FromJSON (ContactUserPref p) where + parseJSON = $(J.mkParseJSON (sumTypeJSON $ dropPrefix "CUP") ''ContactUserPref) + +instance ToJSON p => ToJSON (ContactUserPref p) where + toJSON = $(J.mkToJSON (sumTypeJSON $ dropPrefix "CUP") ''ContactUserPref) + toEncoding = $(J.mkToEncoding (sumTypeJSON $ dropPrefix "CUP") ''ContactUserPref) + +instance FromJSON p => FromJSON (ContactUserPreference p) where + parseJSON = $(J.mkParseJSON defaultJSON ''ContactUserPreference) + +instance ToJSON p => ToJSON (ContactUserPreference p) where + toJSON = $(J.mkToJSON defaultJSON ''ContactUserPreference) + toEncoding = $(J.mkToEncoding defaultJSON ''ContactUserPreference) + +$(J.deriveJSON defaultJSON ''ContactUserPreferences) diff --git a/src/Simplex/Chat/Types/Util.hs b/src/Simplex/Chat/Types/Util.hs index 8681e99086..fffdd24b9e 100644 --- a/src/Simplex/Chat/Types/Util.hs +++ b/src/Simplex/Chat/Types/Util.hs @@ -28,6 +28,3 @@ fromBlobField_ p = \case Right k -> Ok k Left e -> returnError ConversionFailed f ("could not parse field: " ++ e) f -> returnError ConversionFailed f "expecting SQLBlob column type" - -defOpts :: J.Options -defOpts = J.defaultOptions {J.omitNothingFields = True} diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 501e232a60..2a3b74da37 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -7,12 +6,13 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} module Simplex.Chat.View where -import Data.Aeson (ToJSON) import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace, toUpper) @@ -31,7 +31,6 @@ import Data.Time (LocalTime (..), TimeOfDay (..), TimeZone (..), utcToLocalTime) import Data.Time.Calendar (addDays) import Data.Time.Clock (UTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) -import GHC.Generics (Generic) import qualified Network.HTTP.Types as Q import Numeric (showFFloat) import Simplex.Chat (defaultChatConfig, maxImageSize) @@ -66,6 +65,13 @@ import System.Console.ANSI.Types type CurrentTime = UTCTime +data WCallCommand + = WCCallStart {media :: CallMedia, aesKey :: Maybe String, useWorker :: Bool} + | WCCallOffer {offer :: Text, iceCandidates :: Text, media :: CallMedia, aesKey :: Maybe String, useWorker :: Bool} + | WCCallAnswer {answer :: Text, iceCandidates :: Text} + +$(JQ.deriveToJSON (taggedObjectJSON $ dropPrefix "WCCall") ''WCallCommand) + serializeChatResponse :: (Maybe RemoteHostId, Maybe User) -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> String serializeChatResponse user_ ts tz remoteHost_ = unlines . map unStyle . responseToView user_ defaultChatConfig False ts tz remoteHost_ @@ -1633,16 +1639,6 @@ supporedBrowsers callType | encryptedCall callType = " (only Chrome and Safari support e2e encryption for WebRTC, Safari may require enabling WebRTC insertable streams)" | otherwise = "" -data WCallCommand - = WCCallStart {media :: CallMedia, aesKey :: Maybe String, useWorker :: Bool} - | WCCallOffer {offer :: Text, iceCandidates :: Text, media :: CallMedia, aesKey :: Maybe String, useWorker :: Bool} - | WCCallAnswer {answer :: Text, iceCandidates :: Text} - deriving (Generic) - -instance ToJSON WCallCommand where - toEncoding = J.genericToEncoding . taggedObjectJSON $ dropPrefix "WCCall" - toJSON = J.genericToJSON . taggedObjectJSON $ dropPrefix "WCCall" - viewVersionInfo :: ChatLogLevel -> CoreVersionInfo -> [StyledString] viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCommit} = map plain $ diff --git a/stack.yaml b/stack.yaml index f0fcbab1de..58a921303b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -49,7 +49,7 @@ extra-deps: # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561 # - ../simplexmq - github: simplex-chat/simplexmq - commit: d920a2504b6d4653748da7d297cb13cd0a0f1f48 + commit: 511d793b927b1e2f12999e0829718671b3a8f0cb - github: kazu-yamamoto/http2 commit: 804fa283f067bd3fd89b8c5f8d25b3047813a517 # - ../direct-sqlcipher diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index aa36b397a3..d8e98513c7 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -9,8 +10,9 @@ module MobileTests where import ChatTests.Utils import Control.Monad.Except import Crypto.Random (getRandomBytes) -import Data.Aeson (FromJSON (..)) +import Data.Aeson (FromJSON) import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BS @@ -256,9 +258,11 @@ testMediaCApi _ = do (f cKeyStr ptr cLen >>= peekCAString) `shouldReturn` "" getByteString ptr cLen -instance FromJSON WriteFileResult where parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "WF" +instance FromJSON WriteFileResult where + parseJSON = $(JQ.mkParseJSON (sumTypeJSON $ dropPrefix "WF") ''WriteFileResult) -instance FromJSON ReadFileResult where parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RF" +instance FromJSON ReadFileResult where + parseJSON = $(JQ.mkParseJSON (sumTypeJSON $ dropPrefix "RF") ''ReadFileResult) testFileCApi :: FilePath -> FilePath -> IO () testFileCApi fileName tmp = do