{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} {-# OPTIONS_GHC -fno-warn-operator-whitespace #-} module Simplex.Chat.Messages where import Control.Applicative ((<|>)) import Control.Monad ((>=>)) import Data.Aeson (FromJSON, ToJSON, (.:)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE import qualified Data.Aeson.TH as JQ import qualified Data.Aeson.Types as JT import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace) import Data.Int (Int64) import Data.Kind (Constraint) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict (Map) import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, nominalDay) import Data.Type.Equality import Data.Typeable (Typeable) import GHC.TypeLits (ErrorMessage (ShowType, type (:<>:)), TypeError) import qualified GHC.TypeLits as Type import Simplex.Chat.Markdown import Simplex.Chat.Messages.CIContent import Simplex.Chat.Options.DB (FromField (..), ToField (..)) import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptStatus (..)) import Simplex.Messaging.Agent.Store.DB (fromTextField_) import Simplex.Messaging.Crypto.File (CryptoFile (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, sumTypeJSON) import Simplex.Messaging.Protocol (BlockingInfo, MsgBody) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) data ChatType = CTDirect | CTGroup | CTLocal | CTContactRequest | CTContactConnection deriving (Eq, Show, Ord) $(JQ.deriveJSON (enumJSON $ dropPrefix "CT") ''ChatType) data SChatType (c :: ChatType) where SCTDirect :: SChatType 'CTDirect SCTGroup :: SChatType 'CTGroup SCTLocal :: SChatType 'CTLocal SCTContactRequest :: SChatType 'CTContactRequest SCTContactConnection :: SChatType 'CTContactConnection deriving instance Show (SChatType c) instance TestEquality SChatType where testEquality SCTDirect SCTDirect = Just Refl testEquality SCTGroup SCTGroup = Just Refl testEquality SCTLocal SCTLocal = Just Refl testEquality SCTContactRequest SCTContactRequest = Just Refl testEquality SCTContactConnection SCTContactConnection = Just Refl testEquality _ _ = Nothing data AChatType = forall c. ChatTypeI c => ACT (SChatType c) class ChatTypeI (c :: ChatType) where chatTypeI :: SChatType c instance ChatTypeI 'CTDirect where chatTypeI = SCTDirect instance ChatTypeI 'CTGroup where chatTypeI = SCTGroup instance ChatTypeI 'CTLocal where chatTypeI = SCTLocal instance ChatTypeI 'CTContactRequest where chatTypeI = SCTContactRequest instance ChatTypeI 'CTContactConnection where chatTypeI = SCTContactConnection toChatType :: SChatType c -> ChatType toChatType = \case SCTDirect -> CTDirect SCTGroup -> CTGroup SCTLocal -> CTLocal SCTContactRequest -> CTContactRequest SCTContactConnection -> CTContactConnection aChatType :: ChatType -> AChatType aChatType = \case CTDirect -> ACT SCTDirect CTGroup -> ACT SCTGroup CTLocal -> ACT SCTLocal CTContactRequest -> ACT SCTContactRequest CTContactConnection -> ACT SCTContactConnection checkChatType :: forall t c c'. (ChatTypeI c, ChatTypeI c') => t c' -> Either String (t c) checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of Just Refl -> Right x Nothing -> Left "bad chat type" data GroupChatScope = GCSMemberSupport {groupMemberId_ :: Maybe GroupMemberId} -- Nothing means own conversation with support deriving (Eq, Show, Ord) data GroupChatScopeTag = GCSTMemberSupport_ deriving (Eq, Show) instance FromField GroupChatScopeTag where fromField = fromTextField_ textDecode instance ToField GroupChatScopeTag where toField = toField . textEncode instance TextEncoding GroupChatScopeTag where textDecode = \case "member_support" -> Just GCSTMemberSupport_ _ -> Nothing textEncode = \case GCSTMemberSupport_ -> "member_support" data ChatName = ChatName {chatType :: ChatType, chatName :: Text} deriving (Show) data SendName = SNDirect ContactName | SNGroup GroupName (Maybe GroupScopeName) | SNLocal deriving (Show) data GroupScopeName = GSNMemberSupport (Maybe ContactName) deriving (Show) chatTypeStr :: ChatType -> Text chatTypeStr = \case CTDirect -> "@" CTGroup -> "#" CTLocal -> "*" CTContactRequest -> "<@" CTContactConnection -> ":" chatNameStr :: ChatName -> String chatNameStr (ChatName cType name) = T.unpack $ chatTypeStr cType <> if T.any isSpace name then "'" <> name <> "'" else name data ChatRef = ChatRef {chatType :: ChatType, chatId :: Int64, chatScope :: Maybe GroupChatScope} deriving (Eq, Show, Ord) data ChatInfo (c :: ChatType) where DirectChat :: Contact -> ChatInfo 'CTDirect GroupChat :: GroupInfo -> Maybe GroupChatScopeInfo -> ChatInfo 'CTGroup LocalChat :: NoteFolder -> ChatInfo 'CTLocal ContactRequest :: UserContactRequest -> ChatInfo 'CTContactRequest ContactConnection :: PendingContactConnection -> ChatInfo 'CTContactConnection CInfoInvalidJSON :: SChatType c -> J.Object -> ChatInfo c -- this constructor is needed to catch JSON errors for Remote connection parsing deriving instance Show (ChatInfo c) data GroupChatScopeInfo = GCSIMemberSupport {groupMember_ :: Maybe GroupMember} deriving (Show) toChatScope :: GroupChatScopeInfo -> GroupChatScope toChatScope = \case GCSIMemberSupport {groupMember_} -> GCSMemberSupport $ groupMemberId' <$> groupMember_ toMsgScope :: GroupInfo -> GroupChatScopeInfo -> MsgScope toMsgScope GroupInfo {membership} = \case GCSIMemberSupport {groupMember_} -> MSMember $ memberId' $ fromMaybe membership groupMember_ chatInfoToRef :: ChatInfo c -> Maybe ChatRef chatInfoToRef = \case DirectChat Contact {contactId} -> Just $ ChatRef CTDirect contactId Nothing GroupChat GroupInfo {groupId} scopeInfo -> Just $ ChatRef CTGroup groupId (toChatScope <$> scopeInfo) LocalChat NoteFolder {noteFolderId} -> Just $ ChatRef CTLocal noteFolderId Nothing ContactRequest UserContactRequest {contactRequestId} -> Just $ ChatRef CTContactRequest contactRequestId Nothing ContactConnection PendingContactConnection {pccConnId} -> Just $ ChatRef CTContactConnection pccConnId Nothing CInfoInvalidJSON {} -> Nothing chatInfoMembership :: ChatInfo c -> Maybe GroupMember chatInfoMembership = \case GroupChat GroupInfo {membership} _scopeInfo -> Just membership _ -> Nothing data JSONChatInfo = JCInfoDirect {contact :: Contact} | JCInfoGroup {groupInfo :: GroupInfo, groupChatScope :: Maybe GroupChatScopeInfo} | JCInfoLocal {noteFolder :: NoteFolder} | JCInfoContactRequest {contactRequest :: UserContactRequest} | JCInfoContactConnection {contactConnection :: PendingContactConnection} | JCInfoInvalidJSON {chatType :: ChatType, json :: J.Object} $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GCSI") ''GroupChatScopeInfo) $(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "JCInfo") ''JSONChatInfo) instance FromJSON JSONChatInfo where parseJSON v@(J.Object o) = $(JQ.mkParseJSON (sumTypeJSON $ dropPrefix "JCInfo") ''JSONChatInfo) v <|> ((`JCInfoInvalidJSON` o) <$> o .: "type") -- fallback for forward compatible remote parser parseJSON invalid = JT.typeMismatch "Object" invalid instance ChatTypeI c => FromJSON (ChatInfo c) where parseJSON v = (\(AChatInfo _ c) -> checkChatType c) <$?> J.parseJSON v instance ToJSON (ChatInfo c) where toJSON = J.toJSON . jsonChatInfo toEncoding = J.toEncoding . jsonChatInfo jsonChatInfo :: ChatInfo c -> JSONChatInfo jsonChatInfo = \case DirectChat c -> JCInfoDirect c GroupChat g s -> JCInfoGroup g s LocalChat l -> JCInfoLocal l ContactRequest g -> JCInfoContactRequest g ContactConnection c -> JCInfoContactConnection c CInfoInvalidJSON c o -> JCInfoInvalidJSON (toChatType c) o data AChatInfo = forall c. ChatTypeI c => AChatInfo (SChatType c) (ChatInfo c) deriving instance Show AChatInfo jsonAChatInfo :: JSONChatInfo -> AChatInfo jsonAChatInfo = \case JCInfoDirect c -> AChatInfo SCTDirect $ DirectChat c JCInfoGroup g s -> AChatInfo SCTGroup $ GroupChat g s JCInfoLocal l -> AChatInfo SCTLocal $ LocalChat l JCInfoContactRequest g -> AChatInfo SCTContactRequest $ ContactRequest g JCInfoContactConnection c -> AChatInfo SCTContactConnection $ ContactConnection c JCInfoInvalidJSON cType o -> case aChatType cType of ACT c -> AChatInfo c $ CInfoInvalidJSON c o instance FromJSON AChatInfo where parseJSON v = jsonAChatInfo <$> J.parseJSON v instance ToJSON AChatInfo where toJSON (AChatInfo _ c) = J.toJSON c toEncoding (AChatInfo _ c) = J.toEncoding c data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem { chatDir :: CIDirection c d, meta :: CIMeta c d, content :: CIContent d, -- The `mentions` map prevents loading all members from UI. -- The key is a name used in the message text, used to look up CIMention. mentions :: Map MemberName CIMention, formattedText :: Maybe MarkdownList, quotedItem :: Maybe (CIQuote c), reactions :: [CIReactionCount], file :: Maybe (CIFile d) } deriving (Show) data CIMention = CIMention { memberId :: MemberId, -- member record can be created later than the mention is received memberRef :: Maybe CIMentionMember } deriving (Eq, Show) data CIMentionMember = CIMentionMember { groupMemberId :: GroupMemberId, displayName :: Text, -- use `displayName` in copy/share actions localAlias :: Maybe Text, -- use `fromMaybe displayName localAlias` in chat view memberRole :: GroupMemberRole -- shown for admins/owners in the message } deriving (Eq, Show) isACIUserMention :: AChatItem -> Bool isACIUserMention (AChatItem _ _ _ ci) = isUserMention ci isUserMention :: ChatItem c d -> Bool isUserMention ChatItem {meta = CIMeta {userMention}} = userMention data CIDirection (c :: ChatType) (d :: MsgDirection) where CIDirectSnd :: CIDirection 'CTDirect 'MDSnd CIDirectRcv :: CIDirection 'CTDirect 'MDRcv CIGroupSnd :: CIDirection 'CTGroup 'MDSnd CIGroupRcv :: GroupMember -> CIDirection 'CTGroup 'MDRcv CIChannelRcv :: CIDirection 'CTGroup 'MDRcv CILocalSnd :: CIDirection 'CTLocal 'MDSnd CILocalRcv :: CIDirection 'CTLocal 'MDRcv deriving instance Show (CIDirection c d) data CCIDirection c = forall d. MsgDirectionI d => CCID (SMsgDirection d) (CIDirection c d) data ACIDirection = forall c d. (ChatTypeI c, MsgDirectionI d) => ACID (SChatType c) (SMsgDirection d) (CIDirection c d) data JSONCIDirection = JCIDirectSnd | JCIDirectRcv | JCIGroupSnd | JCIGroupRcv {groupMember :: GroupMember} | JCIChannelRcv | JCILocalSnd | JCILocalRcv deriving (Show) jsonCIDirection :: CIDirection c d -> JSONCIDirection jsonCIDirection = \case CIDirectSnd -> JCIDirectSnd CIDirectRcv -> JCIDirectRcv CIGroupSnd -> JCIGroupSnd CIGroupRcv m -> JCIGroupRcv m CIChannelRcv -> JCIChannelRcv CILocalSnd -> JCILocalSnd CILocalRcv -> JCILocalRcv jsonACIDirection :: JSONCIDirection -> ACIDirection jsonACIDirection = \case JCIDirectSnd -> ACID SCTDirect SMDSnd CIDirectSnd JCIDirectRcv -> ACID SCTDirect SMDRcv CIDirectRcv JCIGroupSnd -> ACID SCTGroup SMDSnd CIGroupSnd JCIGroupRcv m -> ACID SCTGroup SMDRcv $ CIGroupRcv m JCIChannelRcv -> ACID SCTGroup SMDRcv CIChannelRcv JCILocalSnd -> ACID SCTLocal SMDSnd CILocalSnd JCILocalRcv -> ACID SCTLocal SMDRcv CILocalRcv data CIReactionCount = CIReactionCount {reaction :: MsgReaction, userReacted :: Bool, totalReacted :: Int} deriving (Show) data CChatItem c = forall d. MsgDirectionI d => CChatItem (SMsgDirection d) (ChatItem c d) deriving instance Show (CChatItem c) cChatItemId :: CChatItem c -> ChatItemId cChatItemId (CChatItem _ ci) = chatItemId' ci chatItemId' :: ChatItem c d -> ChatItemId chatItemId' ChatItem {meta = CIMeta {itemId}} = itemId chatItemTs :: CChatItem c -> UTCTime chatItemTs (CChatItem _ ci) = chatItemTs' ci chatItemTs' :: ChatItem c d -> UTCTime chatItemTs' ChatItem {meta = CIMeta {itemTs}} = itemTs ciCreatedAt :: CChatItem c -> UTCTime ciCreatedAt (CChatItem _ ci) = ciCreatedAt' ci ciCreatedAt' :: ChatItem c d -> UTCTime ciCreatedAt' ChatItem {meta = CIMeta {createdAt}} = createdAt chatItemTimed :: ChatItem c d -> Maybe CITimed chatItemTimed ChatItem {meta = CIMeta {itemTimed}} = itemTimed timedDeleteAt' :: CITimed -> Maybe UTCTime timedDeleteAt' CITimed {deleteAt} = deleteAt chatItemMember :: GroupInfo -> ChatItem 'CTGroup d -> Maybe GroupMember chatItemMember GroupInfo {membership} ChatItem {chatDir, meta = CIMeta {showGroupAsSender}} = case chatDir of CIGroupSnd | showGroupAsSender -> Nothing | otherwise -> Just membership CIGroupRcv m -> Just m CIChannelRcv -> Nothing chatItemRcvFromMember :: ChatItem c d -> Maybe GroupMember chatItemRcvFromMember ChatItem {chatDir} = case chatDir of CIGroupRcv m -> Just m _ -> Nothing chatItemIsRcvNew :: ChatItem c d -> Bool chatItemIsRcvNew ChatItem {meta = CIMeta {itemStatus}} = case itemStatus of CISRcvNew -> True _ -> False ciReactionAllowed :: ChatItem c d -> Bool ciReactionAllowed ChatItem {meta = CIMeta {itemDeleted = Just _}} = False ciReactionAllowed ChatItem {content} = isJust $ ciMsgContent content data ChatDirection (c :: ChatType) (d :: MsgDirection) where CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv CDGroupSnd :: GroupInfo -> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDSnd CDGroupRcv :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv CDChannelRcv :: GroupInfo -> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDRcv CDLocalSnd :: NoteFolder -> ChatDirection 'CTLocal 'MDSnd CDLocalRcv :: NoteFolder -> ChatDirection 'CTLocal 'MDRcv toCIDirection :: ChatDirection c d -> CIDirection c d toCIDirection = \case CDDirectSnd _ -> CIDirectSnd CDDirectRcv _ -> CIDirectRcv CDGroupSnd _ _ -> CIGroupSnd CDGroupRcv _ _ m -> CIGroupRcv m CDChannelRcv _ _ -> CIChannelRcv CDLocalSnd _ -> CILocalSnd CDLocalRcv _ -> CILocalRcv toChatInfo :: ChatDirection c d -> ChatInfo c toChatInfo = \case CDDirectSnd c -> DirectChat c CDDirectRcv c -> DirectChat c CDGroupSnd g s -> GroupChat g s CDGroupRcv g s _ -> GroupChat g s CDChannelRcv g s -> GroupChat g s CDLocalSnd l -> LocalChat l CDLocalRcv l -> LocalChat l contactChatDeleted :: ChatDirection c d -> Bool contactChatDeleted = \case CDDirectSnd Contact {chatDeleted} -> chatDeleted CDDirectRcv Contact {chatDeleted} -> chatDeleted _ -> False data NewChatItem d = NewChatItem { createdByMsgId :: Maybe MessageId, itemSent :: SMsgDirection d, itemTs :: ChatItemTs, itemContent :: CIContent d, itemText :: Text, itemStatus :: CIStatus d, itemSharedMsgId :: Maybe SharedMsgId, itemQuotedMsg :: Maybe QuotedMsg, createdAt :: UTCTime } deriving (Show) -- | type to show one chat with messages data Chat c = Chat { chatInfo :: ChatInfo c, chatItems :: [CChatItem c], chatStats :: ChatStats } deriving (Show) data AChat = forall c. ChatTypeI c => AChat (SChatType c) (Chat c) deriving instance Show AChat data ChatStats = ChatStats { unreadCount :: Int, -- returned both in /_get chat initial API and in /_get chats API unreadMentions :: Int, -- returned both in /_get chat initial API and in /_get chats API reportsCount :: Int, -- returned both in /_get chat initial API and in /_get chats API minUnreadItemId :: ChatItemId, unreadChat :: Bool } deriving (Show) emptyChatStats :: ChatStats emptyChatStats = ChatStats 0 0 0 0 False data NavigationInfo = NavigationInfo { afterUnread :: Int, afterTotal :: Int } 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 data JSONAnyChatItem c d = JSONAnyChatItem {chatInfo :: ChatInfo c, chatItem :: ChatItem c d} aChatItems :: AChat -> [AChatItem] aChatItems (AChat ct Chat {chatInfo, chatItems}) = map aChatItem chatItems where aChatItem (CChatItem md ci) = AChatItem ct md chatInfo ci aChatItemId :: AChatItem -> Int64 aChatItemId (AChatItem _ _ _ ci) = chatItemId' ci aChatItemTs :: AChatItem -> UTCTime aChatItemTs (AChatItem _ _ _ ci) = chatItemTs' ci aChatItemDir :: AChatItem -> MsgDirection aChatItemDir (AChatItem _ sMsgDir _ _) = toMsgDirection sMsgDir aChatItemRcvFromMember :: AChatItem -> Maybe GroupMember aChatItemRcvFromMember (AChatItem _ _ _ ci) = chatItemRcvFromMember ci aChatItemIsRcvNew :: AChatItem -> Bool aChatItemIsRcvNew (AChatItem _ _ _ ci) = chatItemIsRcvNew ci updateFileStatus :: forall c d. ChatItem c d -> CIFileStatus d -> ChatItem c d updateFileStatus ci@ChatItem {file} status = case file of Just f -> ci {file = Just (f :: CIFile d) {fileStatus = status}} Nothing -> ci -- This type is not saved to DB, so all JSON encodings are platform-specific data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta { itemId :: ChatItemId, itemTs :: ChatItemTs, itemText :: Text, itemStatus :: CIStatus d, sentViaProxy :: Maybe Bool, itemSharedMsgId :: Maybe SharedMsgId, itemForwarded :: Maybe CIForwardedFrom, itemDeleted :: Maybe (CIDeleted c), itemEdited :: Bool, itemTimed :: Maybe CITimed, itemLive :: Maybe Bool, userMention :: Bool, -- True for messages that mention user or reply to user messages hasLink :: BoolDef, deletable :: Bool, editable :: Bool, forwardedByMember :: Maybe GroupMemberId, showGroupAsSender :: ShowGroupAsSender, msgSigned :: Maybe MsgSigStatus, createdAt :: UTCTime, updatedAt :: UTCTime } deriving (Show) type ShowGroupAsSender = Bool mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> Bool -> Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> Bool -> Maybe MsgSigStatus -> UTCTime -> UTCTime -> CIMeta c d mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned createdAt updatedAt = let deletable = deletable' itemContent itemDeleted itemTs nominalDay currentTs editable = deletable && isNothing itemForwarded hasLink = BoolDef hasLink_ in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, userMention, hasLink, deletable, editable, forwardedByMember, showGroupAsSender, msgSigned, createdAt, updatedAt} deletable' :: forall c d. ChatTypeI c => CIContent d -> Maybe (CIDeleted c) -> UTCTime -> NominalDiffTime -> UTCTime -> Bool deletable' itemContent itemDeleted itemTs allowedInterval currentTs = case itemContent of CISndMsgContent _ -> case chatTypeI @c of SCTLocal -> isNothing itemDeleted _ -> diffUTCTime currentTs itemTs < allowedInterval && isNothing itemDeleted _ -> False dummyMeta :: ChatItemId -> UTCTime -> Text -> CIMeta c 'MDSnd dummyMeta itemId ts itemText = CIMeta { itemId, itemTs = ts, itemText, itemStatus = CISSndNew, sentViaProxy = Nothing, itemSharedMsgId = Nothing, itemForwarded = Nothing, itemDeleted = Nothing, itemEdited = False, itemTimed = Nothing, itemLive = Nothing, userMention = False, hasLink = BoolDef False, deletable = False, editable = False, forwardedByMember = Nothing, showGroupAsSender = False, msgSigned = Nothing, createdAt = ts, updatedAt = ts } 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) ttl' :: CITimed -> Int ttl' CITimed {ttl} = ttl contactTimedTTL :: Contact -> Maybe (Maybe Int) contactTimedTTL Contact {mergedPreferences = ContactUserPreferences {timedMessages = ContactUserPreference {enabled, userPreference}}} | forUser enabled && forContact enabled = Just ttl | otherwise = Nothing where TimedMessagesPreference {ttl} = case userPreference of CUPContact {preference} -> preference CUPUser {preference} -> preference groupTimedTTL :: GroupInfo -> Maybe (Maybe Int) groupTimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}} | enable == FEOn = Just ttl | otherwise = Nothing rcvContactCITimed :: Contact -> Maybe Int -> Maybe CITimed rcvContactCITimed = rcvCITimed_ . contactTimedTTL rcvGroupCITimed :: GroupInfo -> Maybe Int -> Maybe CITimed rcvGroupCITimed = rcvCITimed_ . groupTimedTTL rcvCITimed_ :: Maybe (Maybe Int) -> Maybe Int -> Maybe CITimed rcvCITimed_ chatTTL itemTTL = (`CITimed` Nothing) <$> (chatTTL >> itemTTL) data CIQuote (c :: ChatType) = CIQuote { chatDir :: CIQDirection c, itemId :: Maybe ChatItemId, -- Nothing in case MsgRef references the item the user did not receive yet sharedMsgId :: Maybe SharedMsgId, -- Nothing for the messages from the old clients sentAt :: UTCTime, content :: MsgContent, formattedText :: Maybe MarkdownList } deriving (Show) quoteItemId :: CIQuote c -> Maybe ChatItemId quoteItemId CIQuote {itemId} = itemId data CIReaction (c :: ChatType) (d :: MsgDirection) = CIReaction { chatDir :: CIDirection c d, chatItem :: CChatItem c, sentAt :: UTCTime, reaction :: MsgReaction } deriving (Show) data AnyCIReaction = forall c d. ChatTypeI c => ACIR (SChatType c) (SMsgDirection d) (CIReaction c d) data ACIReaction = forall c d. ChatTypeI c => ACIReaction (SChatType c) (SMsgDirection d) (ChatInfo c) (CIReaction c d) deriving instance Show ACIReaction data JSONCIReaction c d = JSONCIReaction {chatInfo :: ChatInfo c, chatReaction :: CIReaction c d} data MemberReaction = MemberReaction { groupMember :: GroupMember, reactionTs :: UTCTime } deriving (Show) type family ChatTypeQuotable (a :: ChatType) :: Constraint where ChatTypeQuotable 'CTDirect = () ChatTypeQuotable 'CTGroup = () ChatTypeQuotable a = (Int ~ Bool, TypeError ('Type.Text "ChatType " ':<>: 'ShowType a ':<>: 'Type.Text " cannot be quoted")) data CIQDirection (c :: ChatType) where CIQDirectSnd :: CIQDirection 'CTDirect CIQDirectRcv :: CIQDirection 'CTDirect CIQGroupSnd :: CIQDirection 'CTGroup CIQGroupRcv :: Maybe GroupMember -> CIQDirection 'CTGroup -- member can be Nothing in case MsgRef has memberId that the user is not notified about yet deriving instance Show (CIQDirection c) data ACIQDirection = forall c. (ChatTypeI c, ChatTypeQuotable c) => ACIQDirection (SChatType c) (CIQDirection c) jsonCIQDirection :: CIQDirection c -> JSONCIDirection jsonCIQDirection = \case CIQDirectSnd -> JCIDirectSnd CIQDirectRcv -> JCIDirectRcv CIQGroupSnd -> JCIGroupSnd CIQGroupRcv (Just m) -> JCIGroupRcv m CIQGroupRcv Nothing -> JCIChannelRcv jsonACIQDirection :: JSONCIDirection -> Either String ACIQDirection jsonACIQDirection = \case JCIDirectSnd -> Right $ ACIQDirection SCTDirect CIQDirectSnd JCIDirectRcv -> Right $ ACIQDirection SCTDirect CIQDirectRcv JCIGroupSnd -> Right $ ACIQDirection SCTGroup CIQGroupSnd JCIGroupRcv m -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv (Just m) JCIChannelRcv -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv Nothing JCILocalSnd -> Left "unquotable" JCILocalRcv -> Left "unquotable" quoteMsgDirection :: CIQDirection c -> MsgDirection quoteMsgDirection = \case CIQDirectSnd -> MDSnd CIQDirectRcv -> MDRcv CIQGroupSnd -> MDSnd CIQGroupRcv _ -> MDRcv data CIFile (d :: MsgDirection) = CIFile { fileId :: Int64, fileName :: String, fileSize :: Integer, fileSource :: Maybe CryptoFile, -- local file path with optional key and nonce fileStatus :: CIFileStatus d, fileProtocol :: FileProtocol } deriving (Show) data FileProtocol = FPSMP | FPXFTP | FPLocal deriving (Eq, Show, Ord) instance FromField FileProtocol where fromField = fromTextField_ textDecode instance ToField FileProtocol where toField = toField . textEncode instance FromJSON FileProtocol where parseJSON = textParseJSON "FileProtocol" instance ToJSON FileProtocol where toJSON = J.String . textEncode toEncoding = JE.text . textEncode instance TextEncoding FileProtocol where textDecode = \case "smp" -> Just FPSMP "xftp" -> Just FPXFTP "local" -> Just FPLocal _ -> Nothing textEncode = \case FPSMP -> "smp" FPXFTP -> "xftp" FPLocal -> "local" data CIFileStatus (d :: MsgDirection) where CIFSSndStored :: CIFileStatus 'MDSnd CIFSSndTransfer :: {sndProgress :: Int64, sndTotal :: Int64} -> CIFileStatus 'MDSnd CIFSSndCancelled :: CIFileStatus 'MDSnd CIFSSndComplete :: CIFileStatus 'MDSnd CIFSSndError :: {sndFileError :: FileError} -> CIFileStatus 'MDSnd CIFSSndWarning :: {sndFileError :: FileError} -> CIFileStatus 'MDSnd CIFSRcvInvitation :: CIFileStatus 'MDRcv CIFSRcvAccepted :: CIFileStatus 'MDRcv CIFSRcvTransfer :: {rcvProgress :: Int64, rcvTotal :: Int64} -> CIFileStatus 'MDRcv CIFSRcvAborted :: CIFileStatus 'MDRcv CIFSRcvComplete :: CIFileStatus 'MDRcv CIFSRcvCancelled :: CIFileStatus 'MDRcv CIFSRcvError :: {rcvFileError :: FileError} -> CIFileStatus 'MDRcv CIFSRcvWarning :: {rcvFileError :: FileError} -> CIFileStatus 'MDRcv CIFSInvalid :: {text :: Text} -> CIFileStatus 'MDSnd deriving instance Eq (CIFileStatus d) deriving instance Show (CIFileStatus d) ciFileEnded :: CIFileStatus d -> Bool ciFileEnded = \case CIFSSndStored -> False CIFSSndTransfer {} -> False CIFSSndCancelled -> True CIFSSndComplete -> True CIFSSndError {} -> True CIFSSndWarning {} -> False CIFSRcvInvitation -> False CIFSRcvAccepted -> False CIFSRcvTransfer {} -> False CIFSRcvAborted -> True CIFSRcvCancelled -> True CIFSRcvComplete -> True CIFSRcvError {} -> True CIFSRcvWarning {} -> False CIFSInvalid {} -> True ciFileLoaded :: CIFileStatus d -> Bool ciFileLoaded = \case CIFSSndStored -> True CIFSSndTransfer {} -> True CIFSSndComplete -> True CIFSSndCancelled -> True CIFSSndError {} -> True CIFSSndWarning {} -> True CIFSRcvInvitation -> False CIFSRcvAccepted -> False CIFSRcvTransfer {} -> False CIFSRcvAborted -> False CIFSRcvCancelled -> False CIFSRcvComplete -> True CIFSRcvError {} -> False CIFSRcvWarning {} -> False CIFSInvalid {} -> False data ForwardFileError = FFENotAccepted FileTransferId | FFEInProgress | FFEFailed | FFEMissing deriving (Eq, Ord) ciFileForwardError :: FileTransferId -> CIFileStatus d -> Maybe ForwardFileError ciFileForwardError fId = \case CIFSSndStored -> Nothing CIFSSndTransfer {} -> Nothing CIFSSndComplete -> Nothing CIFSSndCancelled -> Nothing CIFSSndError {} -> Nothing CIFSSndWarning {} -> Nothing CIFSRcvInvitation -> Just $ FFENotAccepted fId CIFSRcvAccepted -> Just FFEInProgress CIFSRcvTransfer {} -> Just FFEInProgress CIFSRcvAborted -> Just $ FFENotAccepted fId CIFSRcvCancelled -> Just FFEFailed CIFSRcvComplete -> Nothing CIFSRcvError {} -> Just FFEFailed CIFSRcvWarning {} -> Just FFEFailed CIFSInvalid {} -> Just FFEFailed data ACIFileStatus = forall d. MsgDirectionI d => AFS (SMsgDirection d) (CIFileStatus d) deriving instance Show ACIFileStatus instance MsgDirectionI d => StrEncoding (CIFileStatus d) where strEncode = \case CIFSSndStored -> "snd_stored" CIFSSndTransfer sent total -> strEncode (Str "snd_transfer", sent, total) CIFSSndCancelled -> "snd_cancelled" CIFSSndComplete -> "snd_complete" CIFSSndError sndFileErr -> "snd_error " <> strEncode sndFileErr CIFSSndWarning sndFileErr -> "snd_warning " <> strEncode sndFileErr CIFSRcvInvitation -> "rcv_invitation" CIFSRcvAccepted -> "rcv_accepted" CIFSRcvTransfer rcvd total -> strEncode (Str "rcv_transfer", rcvd, total) CIFSRcvAborted -> "rcv_aborted" CIFSRcvComplete -> "rcv_complete" CIFSRcvCancelled -> "rcv_cancelled" CIFSRcvError rcvFileErr -> "rcv_error " <> strEncode rcvFileErr CIFSRcvWarning rcvFileErr -> "rcv_warning " <> strEncode rcvFileErr CIFSInvalid {} -> "invalid" strP = (\(AFS _ st) -> checkDirection st) <$?> strP instance StrEncoding ACIFileStatus where strEncode (AFS _ s) = strEncode s strP = (statusP <* A.endOfInput) -- endOfInput to make it fail on partial correct parse <|> (AFS SMDSnd . CIFSInvalid . safeDecodeUtf8 <$> A.takeByteString) where statusP = A.takeTill (== ' ') >>= \case "snd_stored" -> pure $ AFS SMDSnd CIFSSndStored "snd_transfer" -> AFS SMDSnd <$> progress CIFSSndTransfer "snd_cancelled" -> pure $ AFS SMDSnd CIFSSndCancelled "snd_complete" -> pure $ AFS SMDSnd CIFSSndComplete "snd_error" -> AFS SMDSnd . CIFSSndError <$> ((A.space *> strP) <|> pure (FileErrOther "")) -- alternative for backwards compatibility "snd_warning" -> AFS SMDSnd . CIFSSndWarning <$> (A.space *> strP) "rcv_invitation" -> pure $ AFS SMDRcv CIFSRcvInvitation "rcv_accepted" -> pure $ AFS SMDRcv CIFSRcvAccepted "rcv_transfer" -> AFS SMDRcv <$> progress CIFSRcvTransfer "rcv_aborted" -> pure $ AFS SMDRcv CIFSRcvAborted "rcv_complete" -> pure $ AFS SMDRcv CIFSRcvComplete "rcv_cancelled" -> pure $ AFS SMDRcv CIFSRcvCancelled "rcv_error" -> AFS SMDRcv . CIFSRcvError <$> ((A.space *> strP) <|> pure (FileErrOther "")) -- alternative for backwards compatibility "rcv_warning" -> AFS SMDRcv . CIFSRcvWarning <$> (A.space *> strP) _ -> fail "bad file status" progress :: (Int64 -> Int64 -> a) -> A.Parser a progress f = f <$> num <*> num <|> pure (f 0 1) num = A.space *> A.decimal data JSONCIFileStatus = JCIFSSndStored | JCIFSSndTransfer {sndProgress :: Int64, sndTotal :: Int64} | JCIFSSndCancelled | JCIFSSndComplete | JCIFSSndError {sndFileError :: FileError} | JCIFSSndWarning {sndFileError :: FileError} | JCIFSRcvInvitation | JCIFSRcvAccepted | JCIFSRcvTransfer {rcvProgress :: Int64, rcvTotal :: Int64} | JCIFSRcvAborted | JCIFSRcvComplete | JCIFSRcvCancelled | JCIFSRcvError {rcvFileError :: FileError} | JCIFSRcvWarning {rcvFileError :: FileError} | JCIFSInvalid {text :: Text} jsonCIFileStatus :: CIFileStatus d -> JSONCIFileStatus jsonCIFileStatus = \case CIFSSndStored -> JCIFSSndStored CIFSSndTransfer sent total -> JCIFSSndTransfer sent total CIFSSndCancelled -> JCIFSSndCancelled CIFSSndComplete -> JCIFSSndComplete CIFSSndError sndFileErr -> JCIFSSndError sndFileErr CIFSSndWarning sndFileErr -> JCIFSSndWarning sndFileErr CIFSRcvInvitation -> JCIFSRcvInvitation CIFSRcvAccepted -> JCIFSRcvAccepted CIFSRcvTransfer rcvd total -> JCIFSRcvTransfer rcvd total CIFSRcvAborted -> JCIFSRcvAborted CIFSRcvComplete -> JCIFSRcvComplete CIFSRcvCancelled -> JCIFSRcvCancelled CIFSRcvError rcvFileErr -> JCIFSRcvError rcvFileErr CIFSRcvWarning rcvFileErr -> JCIFSRcvWarning rcvFileErr CIFSInvalid text -> JCIFSInvalid text aciFileStatusJSON :: JSONCIFileStatus -> ACIFileStatus aciFileStatusJSON = \case JCIFSSndStored -> AFS SMDSnd CIFSSndStored JCIFSSndTransfer sent total -> AFS SMDSnd $ CIFSSndTransfer sent total JCIFSSndCancelled -> AFS SMDSnd CIFSSndCancelled JCIFSSndComplete -> AFS SMDSnd CIFSSndComplete JCIFSSndError sndFileErr -> AFS SMDSnd (CIFSSndError sndFileErr) JCIFSSndWarning sndFileErr -> AFS SMDSnd (CIFSSndWarning sndFileErr) JCIFSRcvInvitation -> AFS SMDRcv CIFSRcvInvitation JCIFSRcvAccepted -> AFS SMDRcv CIFSRcvAccepted JCIFSRcvTransfer rcvd total -> AFS SMDRcv $ CIFSRcvTransfer rcvd total JCIFSRcvAborted -> AFS SMDRcv CIFSRcvAborted JCIFSRcvComplete -> AFS SMDRcv CIFSRcvComplete JCIFSRcvCancelled -> AFS SMDRcv CIFSRcvCancelled JCIFSRcvError rcvFileErr -> AFS SMDRcv (CIFSRcvError rcvFileErr) JCIFSRcvWarning rcvFileErr -> AFS SMDRcv (CIFSRcvWarning rcvFileErr) JCIFSInvalid text -> AFS SMDSnd $ CIFSInvalid text data FileError = FileErrAuth | FileErrBlocked {server :: String, blockInfo :: BlockingInfo} | FileErrNoFile | FileErrRelay {srvError :: SrvError} | FileErrOther {fileError :: Text} deriving (Eq, Show) instance StrEncoding FileError where strEncode = \case FileErrAuth -> "auth" FileErrBlocked srv info -> "blocked " <> strEncode (srv, info) FileErrNoFile -> "no_file" FileErrRelay srvErr -> "relay " <> strEncode srvErr FileErrOther e -> "other " <> encodeUtf8 e strP = A.takeWhile1 (/= ' ') >>= \case "auth" -> pure FileErrAuth "blocked" -> FileErrBlocked <$> _strP <*> _strP "no_file" -> pure FileErrNoFile "relay" -> FileErrRelay <$> _strP "other" -> FileErrOther . safeDecodeUtf8 <$> (A.space *> A.takeByteString) s -> FileErrOther . safeDecodeUtf8 . (s <>) <$> A.takeByteString -- to conveniently read file data from db data CIFileInfo = CIFileInfo { fileId :: Int64, fileStatus :: Maybe ACIFileStatus, filePath :: Maybe FilePath } deriving (Show) mkCIFileInfo :: MsgDirectionI d => CIFile d -> CIFileInfo mkCIFileInfo CIFile {fileId, fileStatus, fileSource} = CIFileInfo { fileId, fileStatus = Just $ AFS msgDirection fileStatus, filePath = CF.filePath <$> fileSource } data CIStatus (d :: MsgDirection) where CISSndNew :: CIStatus 'MDSnd CISSndSent :: SndCIStatusProgress -> CIStatus 'MDSnd CISSndRcvd :: MsgReceiptStatus -> SndCIStatusProgress -> CIStatus 'MDSnd CISSndErrorAuth :: CIStatus 'MDSnd -- deprecated CISSndError :: SndError -> CIStatus 'MDSnd CISSndWarning :: SndError -> CIStatus 'MDSnd CISRcvNew :: CIStatus 'MDRcv CISRcvRead :: CIStatus 'MDRcv CISInvalid :: Text -> CIStatus 'MDSnd deriving instance Eq (CIStatus d) deriving instance Show (CIStatus d) data ACIStatus = forall d. MsgDirectionI d => ACIStatus (SMsgDirection d) (CIStatus d) deriving instance Show ACIStatus instance MsgDirectionI d => StrEncoding (CIStatus d) where strEncode = \case CISSndNew -> "snd_new" CISSndSent sndProgress -> "snd_sent " <> strEncode sndProgress CISSndRcvd msgRcptStatus sndProgress -> "snd_rcvd " <> strEncode msgRcptStatus <> " " <> strEncode sndProgress CISSndErrorAuth -> "snd_error_auth" CISSndError sndErr -> "snd_error " <> strEncode sndErr CISSndWarning sndErr -> "snd_warning " <> strEncode sndErr CISRcvNew -> "rcv_new" CISRcvRead -> "rcv_read" CISInvalid {} -> "invalid" strP = (\(ACIStatus _ st) -> checkDirection st) <$?> strP instance StrEncoding ACIStatus where strEncode (ACIStatus _ s) = strEncode s strP = (statusP <* A.endOfInput) -- endOfInput to make it fail on partial correct parse, e.g. "snd_rcvd ok complete" <|> (ACIStatus SMDSnd . CISInvalid . safeDecodeUtf8 <$> A.takeByteString) where statusP = A.takeTill (== ' ') >>= \case "snd_new" -> pure $ ACIStatus SMDSnd CISSndNew "snd_sent" -> ACIStatus SMDSnd . CISSndSent <$> ((A.space *> strP) <|> pure SSPComplete) "snd_rcvd" -> ACIStatus SMDSnd <$> (CISSndRcvd <$> (A.space *> strP) <*> ((A.space *> strP) <|> pure SSPComplete)) "snd_error_auth" -> pure $ ACIStatus SMDSnd CISSndErrorAuth "snd_error" -> ACIStatus SMDSnd . CISSndError <$> (A.space *> strP) "snd_warning" -> ACIStatus SMDSnd . CISSndWarning <$> (A.space *> strP) "rcv_new" -> pure $ ACIStatus SMDRcv CISRcvNew "rcv_read" -> pure $ ACIStatus SMDRcv CISRcvRead _ -> fail "bad status" -- see serverHostError in agent data SndError = SndErrAuth | SndErrQuota | SndErrExpired -- TIMEOUT/NETWORK errors | SndErrRelay {srvError :: SrvError} -- BROKER errors (other than TIMEOUT/NETWORK) | SndErrProxy {proxyServer :: String, srvError :: SrvError} -- SMP PROXY errors | SndErrProxyRelay {proxyServer :: String, srvError :: SrvError} -- PROXY BROKER errors | SndErrOther {sndError :: Text} -- other errors deriving (Eq, Show) data SrvError = SrvErrHost | SrvErrVersion | SrvErrOther {srvError :: Text} deriving (Eq, Show) instance StrEncoding SndError where strEncode = \case SndErrAuth -> "auth" SndErrQuota -> "quota" SndErrExpired -> "expired" SndErrRelay srvErr -> "relay " <> strEncode srvErr SndErrProxy proxy srvErr -> "proxy " <> encodeUtf8 (T.pack proxy) <> " " <> strEncode srvErr SndErrProxyRelay proxy srvErr -> "proxy_relay " <> encodeUtf8 (T.pack proxy) <> " " <> strEncode srvErr SndErrOther e -> "other " <> encodeUtf8 e strP = A.takeWhile1 (/= ' ') >>= \case "auth" -> pure SndErrAuth "quota" -> pure SndErrQuota "expired" -> pure SndErrExpired "relay" -> SndErrRelay <$> (A.space *> strP) "proxy" -> SndErrProxy . T.unpack . safeDecodeUtf8 <$> (A.space *> A.takeWhile1 (/= ' ') <* A.space) <*> strP "proxy_relay" -> SndErrProxyRelay . T.unpack . safeDecodeUtf8 <$> (A.space *> A.takeWhile1 (/= ' ') <* A.space) <*> strP "other" -> SndErrOther . safeDecodeUtf8 <$> (A.space *> A.takeByteString) s -> SndErrOther . safeDecodeUtf8 . (s <>) <$> A.takeByteString -- for backward compatibility with `CISSndError String` instance StrEncoding SrvError where strEncode = \case SrvErrHost -> "host" SrvErrVersion -> "version" SrvErrOther e -> "other " <> encodeUtf8 e strP = A.takeWhile1 (/= ' ') >>= \case "host" -> pure SrvErrHost "version" -> pure SrvErrVersion "other" -> SrvErrOther . safeDecodeUtf8 <$> (A.space *> A.takeByteString) _ -> fail "bad SrvError" data JSONCIStatus = JCISSndNew | JCISSndSent {sndProgress :: SndCIStatusProgress} | JCISSndRcvd {msgRcptStatus :: MsgReceiptStatus, sndProgress :: SndCIStatusProgress} | JCISSndErrorAuth -- deprecated | JCISSndError {agentError :: SndError} | JCISSndWarning {agentError :: SndError} | JCISRcvNew | JCISRcvRead | JCISInvalid {text :: Text} deriving (Show) jsonCIStatus :: CIStatus d -> JSONCIStatus jsonCIStatus = \case CISSndNew -> JCISSndNew CISSndSent sndProgress -> JCISSndSent sndProgress CISSndRcvd msgRcptStatus sndProgress -> JCISSndRcvd msgRcptStatus sndProgress CISSndErrorAuth -> JCISSndErrorAuth CISSndError sndErr -> JCISSndError sndErr CISSndWarning sndErr -> JCISSndWarning sndErr CISRcvNew -> JCISRcvNew CISRcvRead -> JCISRcvRead CISInvalid text -> JCISInvalid text jsonACIStatus :: JSONCIStatus -> ACIStatus jsonACIStatus = \case JCISSndNew -> ACIStatus SMDSnd CISSndNew JCISSndSent sndProgress -> ACIStatus SMDSnd $ CISSndSent sndProgress JCISSndRcvd msgRcptStatus sndProgress -> ACIStatus SMDSnd $ CISSndRcvd msgRcptStatus sndProgress JCISSndErrorAuth -> ACIStatus SMDSnd CISSndErrorAuth JCISSndError sndErr -> ACIStatus SMDSnd $ CISSndError sndErr JCISSndWarning sndErr -> ACIStatus SMDSnd $ CISSndWarning sndErr JCISRcvNew -> ACIStatus SMDRcv CISRcvNew JCISRcvRead -> ACIStatus SMDRcv CISRcvRead JCISInvalid text -> ACIStatus SMDSnd $ CISInvalid text 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 | isCIReport content -> CISRcvRead | ciRequiresAttention content -> ciStatusNew | otherwise -> CISRcvRead membersGroupItemStatus :: [(GroupSndStatus, Int)] -> CIStatus 'MDSnd membersGroupItemStatus memStatusCounts | rcvdOk == total = CISSndRcvd MROk SSPComplete | rcvdOk + rcvdBad == total = CISSndRcvd MRBadMsgHash SSPComplete | rcvdBad > 0 = CISSndRcvd MRBadMsgHash SSPPartial | rcvdOk > 0 = CISSndRcvd MROk SSPPartial | sent == total = CISSndSent SSPComplete | sent > 0 = CISSndSent SSPPartial | otherwise = CISSndNew where total = sum $ map snd memStatusCounts rcvdOk = fromMaybe 0 $ lookup (GSSRcvd MROk) memStatusCounts rcvdBad = fromMaybe 0 $ lookup (GSSRcvd MRBadMsgHash) memStatusCounts sent = fromMaybe 0 $ lookup GSSSent memStatusCounts data SndCIStatusProgress = SSPPartial | SSPComplete deriving (Eq, Show) instance StrEncoding SndCIStatusProgress where strEncode = \case SSPPartial -> "partial" SSPComplete -> "complete" strP = A.takeWhile1 (/= ' ') >>= \case "partial" -> pure SSPPartial "complete" -> pure SSPComplete _ -> fail "bad SndCIStatusProgress" data GroupSndStatus = GSSNew | GSSForwarded | GSSInactive | GSSSent | GSSRcvd {msgRcptStatus :: MsgReceiptStatus} | GSSError {agentError :: SndError} | GSSWarning {agentError :: SndError} | GSSInvalid {text :: Text} deriving instance Eq GroupSndStatus deriving instance Show GroupSndStatus -- Preserve CIStatus encoding for backwards compatibility instance StrEncoding GroupSndStatus where strEncode = \case GSSNew -> "snd_new" GSSForwarded -> "snd_forwarded" GSSInactive -> "snd_inactive" GSSSent -> "snd_sent complete" GSSRcvd msgRcptStatus -> "snd_rcvd " <> strEncode msgRcptStatus <> " complete" GSSError sndErr -> "snd_error " <> strEncode sndErr GSSWarning sndErr -> "snd_warning " <> strEncode sndErr GSSInvalid {} -> "invalid" strP = (statusP <* A.endOfInput) -- see ACIStatus decoding <|> (GSSInvalid . safeDecodeUtf8 <$> A.takeByteString) where statusP = A.takeTill (== ' ') >>= \case "snd_new" -> pure GSSNew "snd_forwarded" -> pure GSSForwarded "snd_inactive" -> pure GSSInactive "snd_sent" -> GSSSent <$ " complete" "snd_rcvd" -> GSSRcvd <$> (_strP <* " complete") "snd_error_auth" -> pure $ GSSError SndErrAuth "snd_error" -> GSSError <$> (A.space *> strP) "snd_warning" -> GSSWarning <$> (A.space *> strP) _ -> fail "bad status" type ChatItemId = Int64 type ChatItemTs = UTCTime data SndMessage = SndMessage { msgId :: MessageId, sharedMsgId :: SharedMsgId, msgBody :: MsgBody, signedMsg_ :: Maybe SignedMsg } deriving (Show) data NewRcvMessage e = NewRcvMessage { chatMsgEvent :: ChatMsgEvent e, verifiedMsg :: VerifiedMsg e, brokerTs :: UTCTime } data RcvMessage = RcvMessage { msgId :: MessageId, chatMsgEvent :: AChatMsgEvent, sharedMsgId_ :: Maybe SharedMsgId, msgSigned :: Maybe MsgSigStatus, forwardedByMember :: Maybe GroupMemberId } type MessageId = Int64 data ConnOrGroupId = ConnectionId Int64 | GroupId Int64 data SndMsgDelivery = SndMsgDelivery { connId :: Int64, agentMsgId :: AgentMsgId } deriving (Show) data RcvMsgDelivery = RcvMsgDelivery { connId :: Int64, agentMsgId :: AgentMsgId, agentMsgMeta :: MsgMeta } deriving (Show) data RcvMsgInfo = RcvMsgInfo { msgId :: Int64, msgDeliveryId :: Int64, msgDeliveryStatus :: Text, agentMsgId :: AgentMsgId, agentMsgMeta :: Text } deriving (Show) data MsgMetaJSON = MsgMetaJSON { integrity :: Text, rcvId :: Int64, rcvTs :: UTCTime, serverId :: Text, serverTs :: UTCTime, sndId :: Int64 } deriving (Eq, Show) msgMetaToJson :: MsgMeta -> MsgMetaJSON msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sndMsgId = sndId} = MsgMetaJSON { integrity = (decodeLatin1 . strEncode) integrity, rcvId, rcvTs, serverId = (decodeLatin1 . B64.encode) serverId, serverTs, sndId } data MsgDeliveryStatus (d :: MsgDirection) where MDSRcvAgent :: MsgDeliveryStatus 'MDRcv MDSRcvAcknowledged :: MsgDeliveryStatus 'MDRcv -- not used MDSSndPending :: MsgDeliveryStatus 'MDSnd MDSSndAgent :: MsgDeliveryStatus 'MDSnd MDSSndSent :: MsgDeliveryStatus 'MDSnd MDSSndRcvd :: MsgReceiptStatus -> MsgDeliveryStatus 'MDSnd MDSSndRead :: MsgDeliveryStatus 'MDSnd data AMsgDeliveryStatus = forall d. AMDS (SMsgDirection d) (MsgDeliveryStatus d) instance (Typeable d, MsgDirectionI d) => FromField (MsgDeliveryStatus d) where fromField = fromTextField_ msgDeliveryStatusT' instance ToField (MsgDeliveryStatus d) where toField = toField . serializeMsgDeliveryStatus serializeMsgDeliveryStatus :: MsgDeliveryStatus d -> Text serializeMsgDeliveryStatus = \case MDSRcvAgent -> "rcv_agent" MDSRcvAcknowledged -> "rcv_acknowledged" MDSSndPending -> "snd_pending" MDSSndAgent -> "snd_agent" MDSSndSent -> "snd_sent" MDSSndRcvd status -> "snd_rcvd " <> safeDecodeUtf8 (strEncode status) MDSSndRead -> "snd_read" msgDeliveryStatusT :: Text -> Maybe AMsgDeliveryStatus msgDeliveryStatusT = eitherToMaybe . parseAll statusP . encodeUtf8 where statusP = A.takeTill (== ' ') >>= \case "rcv_agent" -> pure $ AMDS SMDRcv MDSRcvAgent "rcv_acknowledged" -> pure $ AMDS SMDRcv MDSRcvAcknowledged "snd_pending" -> pure $ AMDS SMDSnd MDSSndPending "snd_agent" -> pure $ AMDS SMDSnd MDSSndAgent "snd_sent" -> pure $ AMDS SMDSnd MDSSndSent "snd_rcvd" -> AMDS SMDSnd . MDSSndRcvd <$> (A.space *> strP) "snd_read" -> pure $ AMDS SMDSnd MDSSndRead _ -> fail "bad AMsgDeliveryStatus" msgDeliveryStatusT' :: forall d. MsgDirectionI d => Text -> Maybe (MsgDeliveryStatus d) msgDeliveryStatusT' s = msgDeliveryStatusT s >>= \(AMDS d st) -> case testEquality d (msgDirection @d) of Just Refl -> Just st _ -> Nothing data CIDeleted (c :: ChatType) where CIDeleted :: Maybe UTCTime -> CIDeleted c CIBlocked :: Maybe UTCTime -> CIDeleted 'CTGroup CIBlockedByAdmin :: Maybe UTCTime -> CIDeleted 'CTGroup CIModerated :: Maybe UTCTime -> GroupMember -> CIDeleted 'CTGroup deriving instance Show (CIDeleted c) data ACIDeleted = forall c. ChatTypeI c => ACIDeleted (SChatType c) (CIDeleted c) data JSONCIDeleted = JCIDDeleted {deletedTs :: Maybe UTCTime, chatType :: ChatType} | JCIDBlocked {deletedTs :: Maybe UTCTime} | JCIDBlockedByAdmin {deletedTs :: Maybe UTCTime} | JCIDModerated {deletedTs :: Maybe UTCTime, byGroupMember :: GroupMember} deriving (Show) jsonCIDeleted :: forall d. ChatTypeI d => CIDeleted d -> JSONCIDeleted jsonCIDeleted = \case CIDeleted ts -> JCIDDeleted ts (toChatType $ chatTypeI @d) CIBlocked ts -> JCIDBlocked ts CIBlockedByAdmin ts -> JCIDBlockedByAdmin ts CIModerated ts m -> JCIDModerated ts m jsonACIDeleted :: JSONCIDeleted -> ACIDeleted jsonACIDeleted = \case JCIDDeleted ts cType -> case aChatType cType of ACT c -> ACIDeleted c $ CIDeleted ts JCIDBlocked ts -> ACIDeleted SCTGroup $ CIBlocked ts JCIDBlockedByAdmin ts -> ACIDeleted SCTGroup $ CIBlockedByAdmin ts JCIDModerated ts m -> ACIDeleted SCTGroup (CIModerated ts m) itemDeletedTs :: CIDeleted d -> Maybe UTCTime itemDeletedTs = \case CIDeleted ts -> ts CIBlocked ts -> ts CIBlockedByAdmin ts -> ts CIModerated ts _ -> ts data CIForwardedFrom = CIFFUnknown | CIFFContact {chatName :: Text, msgDir :: MsgDirection, contactId :: Maybe ContactId, chatItemId :: Maybe ChatItemId} | CIFFGroup {chatName :: Text, msgDir :: MsgDirection, groupId :: Maybe GroupId, chatItemId :: Maybe ChatItemId} deriving (Show) cmForwardedFrom :: AChatMsgEvent -> Maybe CIForwardedFrom cmForwardedFrom = \case ACME _ (XMsgNew (MCForward _)) -> Just CIFFUnknown _ -> Nothing data CIForwardedFromTag = CIFFUnknown_ | CIFFContact_ | CIFFGroup_ instance FromField CIForwardedFromTag where fromField = fromTextField_ textDecode instance ToField CIForwardedFromTag where toField = toField . textEncode instance TextEncoding CIForwardedFromTag where textDecode = \case "unknown" -> Just CIFFUnknown_ "contact" -> Just CIFFContact_ "group" -> Just CIFFGroup_ _ -> Nothing textEncode = \case CIFFUnknown_ -> "unknown" CIFFContact_ -> "contact" CIFFGroup_ -> "group" data ChatItemInfo = ChatItemInfo { itemVersions :: [ChatItemVersion], memberDeliveryStatuses :: Maybe (NonEmpty MemberDeliveryStatus), forwardedFromChatItem :: Maybe AChatItem } deriving (Show) data ChatItemVersion = ChatItemVersion { chatItemVersionId :: Int64, msgContent :: MsgContent, formattedText :: Maybe MarkdownList, itemVersionTs :: UTCTime, createdAt :: UTCTime } deriving (Eq, Show) mkItemVersion :: ChatItem c d -> Maybe ChatItemVersion mkItemVersion ChatItem {content, formattedText, meta} = version <$> ciMsgContent content where CIMeta {itemId, itemTs, createdAt} = meta version mc = ChatItemVersion { chatItemVersionId = itemId, msgContent = mc, formattedText, itemVersionTs = itemTs, createdAt = createdAt } data MemberDeliveryStatus = MemberDeliveryStatus { groupMemberId :: GroupMemberId, memberDeliveryStatus :: GroupSndStatus, sentViaProxy :: Maybe Bool } deriving (Eq, Show) data CIModeration = CIModeration { moderationId :: Int64, moderatorMember :: GroupMember, createdByMsgId :: MessageId, moderatedAt :: UTCTime } deriving (Show) 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 (sumTypeJSON $ dropPrefix "CIFF") ''CIForwardedFrom) $(JQ.deriveJSON defaultJSON ''CITimed) $(JQ.deriveJSON (enumJSON $ dropPrefix "SSP") ''SndCIStatusProgress) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "SrvErr") ''SrvError) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "SndErr") ''SndError) $(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 (sumTypeJSON $ dropPrefix "GSS") ''GroupSndStatus) instance ToField GroupSndStatus where toField = toField . decodeLatin1 . strEncode instance FromField GroupSndStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 $(JQ.deriveJSON defaultJSON ''MemberDeliveryStatus) $(JQ.deriveJSON defaultJSON ''ChatItemVersion) 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 "FileErr") ''FileError) $(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 "GCS") ''GroupChatScope) $(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 = (jsonACIQDirection . fromMaybe JCIChannelRcv >=> \(ACIQDirection _ x) -> checkChatType x) <$?> 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) $(JQ.deriveJSON defaultJSON ''CIMentionMember) $(JQ.deriveJSON defaultJSON ''CIMention) 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) -- if JSON encoding changes, update AChatItem type definition in bots/src/API/Docs/Types.hs 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 ''ChatItemInfo) $(JQ.deriveJSON defaultJSON ''ChatStats) $(JQ.deriveJSON defaultJSON ''NavigationInfo) 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) -- if JSON encoding changes, update ACIReaction type definition in bots/src/API/Docs/Types.hs 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 ''MemberReaction) $(JQ.deriveJSON defaultJSON ''MsgMetaJSON) msgMetaJson :: MsgMeta -> Text msgMetaJson = decodeLatin1 . LB.toStrict . J.encode . msgMetaToJson $(JQ.deriveJSON defaultJSON ''RcvMsgInfo)