mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-03-31 01:05:55 +00:00
core: stabilize tests (#2500)
This commit is contained in:
spaced4ndy
@@ -54,6 +54,7 @@ import Simplex.Chat.Call
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.ChatItemContent
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
|
||||
import Simplex.Chat.Protocol
|
||||
|
||||
@@ -16,6 +16,7 @@ import qualified Data.Text as T
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.ChatItemContent
|
||||
import Simplex.Chat.Protocol (MsgContent (..))
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Types (Contact (..), IsContact (..), User (..))
|
||||
|
||||
@@ -42,6 +42,7 @@ import qualified Paths_simplex_chat as SC
|
||||
import Simplex.Chat.Call
|
||||
import Simplex.Chat.Markdown (MarkdownList)
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.ChatItemContent
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Store (AutoAccept, StoreError, UserContactLink)
|
||||
import Simplex.Chat.Types
|
||||
|
||||
@@ -21,7 +21,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isNothing, isJust)
|
||||
import Data.Maybe (isJust, isNothing)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
@@ -29,21 +29,18 @@ import Data.Time.Clock (UTCTime, diffUTCTime, nominalDay)
|
||||
import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime)
|
||||
import Data.Type.Equality
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Word (Word32)
|
||||
import Database.SQLite.Simple (ResultError (..), SQLData (..))
|
||||
import Database.SQLite.Simple.FromField (Field, FromField (..), returnError)
|
||||
import Database.SQLite.Simple.Internal (Field (..))
|
||||
import Database.SQLite.Simple.Ok
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.Generics (Generic)
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages.ChatItemContent
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgErrorType (..), MsgMeta (..), SwitchPhase (..))
|
||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, fstToLower, singleFieldJSON, sumTypeJSON)
|
||||
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (MsgBody)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, tshow, (<$?>))
|
||||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||
|
||||
data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection
|
||||
deriving (Eq, Show, Ord, Generic)
|
||||
@@ -212,6 +209,10 @@ chatItemMember GroupInfo {membership} ChatItem {chatDir} = case chatDir of
|
||||
CIGroupSnd -> membership
|
||||
CIGroupRcv m -> m
|
||||
|
||||
ciReactionAllowed :: ChatItem c d -> Bool
|
||||
ciReactionAllowed ChatItem {meta = CIMeta {itemDeleted = Just _}} = False
|
||||
ciReactionAllowed ChatItem {content} = isJust $ ciMsgContent content
|
||||
|
||||
data CIDeletedState = CIDeletedState
|
||||
{ markedDeleted :: Bool,
|
||||
deletedByMember :: Maybe GroupMember
|
||||
@@ -633,11 +634,6 @@ data CIStatus (d :: MsgDirection) where
|
||||
|
||||
deriving instance Show (CIStatus d)
|
||||
|
||||
ciStatusNew :: forall d. MsgDirectionI d => CIStatus d
|
||||
ciStatusNew = case msgDirection @d of
|
||||
SMDSnd -> CISSndNew
|
||||
SMDRcv -> CISRcvNew
|
||||
|
||||
instance ToJSON (CIStatus d) where
|
||||
toJSON = J.toJSON . jsonCIStatus
|
||||
toEncoding = J.toEncoding . jsonCIStatus
|
||||
@@ -694,6 +690,16 @@ jsonCIStatus = \case
|
||||
CISRcvNew -> JCISRcvNew
|
||||
CISRcvRead -> JCISRcvRead
|
||||
|
||||
ciStatusNew :: forall d. MsgDirectionI d => CIStatus d
|
||||
ciStatusNew = case msgDirection @d of
|
||||
SMDSnd -> CISSndNew
|
||||
SMDRcv -> CISRcvNew
|
||||
|
||||
ciCreateStatus :: forall d. MsgDirectionI d => CIContent d -> CIStatus d
|
||||
ciCreateStatus content = case msgDirection @d of
|
||||
SMDSnd -> ciStatusNew
|
||||
SMDRcv -> if ciRequiresAttention content then ciStatusNew else CISRcvRead
|
||||
|
||||
type ChatItemId = Int64
|
||||
|
||||
type ChatItemTs = UTCTime
|
||||
@@ -704,573 +710,6 @@ data ChatPagination
|
||||
| CPBefore ChatItemId Int
|
||||
deriving (Show)
|
||||
|
||||
data CIDeleteMode = CIDMBroadcast | CIDMInternal
|
||||
deriving (Show, Generic)
|
||||
|
||||
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"
|
||||
|
||||
ciDeleteModeToText :: CIDeleteMode -> Text
|
||||
ciDeleteModeToText = \case
|
||||
CIDMBroadcast -> "this item is deleted (broadcast)"
|
||||
CIDMInternal -> "this item is deleted (internal)"
|
||||
|
||||
ciGroupInvitationToText :: CIGroupInvitation -> GroupMemberRole -> Text
|
||||
ciGroupInvitationToText CIGroupInvitation {groupProfile = GroupProfile {displayName, fullName}} role =
|
||||
"invitation to join group " <> displayName <> optionalFullName displayName fullName <> " as " <> (decodeLatin1 . strEncode $ role)
|
||||
|
||||
rcvGroupEventToText :: RcvGroupEvent -> Text
|
||||
rcvGroupEventToText = \case
|
||||
RGEMemberAdded _ p -> "added " <> profileToText p
|
||||
RGEMemberConnected -> "connected"
|
||||
RGEMemberLeft -> "left"
|
||||
RGEMemberRole _ p r -> "changed role of " <> profileToText p <> " to " <> safeDecodeUtf8 (strEncode r)
|
||||
RGEUserRole r -> "changed your role to " <> safeDecodeUtf8 (strEncode r)
|
||||
RGEMemberDeleted _ p -> "removed " <> profileToText p
|
||||
RGEUserDeleted -> "removed you"
|
||||
RGEGroupDeleted -> "deleted group"
|
||||
RGEGroupUpdated _ -> "group profile updated"
|
||||
RGEInvitedViaGroupLink -> "invited via your group link"
|
||||
|
||||
sndGroupEventToText :: SndGroupEvent -> Text
|
||||
sndGroupEventToText = \case
|
||||
SGEMemberRole _ p r -> "changed role of " <> profileToText p <> " to " <> safeDecodeUtf8 (strEncode r)
|
||||
SGEUserRole r -> "changed role for yourself to " <> safeDecodeUtf8 (strEncode r)
|
||||
SGEMemberDeleted _ p -> "removed " <> profileToText p
|
||||
SGEUserLeft -> "left"
|
||||
SGEGroupUpdated _ -> "group profile updated"
|
||||
|
||||
rcvConnEventToText :: RcvConnEvent -> Text
|
||||
rcvConnEventToText = \case
|
||||
RCESwitchQueue phase -> case phase of
|
||||
SPCompleted -> "changed address for you"
|
||||
_ -> decodeLatin1 (strEncode phase) <> " changing address for you..."
|
||||
|
||||
sndConnEventToText :: SndConnEvent -> Text
|
||||
sndConnEventToText = \case
|
||||
SCESwitchQueue phase m -> case phase of
|
||||
SPCompleted -> "you changed address" <> forMember m
|
||||
_ -> decodeLatin1 (strEncode phase) <> " changing address" <> forMember m <> "..."
|
||||
where
|
||||
forMember member_ =
|
||||
maybe "" (\GroupMemberRef {profile = Profile {displayName}} -> " for " <> displayName) member_
|
||||
|
||||
profileToText :: Profile -> Text
|
||||
profileToText Profile {displayName, fullName} = displayName <> optionalFullName displayName fullName
|
||||
|
||||
-- This type is used both in API and in DB, so we use different JSON encodings for the database and for the API
|
||||
-- ! Nested sum types also have to use different encodings for database and API
|
||||
-- ! to avoid breaking cross-platform compatibility, see RcvGroupEvent and SndGroupEvent
|
||||
data CIContent (d :: MsgDirection) where
|
||||
CISndMsgContent :: MsgContent -> CIContent 'MDSnd
|
||||
CIRcvMsgContent :: MsgContent -> CIContent 'MDRcv
|
||||
CISndDeleted :: CIDeleteMode -> CIContent 'MDSnd -- legacy - since v4.3.0 item_deleted field is used
|
||||
CIRcvDeleted :: CIDeleteMode -> CIContent 'MDRcv -- legacy - since v4.3.0 item_deleted field is used
|
||||
CISndCall :: CICallStatus -> Int -> CIContent 'MDSnd
|
||||
CIRcvCall :: CICallStatus -> Int -> CIContent 'MDRcv
|
||||
CIRcvIntegrityError :: MsgErrorType -> CIContent 'MDRcv
|
||||
CIRcvDecryptionError :: MsgDecryptError -> Word32 -> CIContent 'MDRcv
|
||||
CIRcvGroupInvitation :: CIGroupInvitation -> GroupMemberRole -> CIContent 'MDRcv
|
||||
CISndGroupInvitation :: CIGroupInvitation -> GroupMemberRole -> CIContent 'MDSnd
|
||||
CIRcvGroupEvent :: RcvGroupEvent -> CIContent 'MDRcv
|
||||
CISndGroupEvent :: SndGroupEvent -> CIContent 'MDSnd
|
||||
CIRcvConnEvent :: RcvConnEvent -> CIContent 'MDRcv
|
||||
CISndConnEvent :: SndConnEvent -> CIContent 'MDSnd
|
||||
CIRcvChatFeature :: ChatFeature -> PrefEnabled -> Maybe Int -> CIContent 'MDRcv
|
||||
CISndChatFeature :: ChatFeature -> PrefEnabled -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvChatPreference :: ChatFeature -> FeatureAllowed -> Maybe Int -> CIContent 'MDRcv
|
||||
CISndChatPreference :: ChatFeature -> FeatureAllowed -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDRcv
|
||||
CISndGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvChatFeatureRejected :: ChatFeature -> CIContent 'MDRcv
|
||||
CIRcvGroupFeatureRejected :: GroupFeature -> CIContent 'MDRcv
|
||||
CISndModerated :: CIContent 'MDSnd
|
||||
CIRcvModerated :: CIContent 'MDRcv
|
||||
CIInvalidJSON :: Text -> CIContent d
|
||||
-- ^ This type is used both in API and in DB, so we use different JSON encodings for the database and for the API
|
||||
-- ! ^ Nested sum types also have to use different encodings for database and API
|
||||
-- ! ^ to avoid breaking cross-platform compatibility, see RcvGroupEvent and SndGroupEvent
|
||||
|
||||
deriving instance Show (CIContent d)
|
||||
|
||||
ciMsgContent :: CIContent d -> Maybe MsgContent
|
||||
ciMsgContent = \case
|
||||
CISndMsgContent mc -> Just mc
|
||||
CIRcvMsgContent mc -> Just mc
|
||||
_ -> Nothing
|
||||
|
||||
data MsgDecryptError = MDERatchetHeader | MDETooManySkipped
|
||||
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"
|
||||
|
||||
ciReactionAllowed :: ChatItem c d -> Bool
|
||||
ciReactionAllowed ChatItem {meta = CIMeta {itemDeleted = Just _}} = False
|
||||
ciReactionAllowed ChatItem {content} = isJust $ ciMsgContent content
|
||||
|
||||
ciRequiresAttention :: forall d. MsgDirectionI d => CIContent d -> Bool
|
||||
ciRequiresAttention content = case msgDirection @d of
|
||||
SMDSnd -> True
|
||||
SMDRcv -> case content of
|
||||
CIRcvMsgContent _ -> True
|
||||
CIRcvDeleted _ -> True
|
||||
CIRcvCall {} -> True
|
||||
CIRcvIntegrityError _ -> True
|
||||
CIRcvDecryptionError {} -> True
|
||||
CIRcvGroupInvitation {} -> True
|
||||
CIRcvGroupEvent rge -> case rge of
|
||||
RGEMemberAdded {} -> False
|
||||
RGEMemberConnected -> False
|
||||
RGEMemberLeft -> False
|
||||
RGEMemberRole {} -> False
|
||||
RGEUserRole _ -> True
|
||||
RGEMemberDeleted {} -> False
|
||||
RGEUserDeleted -> True
|
||||
RGEGroupDeleted -> True
|
||||
RGEGroupUpdated _ -> False
|
||||
RGEInvitedViaGroupLink -> False
|
||||
CIRcvConnEvent _ -> True
|
||||
CIRcvChatFeature {} -> False
|
||||
CIRcvChatPreference {} -> False
|
||||
CIRcvGroupFeature {} -> False
|
||||
CIRcvChatFeatureRejected _ -> True
|
||||
CIRcvGroupFeatureRejected _ -> True
|
||||
CIRcvModerated -> True
|
||||
CIInvalidJSON _ -> False
|
||||
|
||||
ciCreateStatus :: forall d. MsgDirectionI d => CIContent d -> CIStatus d
|
||||
ciCreateStatus content = case msgDirection @d of
|
||||
SMDSnd -> ciStatusNew
|
||||
SMDRcv -> if ciRequiresAttention content then ciStatusNew else CISRcvRead
|
||||
|
||||
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
|
||||
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}
|
||||
deriving (Show, Generic)
|
||||
|
||||
data SndConnEvent = SCESwitchQueue {phase :: SwitchPhase, 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
|
||||
|
||||
newtype DBMsgErrorType = DBME MsgErrorType
|
||||
|
||||
instance FromJSON DBMsgErrorType where
|
||||
parseJSON v = DBME <$> J.genericParseJSON (singleFieldJSON fstToLower) v
|
||||
|
||||
instance ToJSON DBMsgErrorType where
|
||||
toJSON (DBME v) = J.genericToJSON (singleFieldJSON fstToLower) v
|
||||
toEncoding (DBME v) = J.genericToEncoding (singleFieldJSON fstToLower) v
|
||||
|
||||
data CIGroupInvitation = CIGroupInvitation
|
||||
{ groupId :: GroupId,
|
||||
groupMemberId :: GroupMemberId,
|
||||
localDisplayName :: GroupName,
|
||||
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}
|
||||
|
||||
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"
|
||||
|
||||
ciContentToText :: CIContent d -> Text
|
||||
ciContentToText = \case
|
||||
CISndMsgContent mc -> msgContentText mc
|
||||
CIRcvMsgContent mc -> msgContentText mc
|
||||
CISndDeleted cidm -> ciDeleteModeToText cidm
|
||||
CIRcvDeleted cidm -> ciDeleteModeToText cidm
|
||||
CISndCall status duration -> "outgoing call: " <> ciCallInfoText status duration
|
||||
CIRcvCall status duration -> "incoming call: " <> ciCallInfoText status duration
|
||||
CIRcvIntegrityError err -> msgIntegrityError err
|
||||
CIRcvDecryptionError err n -> msgDecryptErrorText err n
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> "received " <> ciGroupInvitationToText groupInvitation memberRole
|
||||
CISndGroupInvitation groupInvitation memberRole -> "sent " <> ciGroupInvitationToText groupInvitation memberRole
|
||||
CIRcvGroupEvent event -> rcvGroupEventToText event
|
||||
CISndGroupEvent event -> sndGroupEventToText event
|
||||
CIRcvConnEvent event -> rcvConnEventToText event
|
||||
CISndConnEvent event -> sndConnEventToText event
|
||||
CIRcvChatFeature feature enabled param -> featureStateText feature enabled param
|
||||
CISndChatFeature feature enabled param -> featureStateText feature enabled param
|
||||
CIRcvChatPreference feature allowed param -> prefStateText feature allowed param
|
||||
CISndChatPreference feature allowed param -> "you " <> prefStateText feature allowed param
|
||||
CIRcvGroupFeature feature pref param -> groupPrefStateText feature pref param
|
||||
CISndGroupFeature feature pref param -> groupPrefStateText feature pref param
|
||||
CIRcvChatFeatureRejected feature -> chatFeatureNameText feature <> ": received, prohibited"
|
||||
CIRcvGroupFeatureRejected feature -> groupFeatureNameText feature <> ": received, prohibited"
|
||||
CISndModerated -> ciModeratedText
|
||||
CIRcvModerated -> ciModeratedText
|
||||
CIInvalidJSON _ -> "invalid content JSON"
|
||||
|
||||
msgIntegrityError :: MsgErrorType -> Text
|
||||
msgIntegrityError = \case
|
||||
MsgSkipped fromId toId ->
|
||||
"skipped message ID " <> tshow fromId
|
||||
<> if fromId == toId then "" else ".." <> tshow toId
|
||||
MsgBadId msgId -> "unexpected message ID " <> tshow msgId
|
||||
MsgBadHash -> "incorrect message hash"
|
||||
MsgDuplicate -> "duplicate message ID"
|
||||
|
||||
msgDecryptErrorText :: MsgDecryptError -> Word32 -> Text
|
||||
msgDecryptErrorText err n =
|
||||
"decryption error, possibly due to the device change (" <> errName <> if n == 1 then ")" else ", " <> tshow n <> " messages)"
|
||||
where
|
||||
errName = case err of
|
||||
MDERatchetHeader -> "header"
|
||||
MDETooManySkipped -> "too many skipped messages"
|
||||
|
||||
msgDirToModeratedContent_ :: SMsgDirection d -> CIContent d
|
||||
msgDirToModeratedContent_ = \case
|
||||
SMDRcv -> CIRcvModerated
|
||||
SMDSnd -> CISndModerated
|
||||
|
||||
ciModeratedText :: Text
|
||||
ciModeratedText = "moderated"
|
||||
|
||||
-- platform independent
|
||||
instance MsgDirectionI d => ToField (CIContent d) where
|
||||
toField = toField . encodeJSON . dbJsonCIContent
|
||||
|
||||
-- platform specific
|
||||
instance MsgDirectionI d => ToJSON (CIContent d) where
|
||||
toJSON = J.toJSON . jsonCIContent
|
||||
toEncoding = J.toEncoding . jsonCIContent
|
||||
|
||||
data ACIContent = forall d. MsgDirectionI d => ACIContent (SMsgDirection d) (CIContent d)
|
||||
|
||||
deriving instance Show ACIContent
|
||||
|
||||
-- platform independent
|
||||
dbParseACIContent :: Text -> Either String ACIContent
|
||||
dbParseACIContent = fmap aciContentDBJSON . J.eitherDecodeStrict' . encodeUtf8
|
||||
|
||||
-- platform specific
|
||||
instance FromJSON ACIContent where
|
||||
parseJSON = fmap aciContentJSON . J.parseJSON
|
||||
|
||||
-- platform specific
|
||||
data JSONCIContent
|
||||
= JCISndMsgContent {msgContent :: MsgContent}
|
||||
| JCIRcvMsgContent {msgContent :: MsgContent}
|
||||
| JCISndDeleted {deleteMode :: CIDeleteMode}
|
||||
| JCIRcvDeleted {deleteMode :: CIDeleteMode}
|
||||
| JCISndCall {status :: CICallStatus, duration :: Int} -- duration in seconds
|
||||
| JCIRcvCall {status :: CICallStatus, duration :: Int}
|
||||
| JCIRcvIntegrityError {msgError :: MsgErrorType}
|
||||
| JCIRcvDecryptionError {msgDecryptError :: MsgDecryptError, msgCount :: Word32}
|
||||
| JCIRcvGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| JCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| JCIRcvGroupEvent {rcvGroupEvent :: RcvGroupEvent}
|
||||
| JCISndGroupEvent {sndGroupEvent :: SndGroupEvent}
|
||||
| JCIRcvConnEvent {rcvConnEvent :: RcvConnEvent}
|
||||
| JCISndConnEvent {sndConnEvent :: SndConnEvent}
|
||||
| JCIRcvChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| JCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| JCIRcvChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| JCISndChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| JCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| JCIRcvChatFeatureRejected {feature :: ChatFeature}
|
||||
| JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
|
||||
| JCISndModerated
|
||||
| JCIRcvModerated
|
||||
| JCIInvalidJSON {direction :: MsgDirection, json :: Text}
|
||||
deriving (Generic)
|
||||
|
||||
instance FromJSON JSONCIContent where
|
||||
parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "JCI"
|
||||
|
||||
instance ToJSON JSONCIContent where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCI"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCI"
|
||||
|
||||
jsonCIContent :: forall d. MsgDirectionI d => CIContent d -> JSONCIContent
|
||||
jsonCIContent = \case
|
||||
CISndMsgContent mc -> JCISndMsgContent mc
|
||||
CIRcvMsgContent mc -> JCIRcvMsgContent mc
|
||||
CISndDeleted cidm -> JCISndDeleted cidm
|
||||
CIRcvDeleted cidm -> JCIRcvDeleted cidm
|
||||
CISndCall status duration -> JCISndCall {status, duration}
|
||||
CIRcvCall status duration -> JCIRcvCall {status, duration}
|
||||
CIRcvIntegrityError err -> JCIRcvIntegrityError err
|
||||
CIRcvDecryptionError err n -> JCIRcvDecryptionError err n
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> JCIRcvGroupInvitation {groupInvitation, memberRole}
|
||||
CISndGroupInvitation groupInvitation memberRole -> JCISndGroupInvitation {groupInvitation, memberRole}
|
||||
CIRcvGroupEvent rcvGroupEvent -> JCIRcvGroupEvent {rcvGroupEvent}
|
||||
CISndGroupEvent sndGroupEvent -> JCISndGroupEvent {sndGroupEvent}
|
||||
CIRcvConnEvent rcvConnEvent -> JCIRcvConnEvent {rcvConnEvent}
|
||||
CISndConnEvent sndConnEvent -> JCISndConnEvent {sndConnEvent}
|
||||
CIRcvChatFeature feature enabled param -> JCIRcvChatFeature {feature, enabled, param}
|
||||
CISndChatFeature feature enabled param -> JCISndChatFeature {feature, enabled, param}
|
||||
CIRcvChatPreference feature allowed param -> JCIRcvChatPreference {feature, allowed, param}
|
||||
CISndChatPreference feature allowed param -> JCISndChatPreference {feature, allowed, param}
|
||||
CIRcvGroupFeature groupFeature preference param -> JCIRcvGroupFeature {groupFeature, preference, param}
|
||||
CISndGroupFeature groupFeature preference param -> JCISndGroupFeature {groupFeature, preference, param}
|
||||
CIRcvChatFeatureRejected feature -> JCIRcvChatFeatureRejected {feature}
|
||||
CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature}
|
||||
CISndModerated -> JCISndModerated
|
||||
CIRcvModerated -> JCISndModerated
|
||||
CIInvalidJSON json -> JCIInvalidJSON (toMsgDirection $ msgDirection @d) json
|
||||
|
||||
aciContentJSON :: JSONCIContent -> ACIContent
|
||||
aciContentJSON = \case
|
||||
JCISndMsgContent mc -> ACIContent SMDSnd $ CISndMsgContent mc
|
||||
JCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc
|
||||
JCISndDeleted cidm -> ACIContent SMDSnd $ CISndDeleted cidm
|
||||
JCIRcvDeleted cidm -> ACIContent SMDRcv $ CIRcvDeleted cidm
|
||||
JCISndCall {status, duration} -> ACIContent SMDSnd $ CISndCall status duration
|
||||
JCIRcvCall {status, duration} -> ACIContent SMDRcv $ CIRcvCall status duration
|
||||
JCIRcvIntegrityError err -> ACIContent SMDRcv $ CIRcvIntegrityError err
|
||||
JCIRcvDecryptionError err n -> ACIContent SMDRcv $ CIRcvDecryptionError err n
|
||||
JCIRcvGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDRcv $ CIRcvGroupInvitation groupInvitation memberRole
|
||||
JCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole
|
||||
JCIRcvGroupEvent {rcvGroupEvent} -> ACIContent SMDRcv $ CIRcvGroupEvent rcvGroupEvent
|
||||
JCISndGroupEvent {sndGroupEvent} -> ACIContent SMDSnd $ CISndGroupEvent sndGroupEvent
|
||||
JCIRcvConnEvent {rcvConnEvent} -> ACIContent SMDRcv $ CIRcvConnEvent rcvConnEvent
|
||||
JCISndConnEvent {sndConnEvent} -> ACIContent SMDSnd $ CISndConnEvent sndConnEvent
|
||||
JCIRcvChatFeature {feature, enabled, param} -> ACIContent SMDRcv $ CIRcvChatFeature feature enabled param
|
||||
JCISndChatFeature {feature, enabled, param} -> ACIContent SMDSnd $ CISndChatFeature feature enabled param
|
||||
JCIRcvChatPreference {feature, allowed, param} -> ACIContent SMDRcv $ CIRcvChatPreference feature allowed param
|
||||
JCISndChatPreference {feature, allowed, param} -> ACIContent SMDSnd $ CISndChatPreference feature allowed param
|
||||
JCIRcvGroupFeature {groupFeature, preference, param} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param
|
||||
JCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
|
||||
JCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
|
||||
JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
|
||||
JCISndModerated -> ACIContent SMDSnd CISndModerated
|
||||
JCIRcvModerated -> ACIContent SMDRcv CIRcvModerated
|
||||
JCIInvalidJSON dir json -> case fromMsgDirection dir of
|
||||
AMsgDirection d -> ACIContent d $ CIInvalidJSON json
|
||||
|
||||
-- platform independent
|
||||
data DBJSONCIContent
|
||||
= DBJCISndMsgContent {msgContent :: MsgContent}
|
||||
| DBJCIRcvMsgContent {msgContent :: MsgContent}
|
||||
| DBJCISndDeleted {deleteMode :: CIDeleteMode}
|
||||
| DBJCIRcvDeleted {deleteMode :: CIDeleteMode}
|
||||
| DBJCISndCall {status :: CICallStatus, duration :: Int}
|
||||
| DBJCIRcvCall {status :: CICallStatus, duration :: Int}
|
||||
| DBJCIRcvIntegrityError {msgError :: DBMsgErrorType}
|
||||
| DBJCIRcvDecryptionError {msgDecryptError :: MsgDecryptError, msgCount :: Word32}
|
||||
| DBJCIRcvGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| DBJCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| DBJCIRcvGroupEvent {rcvGroupEvent :: DBRcvGroupEvent}
|
||||
| DBJCISndGroupEvent {sndGroupEvent :: DBSndGroupEvent}
|
||||
| DBJCIRcvConnEvent {rcvConnEvent :: DBRcvConnEvent}
|
||||
| DBJCISndConnEvent {sndConnEvent :: DBSndConnEvent}
|
||||
| DBJCIRcvChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| DBJCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| DBJCIRcvChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| DBJCISndChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| DBJCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| DBJCIRcvChatFeatureRejected {feature :: ChatFeature}
|
||||
| DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
|
||||
| DBJCISndModerated
|
||||
| DBJCIRcvModerated
|
||||
| DBJCIInvalidJSON {direction :: MsgDirection, json :: Text}
|
||||
deriving (Generic)
|
||||
|
||||
instance FromJSON DBJSONCIContent where
|
||||
parseJSON = J.genericParseJSON . singleFieldJSON $ dropPrefix "DBJCI"
|
||||
|
||||
instance ToJSON DBJSONCIContent where
|
||||
toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "DBJCI"
|
||||
toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "DBJCI"
|
||||
|
||||
dbJsonCIContent :: forall d. MsgDirectionI d => CIContent d -> DBJSONCIContent
|
||||
dbJsonCIContent = \case
|
||||
CISndMsgContent mc -> DBJCISndMsgContent mc
|
||||
CIRcvMsgContent mc -> DBJCIRcvMsgContent mc
|
||||
CISndDeleted cidm -> DBJCISndDeleted cidm
|
||||
CIRcvDeleted cidm -> DBJCIRcvDeleted cidm
|
||||
CISndCall status duration -> DBJCISndCall {status, duration}
|
||||
CIRcvCall status duration -> DBJCIRcvCall {status, duration}
|
||||
CIRcvIntegrityError err -> DBJCIRcvIntegrityError $ DBME err
|
||||
CIRcvDecryptionError err n -> DBJCIRcvDecryptionError err n
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> DBJCIRcvGroupInvitation {groupInvitation, memberRole}
|
||||
CISndGroupInvitation groupInvitation memberRole -> DBJCISndGroupInvitation {groupInvitation, memberRole}
|
||||
CIRcvGroupEvent rge -> DBJCIRcvGroupEvent $ RGE rge
|
||||
CISndGroupEvent sge -> DBJCISndGroupEvent $ SGE sge
|
||||
CIRcvConnEvent rce -> DBJCIRcvConnEvent $ RCE rce
|
||||
CISndConnEvent sce -> DBJCISndConnEvent $ SCE sce
|
||||
CIRcvChatFeature feature enabled param -> DBJCIRcvChatFeature {feature, enabled, param}
|
||||
CISndChatFeature feature enabled param -> DBJCISndChatFeature {feature, enabled, param}
|
||||
CIRcvChatPreference feature allowed param -> DBJCIRcvChatPreference {feature, allowed, param}
|
||||
CISndChatPreference feature allowed param -> DBJCISndChatPreference {feature, allowed, param}
|
||||
CIRcvGroupFeature groupFeature preference param -> DBJCIRcvGroupFeature {groupFeature, preference, param}
|
||||
CISndGroupFeature groupFeature preference param -> DBJCISndGroupFeature {groupFeature, preference, param}
|
||||
CIRcvChatFeatureRejected feature -> DBJCIRcvChatFeatureRejected {feature}
|
||||
CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature}
|
||||
CISndModerated -> DBJCISndModerated
|
||||
CIRcvModerated -> DBJCIRcvModerated
|
||||
CIInvalidJSON json -> DBJCIInvalidJSON (toMsgDirection $ msgDirection @d) json
|
||||
|
||||
aciContentDBJSON :: DBJSONCIContent -> ACIContent
|
||||
aciContentDBJSON = \case
|
||||
DBJCISndMsgContent mc -> ACIContent SMDSnd $ CISndMsgContent mc
|
||||
DBJCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc
|
||||
DBJCISndDeleted cidm -> ACIContent SMDSnd $ CISndDeleted cidm
|
||||
DBJCIRcvDeleted cidm -> ACIContent SMDRcv $ CIRcvDeleted cidm
|
||||
DBJCISndCall {status, duration} -> ACIContent SMDSnd $ CISndCall status duration
|
||||
DBJCIRcvCall {status, duration} -> ACIContent SMDRcv $ CIRcvCall status duration
|
||||
DBJCIRcvIntegrityError (DBME err) -> ACIContent SMDRcv $ CIRcvIntegrityError err
|
||||
DBJCIRcvDecryptionError err n -> ACIContent SMDRcv $ CIRcvDecryptionError err n
|
||||
DBJCIRcvGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDRcv $ CIRcvGroupInvitation groupInvitation memberRole
|
||||
DBJCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole
|
||||
DBJCIRcvGroupEvent (RGE rge) -> ACIContent SMDRcv $ CIRcvGroupEvent rge
|
||||
DBJCISndGroupEvent (SGE sge) -> ACIContent SMDSnd $ CISndGroupEvent sge
|
||||
DBJCIRcvConnEvent (RCE rce) -> ACIContent SMDRcv $ CIRcvConnEvent rce
|
||||
DBJCISndConnEvent (SCE sce) -> ACIContent SMDSnd $ CISndConnEvent sce
|
||||
DBJCIRcvChatFeature {feature, enabled, param} -> ACIContent SMDRcv $ CIRcvChatFeature feature enabled param
|
||||
DBJCISndChatFeature {feature, enabled, param} -> ACIContent SMDSnd $ CISndChatFeature feature enabled param
|
||||
DBJCIRcvChatPreference {feature, allowed, param} -> ACIContent SMDRcv $ CIRcvChatPreference feature allowed param
|
||||
DBJCISndChatPreference {feature, allowed, param} -> ACIContent SMDSnd $ CISndChatPreference feature allowed param
|
||||
DBJCIRcvGroupFeature {groupFeature, preference, param} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param
|
||||
DBJCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
|
||||
DBJCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
|
||||
DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
|
||||
DBJCISndModerated -> ACIContent SMDSnd CISndModerated
|
||||
DBJCIRcvModerated -> ACIContent SMDRcv CIRcvModerated
|
||||
DBJCIInvalidJSON dir json -> case fromMsgDirection dir of
|
||||
AMsgDirection d -> ACIContent d $ CIInvalidJSON json
|
||||
|
||||
data CICallStatus
|
||||
= CISCallPending
|
||||
| CISCallMissed
|
||||
| CISCallRejected -- only possible for received calls, not on type level
|
||||
| CISCallAccepted
|
||||
| CISCallNegotiated
|
||||
| CISCallProgress
|
||||
| CISCallEnded
|
||||
| CISCallError
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance FromJSON CICallStatus where
|
||||
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CISCall"
|
||||
|
||||
instance ToJSON CICallStatus where
|
||||
toJSON = J.genericToJSON . enumJSON $ dropPrefix "CISCall"
|
||||
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CISCall"
|
||||
|
||||
ciCallInfoText :: CICallStatus -> Int -> Text
|
||||
ciCallInfoText status duration = case status of
|
||||
CISCallPending -> "calling..."
|
||||
CISCallMissed -> "missed"
|
||||
CISCallRejected -> "rejected"
|
||||
CISCallAccepted -> "accepted"
|
||||
CISCallNegotiated -> "connecting..."
|
||||
CISCallProgress -> "in progress " <> durationText duration
|
||||
CISCallEnded -> "ended " <> durationText duration
|
||||
CISCallError -> "error"
|
||||
|
||||
data SChatType (c :: ChatType) where
|
||||
SCTDirect :: SChatType 'CTDirect
|
||||
SCTGroup :: SChatType 'CTGroup
|
||||
@@ -1323,73 +762,6 @@ type MessageId = Int64
|
||||
|
||||
data ConnOrGroupId = ConnectionId Int64 | GroupId Int64
|
||||
|
||||
data MsgDirection = MDRcv | MDSnd
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
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"
|
||||
|
||||
instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgDirection . msgDirectionIntP
|
||||
|
||||
instance ToField MsgDirection where toField = toField . msgDirectionInt
|
||||
|
||||
fromIntField_ :: (Typeable a) => (Int64 -> Maybe a) -> Field -> Ok a
|
||||
fromIntField_ fromInt = \case
|
||||
f@(Field (SQLInteger i) _) ->
|
||||
case fromInt i of
|
||||
Just x -> Ok x
|
||||
_ -> returnError ConversionFailed f ("invalid integer: " <> show i)
|
||||
f -> returnError ConversionFailed f "expecting SQLInteger column type"
|
||||
|
||||
data SMsgDirection (d :: MsgDirection) where
|
||||
SMDRcv :: SMsgDirection 'MDRcv
|
||||
SMDSnd :: SMsgDirection 'MDSnd
|
||||
|
||||
deriving instance Show (SMsgDirection d)
|
||||
|
||||
instance TestEquality SMsgDirection where
|
||||
testEquality SMDRcv SMDRcv = Just Refl
|
||||
testEquality SMDSnd SMDSnd = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
instance ToField (SMsgDirection d) where toField = toField . msgDirectionInt . toMsgDirection
|
||||
|
||||
data AMsgDirection = forall d. MsgDirectionI d => AMsgDirection (SMsgDirection d)
|
||||
|
||||
deriving instance Show AMsgDirection
|
||||
|
||||
toMsgDirection :: SMsgDirection d -> MsgDirection
|
||||
toMsgDirection = \case
|
||||
SMDRcv -> MDRcv
|
||||
SMDSnd -> MDSnd
|
||||
|
||||
fromMsgDirection :: MsgDirection -> AMsgDirection
|
||||
fromMsgDirection = \case
|
||||
MDRcv -> AMsgDirection SMDRcv
|
||||
MDSnd -> AMsgDirection SMDSnd
|
||||
|
||||
class MsgDirectionI (d :: MsgDirection) where
|
||||
msgDirection :: SMsgDirection d
|
||||
|
||||
instance MsgDirectionI 'MDRcv where msgDirection = SMDRcv
|
||||
|
||||
instance MsgDirectionI 'MDSnd where msgDirection = SMDSnd
|
||||
|
||||
msgDirectionInt :: MsgDirection -> Int
|
||||
msgDirectionInt = \case
|
||||
MDRcv -> 0
|
||||
MDSnd -> 1
|
||||
|
||||
msgDirectionIntP :: Int64 -> Maybe MsgDirection
|
||||
msgDirectionIntP = \case
|
||||
0 -> Just MDRcv
|
||||
1 -> Just MDSnd
|
||||
_ -> Nothing
|
||||
|
||||
data SndMsgDelivery = SndMsgDelivery
|
||||
{ connId :: Int64,
|
||||
agentMsgId :: AgentMsgId
|
||||
|
||||
660
src/Simplex/Chat/Messages/ChatItemContent.hs
Normal file
660
src/Simplex/Chat/Messages/ChatItemContent.hs
Normal file
@@ -0,0 +1,660 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Chat.Messages.ChatItemContent where
|
||||
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Type.Equality
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Word (Word32)
|
||||
import Database.SQLite.Simple (ResultError (..), SQLData (..))
|
||||
import Database.SQLite.Simple.FromField (Field, FromField (..), returnError)
|
||||
import Database.SQLite.Simple.Internal (Field (..))
|
||||
import Database.SQLite.Simple.Ok
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.Generics (Generic)
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (MsgErrorType (..), SwitchPhase (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fstToLower, singleFieldJSON, sumTypeJSON)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
|
||||
|
||||
data MsgDirection = MDRcv | MDSnd
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
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"
|
||||
|
||||
instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgDirection . msgDirectionIntP
|
||||
|
||||
instance ToField MsgDirection where toField = toField . msgDirectionInt
|
||||
|
||||
fromIntField_ :: (Typeable a) => (Int64 -> Maybe a) -> Field -> Ok a
|
||||
fromIntField_ fromInt = \case
|
||||
f@(Field (SQLInteger i) _) ->
|
||||
case fromInt i of
|
||||
Just x -> Ok x
|
||||
_ -> returnError ConversionFailed f ("invalid integer: " <> show i)
|
||||
f -> returnError ConversionFailed f "expecting SQLInteger column type"
|
||||
|
||||
data SMsgDirection (d :: MsgDirection) where
|
||||
SMDRcv :: SMsgDirection 'MDRcv
|
||||
SMDSnd :: SMsgDirection 'MDSnd
|
||||
|
||||
deriving instance Show (SMsgDirection d)
|
||||
|
||||
instance TestEquality SMsgDirection where
|
||||
testEquality SMDRcv SMDRcv = Just Refl
|
||||
testEquality SMDSnd SMDSnd = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
instance ToField (SMsgDirection d) where toField = toField . msgDirectionInt . toMsgDirection
|
||||
|
||||
data AMsgDirection = forall d. MsgDirectionI d => AMsgDirection (SMsgDirection d)
|
||||
|
||||
deriving instance Show AMsgDirection
|
||||
|
||||
toMsgDirection :: SMsgDirection d -> MsgDirection
|
||||
toMsgDirection = \case
|
||||
SMDRcv -> MDRcv
|
||||
SMDSnd -> MDSnd
|
||||
|
||||
fromMsgDirection :: MsgDirection -> AMsgDirection
|
||||
fromMsgDirection = \case
|
||||
MDRcv -> AMsgDirection SMDRcv
|
||||
MDSnd -> AMsgDirection SMDSnd
|
||||
|
||||
class MsgDirectionI (d :: MsgDirection) where
|
||||
msgDirection :: SMsgDirection d
|
||||
|
||||
instance MsgDirectionI 'MDRcv where msgDirection = SMDRcv
|
||||
|
||||
instance MsgDirectionI 'MDSnd where msgDirection = SMDSnd
|
||||
|
||||
msgDirectionInt :: MsgDirection -> Int
|
||||
msgDirectionInt = \case
|
||||
MDRcv -> 0
|
||||
MDSnd -> 1
|
||||
|
||||
msgDirectionIntP :: Int64 -> Maybe MsgDirection
|
||||
msgDirectionIntP = \case
|
||||
0 -> Just MDRcv
|
||||
1 -> Just MDSnd
|
||||
_ -> Nothing
|
||||
|
||||
data CIDeleteMode = CIDMBroadcast | CIDMInternal
|
||||
deriving (Show, Generic)
|
||||
|
||||
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"
|
||||
|
||||
ciDeleteModeToText :: CIDeleteMode -> Text
|
||||
ciDeleteModeToText = \case
|
||||
CIDMBroadcast -> "this item is deleted (broadcast)"
|
||||
CIDMInternal -> "this item is deleted (internal)"
|
||||
|
||||
-- This type is used both in API and in DB, so we use different JSON encodings for the database and for the API
|
||||
-- ! Nested sum types also have to use different encodings for database and API
|
||||
-- ! to avoid breaking cross-platform compatibility, see RcvGroupEvent and SndGroupEvent
|
||||
data CIContent (d :: MsgDirection) where
|
||||
CISndMsgContent :: MsgContent -> CIContent 'MDSnd
|
||||
CIRcvMsgContent :: MsgContent -> CIContent 'MDRcv
|
||||
CISndDeleted :: CIDeleteMode -> CIContent 'MDSnd -- legacy - since v4.3.0 item_deleted field is used
|
||||
CIRcvDeleted :: CIDeleteMode -> CIContent 'MDRcv -- legacy - since v4.3.0 item_deleted field is used
|
||||
CISndCall :: CICallStatus -> Int -> CIContent 'MDSnd
|
||||
CIRcvCall :: CICallStatus -> Int -> CIContent 'MDRcv
|
||||
CIRcvIntegrityError :: MsgErrorType -> CIContent 'MDRcv
|
||||
CIRcvDecryptionError :: MsgDecryptError -> Word32 -> CIContent 'MDRcv
|
||||
CIRcvGroupInvitation :: CIGroupInvitation -> GroupMemberRole -> CIContent 'MDRcv
|
||||
CISndGroupInvitation :: CIGroupInvitation -> GroupMemberRole -> CIContent 'MDSnd
|
||||
CIRcvGroupEvent :: RcvGroupEvent -> CIContent 'MDRcv
|
||||
CISndGroupEvent :: SndGroupEvent -> CIContent 'MDSnd
|
||||
CIRcvConnEvent :: RcvConnEvent -> CIContent 'MDRcv
|
||||
CISndConnEvent :: SndConnEvent -> CIContent 'MDSnd
|
||||
CIRcvChatFeature :: ChatFeature -> PrefEnabled -> Maybe Int -> CIContent 'MDRcv
|
||||
CISndChatFeature :: ChatFeature -> PrefEnabled -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvChatPreference :: ChatFeature -> FeatureAllowed -> Maybe Int -> CIContent 'MDRcv
|
||||
CISndChatPreference :: ChatFeature -> FeatureAllowed -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDRcv
|
||||
CISndGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvChatFeatureRejected :: ChatFeature -> CIContent 'MDRcv
|
||||
CIRcvGroupFeatureRejected :: GroupFeature -> CIContent 'MDRcv
|
||||
CISndModerated :: CIContent 'MDSnd
|
||||
CIRcvModerated :: CIContent 'MDRcv
|
||||
CIInvalidJSON :: Text -> CIContent d
|
||||
-- ^ This type is used both in API and in DB, so we use different JSON encodings for the database and for the API
|
||||
-- ! ^ Nested sum types also have to use different encodings for database and API
|
||||
-- ! ^ to avoid breaking cross-platform compatibility, see RcvGroupEvent and SndGroupEvent
|
||||
|
||||
deriving instance Show (CIContent d)
|
||||
|
||||
ciMsgContent :: CIContent d -> Maybe MsgContent
|
||||
ciMsgContent = \case
|
||||
CISndMsgContent mc -> Just mc
|
||||
CIRcvMsgContent mc -> Just mc
|
||||
_ -> Nothing
|
||||
|
||||
data MsgDecryptError = MDERatchetHeader | MDETooManySkipped
|
||||
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"
|
||||
|
||||
ciRequiresAttention :: forall d. MsgDirectionI d => CIContent d -> Bool
|
||||
ciRequiresAttention content = case msgDirection @d of
|
||||
SMDSnd -> True
|
||||
SMDRcv -> case content of
|
||||
CIRcvMsgContent _ -> True
|
||||
CIRcvDeleted _ -> True
|
||||
CIRcvCall {} -> True
|
||||
CIRcvIntegrityError _ -> True
|
||||
CIRcvDecryptionError {} -> True
|
||||
CIRcvGroupInvitation {} -> True
|
||||
CIRcvGroupEvent rge -> case rge of
|
||||
RGEMemberAdded {} -> False
|
||||
RGEMemberConnected -> False
|
||||
RGEMemberLeft -> False
|
||||
RGEMemberRole {} -> False
|
||||
RGEUserRole _ -> True
|
||||
RGEMemberDeleted {} -> False
|
||||
RGEUserDeleted -> True
|
||||
RGEGroupDeleted -> True
|
||||
RGEGroupUpdated _ -> False
|
||||
RGEInvitedViaGroupLink -> False
|
||||
CIRcvConnEvent _ -> True
|
||||
CIRcvChatFeature {} -> False
|
||||
CIRcvChatPreference {} -> False
|
||||
CIRcvGroupFeature {} -> False
|
||||
CIRcvChatFeatureRejected _ -> True
|
||||
CIRcvGroupFeatureRejected _ -> True
|
||||
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
|
||||
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}
|
||||
deriving (Show, Generic)
|
||||
|
||||
data SndConnEvent = SCESwitchQueue {phase :: SwitchPhase, 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
|
||||
|
||||
newtype DBMsgErrorType = DBME MsgErrorType
|
||||
|
||||
instance FromJSON DBMsgErrorType where
|
||||
parseJSON v = DBME <$> J.genericParseJSON (singleFieldJSON fstToLower) v
|
||||
|
||||
instance ToJSON DBMsgErrorType where
|
||||
toJSON (DBME v) = J.genericToJSON (singleFieldJSON fstToLower) v
|
||||
toEncoding (DBME v) = J.genericToEncoding (singleFieldJSON fstToLower) v
|
||||
|
||||
data CIGroupInvitation = CIGroupInvitation
|
||||
{ groupId :: GroupId,
|
||||
groupMemberId :: GroupMemberId,
|
||||
localDisplayName :: GroupName,
|
||||
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}
|
||||
|
||||
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"
|
||||
|
||||
ciContentToText :: CIContent d -> Text
|
||||
ciContentToText = \case
|
||||
CISndMsgContent mc -> msgContentText mc
|
||||
CIRcvMsgContent mc -> msgContentText mc
|
||||
CISndDeleted cidm -> ciDeleteModeToText cidm
|
||||
CIRcvDeleted cidm -> ciDeleteModeToText cidm
|
||||
CISndCall status duration -> "outgoing call: " <> ciCallInfoText status duration
|
||||
CIRcvCall status duration -> "incoming call: " <> ciCallInfoText status duration
|
||||
CIRcvIntegrityError err -> msgIntegrityError err
|
||||
CIRcvDecryptionError err n -> msgDecryptErrorText err n
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> "received " <> ciGroupInvitationToText groupInvitation memberRole
|
||||
CISndGroupInvitation groupInvitation memberRole -> "sent " <> ciGroupInvitationToText groupInvitation memberRole
|
||||
CIRcvGroupEvent event -> rcvGroupEventToText event
|
||||
CISndGroupEvent event -> sndGroupEventToText event
|
||||
CIRcvConnEvent event -> rcvConnEventToText event
|
||||
CISndConnEvent event -> sndConnEventToText event
|
||||
CIRcvChatFeature feature enabled param -> featureStateText feature enabled param
|
||||
CISndChatFeature feature enabled param -> featureStateText feature enabled param
|
||||
CIRcvChatPreference feature allowed param -> prefStateText feature allowed param
|
||||
CISndChatPreference feature allowed param -> "you " <> prefStateText feature allowed param
|
||||
CIRcvGroupFeature feature pref param -> groupPrefStateText feature pref param
|
||||
CISndGroupFeature feature pref param -> groupPrefStateText feature pref param
|
||||
CIRcvChatFeatureRejected feature -> chatFeatureNameText feature <> ": received, prohibited"
|
||||
CIRcvGroupFeatureRejected feature -> groupFeatureNameText feature <> ": received, prohibited"
|
||||
CISndModerated -> ciModeratedText
|
||||
CIRcvModerated -> ciModeratedText
|
||||
CIInvalidJSON _ -> "invalid content JSON"
|
||||
|
||||
ciGroupInvitationToText :: CIGroupInvitation -> GroupMemberRole -> Text
|
||||
ciGroupInvitationToText CIGroupInvitation {groupProfile = GroupProfile {displayName, fullName}} role =
|
||||
"invitation to join group " <> displayName <> optionalFullName displayName fullName <> " as " <> (decodeLatin1 . strEncode $ role)
|
||||
|
||||
rcvGroupEventToText :: RcvGroupEvent -> Text
|
||||
rcvGroupEventToText = \case
|
||||
RGEMemberAdded _ p -> "added " <> profileToText p
|
||||
RGEMemberConnected -> "connected"
|
||||
RGEMemberLeft -> "left"
|
||||
RGEMemberRole _ p r -> "changed role of " <> profileToText p <> " to " <> safeDecodeUtf8 (strEncode r)
|
||||
RGEUserRole r -> "changed your role to " <> safeDecodeUtf8 (strEncode r)
|
||||
RGEMemberDeleted _ p -> "removed " <> profileToText p
|
||||
RGEUserDeleted -> "removed you"
|
||||
RGEGroupDeleted -> "deleted group"
|
||||
RGEGroupUpdated _ -> "group profile updated"
|
||||
RGEInvitedViaGroupLink -> "invited via your group link"
|
||||
|
||||
sndGroupEventToText :: SndGroupEvent -> Text
|
||||
sndGroupEventToText = \case
|
||||
SGEMemberRole _ p r -> "changed role of " <> profileToText p <> " to " <> safeDecodeUtf8 (strEncode r)
|
||||
SGEUserRole r -> "changed role for yourself to " <> safeDecodeUtf8 (strEncode r)
|
||||
SGEMemberDeleted _ p -> "removed " <> profileToText p
|
||||
SGEUserLeft -> "left"
|
||||
SGEGroupUpdated _ -> "group profile updated"
|
||||
|
||||
rcvConnEventToText :: RcvConnEvent -> Text
|
||||
rcvConnEventToText = \case
|
||||
RCESwitchQueue phase -> case phase of
|
||||
SPCompleted -> "changed address for you"
|
||||
_ -> decodeLatin1 (strEncode phase) <> " changing address for you..."
|
||||
|
||||
sndConnEventToText :: SndConnEvent -> Text
|
||||
sndConnEventToText = \case
|
||||
SCESwitchQueue phase m -> case phase of
|
||||
SPCompleted -> "you changed address" <> forMember m
|
||||
_ -> decodeLatin1 (strEncode phase) <> " changing address" <> forMember m <> "..."
|
||||
where
|
||||
forMember member_ =
|
||||
maybe "" (\GroupMemberRef {profile = Profile {displayName}} -> " for " <> displayName) member_
|
||||
|
||||
profileToText :: Profile -> Text
|
||||
profileToText Profile {displayName, fullName} = displayName <> optionalFullName displayName fullName
|
||||
|
||||
msgIntegrityError :: MsgErrorType -> Text
|
||||
msgIntegrityError = \case
|
||||
MsgSkipped fromId toId ->
|
||||
"skipped message ID " <> tshow fromId
|
||||
<> if fromId == toId then "" else ".." <> tshow toId
|
||||
MsgBadId msgId -> "unexpected message ID " <> tshow msgId
|
||||
MsgBadHash -> "incorrect message hash"
|
||||
MsgDuplicate -> "duplicate message ID"
|
||||
|
||||
msgDecryptErrorText :: MsgDecryptError -> Word32 -> Text
|
||||
msgDecryptErrorText err n =
|
||||
"decryption error, possibly due to the device change (" <> errName <> if n == 1 then ")" else ", " <> tshow n <> " messages)"
|
||||
where
|
||||
errName = case err of
|
||||
MDERatchetHeader -> "header"
|
||||
MDETooManySkipped -> "too many skipped messages"
|
||||
|
||||
msgDirToModeratedContent_ :: SMsgDirection d -> CIContent d
|
||||
msgDirToModeratedContent_ = \case
|
||||
SMDRcv -> CIRcvModerated
|
||||
SMDSnd -> CISndModerated
|
||||
|
||||
ciModeratedText :: Text
|
||||
ciModeratedText = "moderated"
|
||||
|
||||
-- platform independent
|
||||
instance MsgDirectionI d => ToField (CIContent d) where
|
||||
toField = toField . encodeJSON . dbJsonCIContent
|
||||
|
||||
-- platform specific
|
||||
instance MsgDirectionI d => ToJSON (CIContent d) where
|
||||
toJSON = J.toJSON . jsonCIContent
|
||||
toEncoding = J.toEncoding . jsonCIContent
|
||||
|
||||
data ACIContent = forall d. MsgDirectionI d => ACIContent (SMsgDirection d) (CIContent d)
|
||||
|
||||
deriving instance Show ACIContent
|
||||
|
||||
-- platform independent
|
||||
dbParseACIContent :: Text -> Either String ACIContent
|
||||
dbParseACIContent = fmap aciContentDBJSON . J.eitherDecodeStrict' . encodeUtf8
|
||||
|
||||
-- platform specific
|
||||
instance FromJSON ACIContent where
|
||||
parseJSON = fmap aciContentJSON . J.parseJSON
|
||||
|
||||
-- platform specific
|
||||
data JSONCIContent
|
||||
= JCISndMsgContent {msgContent :: MsgContent}
|
||||
| JCIRcvMsgContent {msgContent :: MsgContent}
|
||||
| JCISndDeleted {deleteMode :: CIDeleteMode}
|
||||
| JCIRcvDeleted {deleteMode :: CIDeleteMode}
|
||||
| JCISndCall {status :: CICallStatus, duration :: Int} -- duration in seconds
|
||||
| JCIRcvCall {status :: CICallStatus, duration :: Int}
|
||||
| JCIRcvIntegrityError {msgError :: MsgErrorType}
|
||||
| JCIRcvDecryptionError {msgDecryptError :: MsgDecryptError, msgCount :: Word32}
|
||||
| JCIRcvGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| JCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| JCIRcvGroupEvent {rcvGroupEvent :: RcvGroupEvent}
|
||||
| JCISndGroupEvent {sndGroupEvent :: SndGroupEvent}
|
||||
| JCIRcvConnEvent {rcvConnEvent :: RcvConnEvent}
|
||||
| JCISndConnEvent {sndConnEvent :: SndConnEvent}
|
||||
| JCIRcvChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| JCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| JCIRcvChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| JCISndChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| JCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| JCIRcvChatFeatureRejected {feature :: ChatFeature}
|
||||
| JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
|
||||
| JCISndModerated
|
||||
| JCIRcvModerated
|
||||
| JCIInvalidJSON {direction :: MsgDirection, json :: Text}
|
||||
deriving (Generic)
|
||||
|
||||
instance FromJSON JSONCIContent where
|
||||
parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "JCI"
|
||||
|
||||
instance ToJSON JSONCIContent where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCI"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCI"
|
||||
|
||||
jsonCIContent :: forall d. MsgDirectionI d => CIContent d -> JSONCIContent
|
||||
jsonCIContent = \case
|
||||
CISndMsgContent mc -> JCISndMsgContent mc
|
||||
CIRcvMsgContent mc -> JCIRcvMsgContent mc
|
||||
CISndDeleted cidm -> JCISndDeleted cidm
|
||||
CIRcvDeleted cidm -> JCIRcvDeleted cidm
|
||||
CISndCall status duration -> JCISndCall {status, duration}
|
||||
CIRcvCall status duration -> JCIRcvCall {status, duration}
|
||||
CIRcvIntegrityError err -> JCIRcvIntegrityError err
|
||||
CIRcvDecryptionError err n -> JCIRcvDecryptionError err n
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> JCIRcvGroupInvitation {groupInvitation, memberRole}
|
||||
CISndGroupInvitation groupInvitation memberRole -> JCISndGroupInvitation {groupInvitation, memberRole}
|
||||
CIRcvGroupEvent rcvGroupEvent -> JCIRcvGroupEvent {rcvGroupEvent}
|
||||
CISndGroupEvent sndGroupEvent -> JCISndGroupEvent {sndGroupEvent}
|
||||
CIRcvConnEvent rcvConnEvent -> JCIRcvConnEvent {rcvConnEvent}
|
||||
CISndConnEvent sndConnEvent -> JCISndConnEvent {sndConnEvent}
|
||||
CIRcvChatFeature feature enabled param -> JCIRcvChatFeature {feature, enabled, param}
|
||||
CISndChatFeature feature enabled param -> JCISndChatFeature {feature, enabled, param}
|
||||
CIRcvChatPreference feature allowed param -> JCIRcvChatPreference {feature, allowed, param}
|
||||
CISndChatPreference feature allowed param -> JCISndChatPreference {feature, allowed, param}
|
||||
CIRcvGroupFeature groupFeature preference param -> JCIRcvGroupFeature {groupFeature, preference, param}
|
||||
CISndGroupFeature groupFeature preference param -> JCISndGroupFeature {groupFeature, preference, param}
|
||||
CIRcvChatFeatureRejected feature -> JCIRcvChatFeatureRejected {feature}
|
||||
CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature}
|
||||
CISndModerated -> JCISndModerated
|
||||
CIRcvModerated -> JCISndModerated
|
||||
CIInvalidJSON json -> JCIInvalidJSON (toMsgDirection $ msgDirection @d) json
|
||||
|
||||
aciContentJSON :: JSONCIContent -> ACIContent
|
||||
aciContentJSON = \case
|
||||
JCISndMsgContent mc -> ACIContent SMDSnd $ CISndMsgContent mc
|
||||
JCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc
|
||||
JCISndDeleted cidm -> ACIContent SMDSnd $ CISndDeleted cidm
|
||||
JCIRcvDeleted cidm -> ACIContent SMDRcv $ CIRcvDeleted cidm
|
||||
JCISndCall {status, duration} -> ACIContent SMDSnd $ CISndCall status duration
|
||||
JCIRcvCall {status, duration} -> ACIContent SMDRcv $ CIRcvCall status duration
|
||||
JCIRcvIntegrityError err -> ACIContent SMDRcv $ CIRcvIntegrityError err
|
||||
JCIRcvDecryptionError err n -> ACIContent SMDRcv $ CIRcvDecryptionError err n
|
||||
JCIRcvGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDRcv $ CIRcvGroupInvitation groupInvitation memberRole
|
||||
JCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole
|
||||
JCIRcvGroupEvent {rcvGroupEvent} -> ACIContent SMDRcv $ CIRcvGroupEvent rcvGroupEvent
|
||||
JCISndGroupEvent {sndGroupEvent} -> ACIContent SMDSnd $ CISndGroupEvent sndGroupEvent
|
||||
JCIRcvConnEvent {rcvConnEvent} -> ACIContent SMDRcv $ CIRcvConnEvent rcvConnEvent
|
||||
JCISndConnEvent {sndConnEvent} -> ACIContent SMDSnd $ CISndConnEvent sndConnEvent
|
||||
JCIRcvChatFeature {feature, enabled, param} -> ACIContent SMDRcv $ CIRcvChatFeature feature enabled param
|
||||
JCISndChatFeature {feature, enabled, param} -> ACIContent SMDSnd $ CISndChatFeature feature enabled param
|
||||
JCIRcvChatPreference {feature, allowed, param} -> ACIContent SMDRcv $ CIRcvChatPreference feature allowed param
|
||||
JCISndChatPreference {feature, allowed, param} -> ACIContent SMDSnd $ CISndChatPreference feature allowed param
|
||||
JCIRcvGroupFeature {groupFeature, preference, param} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param
|
||||
JCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
|
||||
JCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
|
||||
JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
|
||||
JCISndModerated -> ACIContent SMDSnd CISndModerated
|
||||
JCIRcvModerated -> ACIContent SMDRcv CIRcvModerated
|
||||
JCIInvalidJSON dir json -> case fromMsgDirection dir of
|
||||
AMsgDirection d -> ACIContent d $ CIInvalidJSON json
|
||||
|
||||
-- platform independent
|
||||
data DBJSONCIContent
|
||||
= DBJCISndMsgContent {msgContent :: MsgContent}
|
||||
| DBJCIRcvMsgContent {msgContent :: MsgContent}
|
||||
| DBJCISndDeleted {deleteMode :: CIDeleteMode}
|
||||
| DBJCIRcvDeleted {deleteMode :: CIDeleteMode}
|
||||
| DBJCISndCall {status :: CICallStatus, duration :: Int}
|
||||
| DBJCIRcvCall {status :: CICallStatus, duration :: Int}
|
||||
| DBJCIRcvIntegrityError {msgError :: DBMsgErrorType}
|
||||
| DBJCIRcvDecryptionError {msgDecryptError :: MsgDecryptError, msgCount :: Word32}
|
||||
| DBJCIRcvGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| DBJCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| DBJCIRcvGroupEvent {rcvGroupEvent :: DBRcvGroupEvent}
|
||||
| DBJCISndGroupEvent {sndGroupEvent :: DBSndGroupEvent}
|
||||
| DBJCIRcvConnEvent {rcvConnEvent :: DBRcvConnEvent}
|
||||
| DBJCISndConnEvent {sndConnEvent :: DBSndConnEvent}
|
||||
| DBJCIRcvChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| DBJCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| DBJCIRcvChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| DBJCISndChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| DBJCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| DBJCIRcvChatFeatureRejected {feature :: ChatFeature}
|
||||
| DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
|
||||
| DBJCISndModerated
|
||||
| DBJCIRcvModerated
|
||||
| DBJCIInvalidJSON {direction :: MsgDirection, json :: Text}
|
||||
deriving (Generic)
|
||||
|
||||
instance FromJSON DBJSONCIContent where
|
||||
parseJSON = J.genericParseJSON . singleFieldJSON $ dropPrefix "DBJCI"
|
||||
|
||||
instance ToJSON DBJSONCIContent where
|
||||
toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "DBJCI"
|
||||
toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "DBJCI"
|
||||
|
||||
dbJsonCIContent :: forall d. MsgDirectionI d => CIContent d -> DBJSONCIContent
|
||||
dbJsonCIContent = \case
|
||||
CISndMsgContent mc -> DBJCISndMsgContent mc
|
||||
CIRcvMsgContent mc -> DBJCIRcvMsgContent mc
|
||||
CISndDeleted cidm -> DBJCISndDeleted cidm
|
||||
CIRcvDeleted cidm -> DBJCIRcvDeleted cidm
|
||||
CISndCall status duration -> DBJCISndCall {status, duration}
|
||||
CIRcvCall status duration -> DBJCIRcvCall {status, duration}
|
||||
CIRcvIntegrityError err -> DBJCIRcvIntegrityError $ DBME err
|
||||
CIRcvDecryptionError err n -> DBJCIRcvDecryptionError err n
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> DBJCIRcvGroupInvitation {groupInvitation, memberRole}
|
||||
CISndGroupInvitation groupInvitation memberRole -> DBJCISndGroupInvitation {groupInvitation, memberRole}
|
||||
CIRcvGroupEvent rge -> DBJCIRcvGroupEvent $ RGE rge
|
||||
CISndGroupEvent sge -> DBJCISndGroupEvent $ SGE sge
|
||||
CIRcvConnEvent rce -> DBJCIRcvConnEvent $ RCE rce
|
||||
CISndConnEvent sce -> DBJCISndConnEvent $ SCE sce
|
||||
CIRcvChatFeature feature enabled param -> DBJCIRcvChatFeature {feature, enabled, param}
|
||||
CISndChatFeature feature enabled param -> DBJCISndChatFeature {feature, enabled, param}
|
||||
CIRcvChatPreference feature allowed param -> DBJCIRcvChatPreference {feature, allowed, param}
|
||||
CISndChatPreference feature allowed param -> DBJCISndChatPreference {feature, allowed, param}
|
||||
CIRcvGroupFeature groupFeature preference param -> DBJCIRcvGroupFeature {groupFeature, preference, param}
|
||||
CISndGroupFeature groupFeature preference param -> DBJCISndGroupFeature {groupFeature, preference, param}
|
||||
CIRcvChatFeatureRejected feature -> DBJCIRcvChatFeatureRejected {feature}
|
||||
CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature}
|
||||
CISndModerated -> DBJCISndModerated
|
||||
CIRcvModerated -> DBJCIRcvModerated
|
||||
CIInvalidJSON json -> DBJCIInvalidJSON (toMsgDirection $ msgDirection @d) json
|
||||
|
||||
aciContentDBJSON :: DBJSONCIContent -> ACIContent
|
||||
aciContentDBJSON = \case
|
||||
DBJCISndMsgContent mc -> ACIContent SMDSnd $ CISndMsgContent mc
|
||||
DBJCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc
|
||||
DBJCISndDeleted cidm -> ACIContent SMDSnd $ CISndDeleted cidm
|
||||
DBJCIRcvDeleted cidm -> ACIContent SMDRcv $ CIRcvDeleted cidm
|
||||
DBJCISndCall {status, duration} -> ACIContent SMDSnd $ CISndCall status duration
|
||||
DBJCIRcvCall {status, duration} -> ACIContent SMDRcv $ CIRcvCall status duration
|
||||
DBJCIRcvIntegrityError (DBME err) -> ACIContent SMDRcv $ CIRcvIntegrityError err
|
||||
DBJCIRcvDecryptionError err n -> ACIContent SMDRcv $ CIRcvDecryptionError err n
|
||||
DBJCIRcvGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDRcv $ CIRcvGroupInvitation groupInvitation memberRole
|
||||
DBJCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole
|
||||
DBJCIRcvGroupEvent (RGE rge) -> ACIContent SMDRcv $ CIRcvGroupEvent rge
|
||||
DBJCISndGroupEvent (SGE sge) -> ACIContent SMDSnd $ CISndGroupEvent sge
|
||||
DBJCIRcvConnEvent (RCE rce) -> ACIContent SMDRcv $ CIRcvConnEvent rce
|
||||
DBJCISndConnEvent (SCE sce) -> ACIContent SMDSnd $ CISndConnEvent sce
|
||||
DBJCIRcvChatFeature {feature, enabled, param} -> ACIContent SMDRcv $ CIRcvChatFeature feature enabled param
|
||||
DBJCISndChatFeature {feature, enabled, param} -> ACIContent SMDSnd $ CISndChatFeature feature enabled param
|
||||
DBJCIRcvChatPreference {feature, allowed, param} -> ACIContent SMDRcv $ CIRcvChatPreference feature allowed param
|
||||
DBJCISndChatPreference {feature, allowed, param} -> ACIContent SMDSnd $ CISndChatPreference feature allowed param
|
||||
DBJCIRcvGroupFeature {groupFeature, preference, param} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param
|
||||
DBJCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
|
||||
DBJCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
|
||||
DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
|
||||
DBJCISndModerated -> ACIContent SMDSnd CISndModerated
|
||||
DBJCIRcvModerated -> ACIContent SMDRcv CIRcvModerated
|
||||
DBJCIInvalidJSON dir json -> case fromMsgDirection dir of
|
||||
AMsgDirection d -> ACIContent d $ CIInvalidJSON json
|
||||
|
||||
data CICallStatus
|
||||
= CISCallPending
|
||||
| CISCallMissed
|
||||
| CISCallRejected -- only possible for received calls, not on type level
|
||||
| CISCallAccepted
|
||||
| CISCallNegotiated
|
||||
| CISCallProgress
|
||||
| CISCallEnded
|
||||
| CISCallError
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance FromJSON CICallStatus where
|
||||
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CISCall"
|
||||
|
||||
instance ToJSON CICallStatus where
|
||||
toJSON = J.genericToJSON . enumJSON $ dropPrefix "CISCall"
|
||||
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CISCall"
|
||||
|
||||
ciCallInfoText :: CICallStatus -> Int -> Text
|
||||
ciCallInfoText status duration = case status of
|
||||
CISCallPending -> "calling..."
|
||||
CISCallMissed -> "missed"
|
||||
CISCallRejected -> "rejected"
|
||||
CISCallAccepted -> "accepted"
|
||||
CISCallNegotiated -> "connecting..."
|
||||
CISCallProgress -> "in progress " <> durationText duration
|
||||
CISCallEnded -> "ended " <> durationText duration
|
||||
CISCallError -> "error"
|
||||
@@ -329,6 +329,7 @@ import GHC.Generics (Generic)
|
||||
import Simplex.Chat.Call
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.ChatItemContent
|
||||
import Simplex.Chat.Migrations.M20220101_initial
|
||||
import Simplex.Chat.Migrations.M20220122_v1_1
|
||||
import Simplex.Chat.Migrations.M20220205_chat_item_status
|
||||
@@ -4866,8 +4867,8 @@ getGroupChatReactions_ db g c@Chat {chatItems} = do
|
||||
|
||||
getDirectCIReactions :: DB.Connection -> Contact -> SharedMsgId -> IO [CIReactionCount]
|
||||
getDirectCIReactions db Contact {contactId} itemSharedMsgId =
|
||||
map toCIReaction <$>
|
||||
DB.query
|
||||
map toCIReaction
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT reaction, MAX(reaction_sent), COUNT(chat_item_reaction_id)
|
||||
@@ -4879,8 +4880,8 @@ getDirectCIReactions db Contact {contactId} itemSharedMsgId =
|
||||
|
||||
getGroupCIReactions :: DB.Connection -> GroupInfo -> MemberId -> SharedMsgId -> IO [CIReactionCount]
|
||||
getGroupCIReactions db GroupInfo {groupId} itemMemberId itemSharedMsgId =
|
||||
map toCIReaction <$>
|
||||
DB.query
|
||||
map toCIReaction
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT reaction, MAX(reaction_sent), COUNT(chat_item_reaction_id)
|
||||
@@ -4905,14 +4906,15 @@ getACIReactions db aci@(AChatItem _ md chat ci@ChatItem {meta = CIMeta {itemShar
|
||||
|
||||
deleteDirectCIReactions_ :: DB.Connection -> ContactId -> ChatItem 'CTDirect d -> IO ()
|
||||
deleteDirectCIReactions_ db contactId ChatItem {meta = CIMeta {itemSharedMsgId}} =
|
||||
forM_ itemSharedMsgId $ \itemSharedMId ->
|
||||
forM_ itemSharedMsgId $ \itemSharedMId ->
|
||||
DB.execute db "DELETE FROM chat_item_reactions WHERE contact_id = ? AND shared_msg_id = ?" (contactId, itemSharedMId)
|
||||
|
||||
deleteGroupCIReactions_ :: DB.Connection -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
|
||||
deleteGroupCIReactions_ db g@GroupInfo {groupId} ci@ChatItem {meta = CIMeta {itemSharedMsgId}} =
|
||||
forM_ itemSharedMsgId $ \itemSharedMId -> do
|
||||
let GroupMember {memberId} = chatItemMember g ci
|
||||
DB.execute db
|
||||
DB.execute
|
||||
db
|
||||
"DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id = ?"
|
||||
(groupId, itemSharedMId, memberId)
|
||||
|
||||
@@ -4921,8 +4923,8 @@ toCIReaction (reaction, userReacted, totalReacted) = CIReactionCount {reaction,
|
||||
|
||||
getDirectReactions :: DB.Connection -> Contact -> SharedMsgId -> Bool -> IO [MsgReaction]
|
||||
getDirectReactions db ct itemSharedMId sent =
|
||||
map fromOnly <$>
|
||||
DB.query
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT reaction
|
||||
@@ -4953,8 +4955,8 @@ setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs
|
||||
|
||||
getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [MsgReaction]
|
||||
getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent =
|
||||
map fromOnly <$>
|
||||
DB.query
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT reaction
|
||||
|
||||
@@ -31,6 +31,7 @@ import GHC.Weak (deRefWeak)
|
||||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.ChatItemContent
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Terminal.Output
|
||||
import Simplex.Chat.Types (User (..))
|
||||
@@ -322,7 +323,7 @@ updateTermState user_ st ac live tw (key, ms) ts@TerminalState {inputString = s,
|
||||
go _ _ = ""
|
||||
charsWithContact cs
|
||||
| live = cs
|
||||
| null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" =
|
||||
| null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" =
|
||||
contactPrefix <> cs
|
||||
| (s == ">" || s == "\\" || s == "!") && cs == " " =
|
||||
cs <> contactPrefix
|
||||
|
||||
@@ -37,6 +37,7 @@ import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Help
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages hiding (NewChatItem (..))
|
||||
import Simplex.Chat.Messages.ChatItemContent
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
|
||||
import Simplex.Chat.Styled
|
||||
|
||||
Reference in New Issue
Block a user