lovely-projects/simplex-chat
lovely-projects/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-03-14 09:45:42 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

core: derive JSON with TH (#3275)

Browse source 
* core: derive JSON with TH

* fix tests

* simplify events

* reduce diff

* fix

* update simplexmq

* update simplexmq
This commit is contained in:
Evgeny Poberezkin 2023-10-26 15:44:50 +01:00 • committed by GitHub
parent 3790752378
commit 16bda26022
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
23 changed files with 849 additions and 1136 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
cabal.project
View file

@ -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

2
scripts/nix/sha256map.nix
View file

@ -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";

1
simplex-chat.cabal
View file

@ -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

1
src/Simplex/Chat.hs
View file

@ -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

135
src/Simplex/Chat/Call.hs
View file

@ -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)

286
src/Simplex/Chat/Controller.hs
View file

@ -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)

42
src/Simplex/Chat/Markdown.hs
View file

@ -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)

445
src/Simplex/Chat/Messages.hs
View file

@ -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

184
src/Simplex/Chat/Messages/CIContent.hs
View file

@ -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

116
src/Simplex/Chat/Messages/CIContent/Events.hs Normal file
View file

@ -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

40
src/Simplex/Chat/Mobile.hs
View file

@ -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}

13
src/Simplex/Chat/Mobile/File.hs
View file

@ -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)

120
src/Simplex/Chat/Protocol.hs
View file

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

1
src/Simplex/Chat/Remote/Protocol.hs
View file

@ -1,5 +1,4 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}

11
src/Simplex/Chat/Remote/Types.hs
View file

@ -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)

17
src/Simplex/Chat/Store/Profiles.hs
View file

@ -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) =

15
src/Simplex/Chat/Store/Shared.hs
View file

@ -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()"

315
src/Simplex/Chat/Types.hs
View file

@ -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)

202
src/Simplex/Chat/Types/Preferences.hs
View file

@ -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)

3
src/Simplex/Chat/Types/Util.hs
View file

@ -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}

22
src/Simplex/Chat/View.hs
View file

@ -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 $

2
stack.yaml
View file

@ -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

10
tests/MobileTests.hs
View file

@ -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