{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Library.Internal where import qualified Codec.Compression.Zstd as Z1 import Control.Applicative ((<|>)) import Control.Concurrent.STM (retry) import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isDigit) import Data.Containers.ListUtils (nubOrd) import Data.Either (partitionEithers, rights) import Data.Fixed (div') import Data.Foldable (foldr') import Data.Functor (($>)) import Data.Functor.Identity import Data.Int (Int64) import Data.List (find, foldl', mapAccumL, partition) import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Time (addUTCTime) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToDiffTime) import Simplex.Chat.Call import Simplex.Chat.Controller import Simplex.Chat.Files import Simplex.Chat.Markdown import Simplex.Chat.Messages import Simplex.Chat.Messages.Batch (MsgBatch (..), batchMessages) import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent.Events import Simplex.Chat.Operators import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol import Simplex.Chat.Store import Simplex.Chat.Store.ContactRequest import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Files import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Messages import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.Chat.Types.MemberRelations import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Chat.Util (encryptFile, shuffle) import Simplex.FileTransfer.Description (FileDescriptionURI (..), ValidFileDescription) import qualified Simplex.FileTransfer.Description as FD import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.Messaging.Agent import Simplex.Messaging.Agent.Client (getFastNetworkConfig, ipAddressProtected, withLockMap) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), ServerCfg (..)) import Simplex.Messaging.Agent.Lock (withLock) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..)) import Simplex.Messaging.Compression (compressionLevel) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (MsgBody, MsgFlags (..), ProtoServerWithAuth (..), ProtocolServer, ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer) import qualified Simplex.Messaging.Protocol as SMP import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util import Simplex.Messaging.Version import System.FilePath (takeFileName, ()) import System.IO (Handle, IOMode (..), hFlush) import UnliftIO.Concurrent (forkFinally, mkWeakThreadId) import UnliftIO.Directory import UnliftIO.IO (hClose, openFile) import UnliftIO.STM maxMsgReactions :: Int maxMsgReactions = 3 maxRcvMentions :: Int maxRcvMentions = 5 maxSndMentions :: Int maxSndMentions = 3 withChatLock :: Text -> CM a -> CM a withChatLock name action = asks chatLock >>= \l -> withLock l name action withEntityLock :: Text -> ChatLockEntity -> CM a -> CM a withEntityLock name entity action = do chatLock <- asks chatLock ls <- asks entityLocks atomically $ unlessM (isEmptyTMVar chatLock) retry withLockMap ls entity name action withInvitationLock :: Text -> ByteString -> CM a -> CM a withInvitationLock name = withEntityLock name . CLInvitation {-# INLINE withInvitationLock #-} withConnectionLock :: Text -> Int64 -> CM a -> CM a withConnectionLock name = withEntityLock name . CLConnection {-# INLINE withConnectionLock #-} withContactLock :: Text -> ContactId -> CM a -> CM a withContactLock name = withEntityLock name . CLContact {-# INLINE withContactLock #-} withGroupLock :: Text -> GroupId -> CM a -> CM a withGroupLock name = withEntityLock name . CLGroup {-# INLINE withGroupLock #-} withUserContactLock :: Text -> Int64 -> CM a -> CM a withUserContactLock name = withEntityLock name . CLUserContact {-# INLINE withUserContactLock #-} withContactRequestLock :: Text -> Int64 -> CM a -> CM a withContactRequestLock name = withEntityLock name . CLContactRequest {-# INLINE withContactRequestLock #-} withFileLock :: Text -> Int64 -> CM a -> CM a withFileLock name = withEntityLock name . CLFile {-# INLINE withFileLock #-} useServerCfgs :: forall p. UserProtocol p => SProtocolType p -> RandomAgentServers -> [(Text, ServerOperator)] -> [UserServer p] -> NonEmpty (ServerCfg p) useServerCfgs p RandomAgentServers {smpServers, xftpServers} opDomains = fromMaybe (rndAgentServers p) . L.nonEmpty . agentServerCfgs p opDomains where rndAgentServers :: SProtocolType p -> NonEmpty (ServerCfg p) rndAgentServers = \case SPSMP -> smpServers SPXFTP -> xftpServers contactCITimed :: Contact -> CM (Maybe CITimed) contactCITimed ct = sndContactCITimed False ct Nothing sndContactCITimed :: Bool -> Contact -> Maybe Int -> CM (Maybe CITimed) sndContactCITimed live = sndCITimed_ live . contactTimedTTL sndGroupCITimed :: Bool -> GroupInfo -> Maybe Int -> CM (Maybe CITimed) sndGroupCITimed live = sndCITimed_ live . groupTimedTTL sndCITimed_ :: Bool -> Maybe (Maybe Int) -> Maybe Int -> CM (Maybe CITimed) sndCITimed_ live chatTTL itemTTL = forM (chatTTL >>= (itemTTL <|>)) $ \ttl -> CITimed ttl <$> if live then pure Nothing else Just . addUTCTime (realToFrac ttl) <$> liftIO getCurrentTime callTimed :: Contact -> ACIContent -> CM (Maybe CITimed) callTimed ct aciContent = case aciContentCallStatus aciContent of Just callStatus | callComplete callStatus -> do contactCITimed ct _ -> pure Nothing where aciContentCallStatus :: ACIContent -> Maybe CICallStatus aciContentCallStatus (ACIContent _ (CISndCall st _)) = Just st aciContentCallStatus (ACIContent _ (CIRcvCall st _)) = Just st aciContentCallStatus _ = Nothing toggleNtf :: GroupMember -> Bool -> CM () toggleNtf m ntfOn = when (memberActive m) $ forM_ (memberConnId m) $ \connId -> withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchAllErrors` eToView prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup)) prepareGroupMsg db user g@GroupInfo {membership} msgScope mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of (Nothing, Nothing) -> let mc' = MCSimple $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope in pure (XMsgNew mc', Nothing) (Nothing, Just _) -> let mc' = MCForward $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope in pure (XMsgNew mc', Nothing) (Just quotedItemId, Nothing) -> do CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, mentions = quoteMentions, file} <- getGroupCIWithReactions db user g quotedItemId (origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} qmc = quoteContent mc origQmc file (qmc', ft', _) = updatedMentionNames qmc formattedText quoteMentions quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc', formattedText = ft'} mc' = MCQuote QuotedMsg {msgRef, content = qmc'} (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope) pure (XMsgNew mc', Just quotedItem) (Just _, Just _) -> throwError SEInvalidQuote where quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwError SEInvalidQuote quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership') quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m) quoteData _ _ = throwError SEInvalidQuote updatedMentionNames :: MsgContent -> Maybe MarkdownList -> Map MemberName CIMention -> (MsgContent, Maybe MarkdownList, Map MemberName CIMention) updatedMentionNames mc ft_ mentions = case ft_ of Just ft | not (null ft) && not (null mentions) && not (all sameName $ M.assocs mentions) -> let (mentions', ft') = mapAccumL update M.empty ft text = T.concat $ map markdownText ft' in (mc {text} :: MsgContent, Just ft', mentions') _ -> (mc, ft_, mentions) where sameName (name, CIMention {memberRef}) = case memberRef of Just CIMentionMember {displayName} -> case T.stripPrefix displayName name of Just rest | T.null rest -> True | otherwise -> case T.uncons rest of Just ('_', suffix) -> T.all isDigit suffix _ -> False Nothing -> False Nothing -> True update mentions' ft@(FormattedText f _) = case f of Just (Mention name) -> case M.lookup name mentions of Just mm@CIMention {memberRef} -> let name' = uniqueMentionName 0 $ case memberRef of Just CIMentionMember {displayName} -> displayName Nothing -> name in (M.insert name' mm mentions', FormattedText (Just $ Mention name') ('@' `T.cons` viewName name')) Nothing -> (mentions', ft) _ -> (mentions', ft) where uniqueMentionName :: Int -> Text -> Text uniqueMentionName pfx name = let prefixed = if pfx == 0 then name else (name `T.snoc` '_') <> tshow pfx in if prefixed `M.member` mentions' then uniqueMentionName (pfx + 1) name else prefixed getCIMentions :: DB.Connection -> User -> GroupInfo -> Maybe MarkdownList -> Map MemberName GroupMemberId -> ExceptT StoreError IO (Map MemberName CIMention) getCIMentions db user GroupInfo {groupId} ft_ mentions = case ft_ of Just ft | not (null ft) && not (null mentions) -> do let msgMentions = S.fromList $ mentionedNames ft n = M.size mentions -- prevent "invisible" and repeated-with-different-name mentions (when the same member is mentioned via another name) unless (n <= maxSndMentions && all (`S.member` msgMentions) (M.keys mentions) && S.size (S.fromList $ M.elems mentions) == n) $ throwError SEInvalidMention mapM (getMentionedGroupMember db user groupId) mentions _ -> pure M.empty getRcvCIMentions :: DB.Connection -> User -> GroupInfo -> Maybe MarkdownList -> Map MemberName MsgMention -> IO (Map MemberName CIMention) getRcvCIMentions db user GroupInfo {groupId} ft_ mentions = case ft_ of Just ft | not (null ft) && not (null mentions) -> let mentions' = uniqueMsgMentions maxRcvMentions mentions $ mentionedNames ft in mapM (getMentionedMemberByMemberId db user groupId) mentions' _ -> pure M.empty -- prevent "invisible" and repeated-with-different-name mentions uniqueMsgMentions :: Int -> Map MemberName MsgMention -> [ContactName] -> Map MemberName MsgMention uniqueMsgMentions maxMentions mentions = go M.empty S.empty 0 where go acc _ _ [] = acc go acc seen n (name : rest) | n >= maxMentions = acc | otherwise = case M.lookup name mentions of Just mm@MsgMention {memberId} | S.notMember memberId seen -> go (M.insert name mm acc) (S.insert memberId seen) (n + 1) rest _ -> go acc seen n rest getMessageMentions :: DB.Connection -> User -> GroupId -> Text -> IO (Map MemberName GroupMemberId) getMessageMentions db user gId msg = case parseMaybeMarkdownList msg of Just ft | not (null ft) -> M.fromList . catMaybes <$> mapM get (nubOrd $ mentionedNames ft) _ -> pure M.empty where get name = fmap (name,) . eitherToMaybe <$> runExceptT (getGroupMemberIdByName db user gId name) msgContentTexts :: MsgContent -> (Text, Maybe MarkdownList) msgContentTexts mc = let t = msgContentText mc in (t, parseMaybeMarkdownList t) ciContentTexts :: CIContent d -> (Text, Maybe MarkdownList) ciContentTexts content = let t = ciContentToText content in (t, parseMaybeMarkdownList t) quoteContent :: forall d. MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent quoteContent mc qmc ciFile_ | replaceContent = MCText qTextOrFile | otherwise = case qmc of MCImage _ image -> MCImage qTextOrFile image MCFile _ -> MCFile qTextOrFile -- consider same for voice messages -- MCVoice _ voice -> MCVoice qTextOrFile voice _ -> qmc where -- if the message we're quoting with is one of the "large" MsgContents -- we replace the quote's content with MCText replaceContent = case mc of MCText _ -> False MCFile _ -> False MCLink {} -> True MCImage {} -> True MCVideo {} -> True MCVoice {} -> False MCReport {} -> False MCChat {} -> True MCUnknown {} -> True qText = msgContentText qmc getFileName :: CIFile d -> String getFileName CIFile {fileName} = fileName qFileName = maybe qText (T.pack . getFileName) ciFile_ qTextOrFile = if T.null qText then qFileName else qText prohibitedGroupContent :: GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> MsgContent -> Maybe MarkdownList -> Maybe f -> Bool -> Maybe GroupFeature prohibitedGroupContent gInfo@GroupInfo {membership = GroupMember {memberRole = userRole}} m scopeInfo mc ft file_ sent | isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) = Just GFVoice | isNothing scopeInfo && not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles | isNothing scopeInfo && isReport mc && (badReportUser || not (groupFeatureAllowed SGFReports gInfo)) = Just GFReports | isNothing scopeInfo && prohibitedSimplexLinks gInfo m ft = Just GFSimplexLinks | otherwise = Nothing where -- admins cannot send reports, non-admins cannot receive reports badReportUser | sent = userRole >= GRModerator | otherwise = userRole < GRModerator prohibitedSimplexLinks :: GroupInfo -> GroupMember -> Maybe MarkdownList -> Bool prohibitedSimplexLinks gInfo m ft = not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo) && maybe False (any ftIsSimplexLink) ft ftIsSimplexLink :: FormattedText -> Bool ftIsSimplexLink FormattedText {format} = maybe False isSimplexLink format roundedFDCount :: Int -> Int roundedFDCount n | n <= 0 = 4 | otherwise = max 4 $ fromIntegral $ (2 :: Integer) ^ (ceiling (logBase 2 (fromIntegral n) :: Double) :: Integer) xftpSndFileTransfer_ :: User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta) xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup_ = do let fileName = takeFileName filePath fInv = xftpFileInvitation fileName fileSize dummyFileDescr fsFilePath <- lift $ toFSFilePath filePath let srcFile = CryptoFile fsFilePath cfArgs aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n) -- TODO CRSndFileStart event for XFTP chSize <- asks $ fileChunkSize . config ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup_ file fInv (AgentSndFileId aFileId) Nothing chSize let fileSource = Just $ CryptoFile filePath cfArgs ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP} pure (fInv, ciFile, ft) xftpSndFileRedirect :: User -> FileTransferId -> ValidFileDescription 'FRecipient -> CM FileTransferMeta xftpSndFileRedirect user ftId vfd = do let fileName = "redirect.yaml" file = CryptoFile fileName Nothing fInv = xftpFileInvitation fileName (fromIntegral $ B.length $ strEncode vfd) dummyFileDescr aFileId <- withAgent $ \a -> xftpSendDescription a (aUserId user) vfd (roundedFDCount 1) chSize <- asks $ fileChunkSize . config withStore' $ \db -> createSndFileTransferXFTP db user Nothing file fInv (AgentSndFileId aFileId) (Just ftId) chSize dummyFileDescr :: FileDescr dummyFileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} cancelFilesInProgress :: User -> [CIFileInfo] -> CM () cancelFilesInProgress user filesInfo = do let filesInfo' = filter (not . fileEnded) filesInfo (sfs, rfs) <- lift $ splitFTTypes <$> withStoreBatch (\db -> map (getFT db) filesInfo') forM_ rfs $ \RcvFileTransfer {fileId} -> lift (closeFileHandle fileId rcvFiles) `catchAllErrors` \_ -> pure () lift . void . withStoreBatch' $ \db -> map (updateSndFileCancelled db) sfs lift . void . withStoreBatch' $ \db -> map (updateRcvFileCancelled db) rfs let xsfIds = mapMaybe (\(FileTransferMeta {fileId, xftpSndFile}, _) -> (,fileId) <$> xftpSndFile) sfs xrfIds = mapMaybe (\RcvFileTransfer {fileId, xftpRcvFile} -> (,fileId) <$> xftpRcvFile) rfs lift $ agentXFTPDeleteSndFilesRemote user xsfIds lift $ agentXFTPDeleteRcvFiles xrfIds where fileEnded CIFileInfo {fileStatus} = case fileStatus of Just (AFS _ status) -> ciFileEnded status Nothing -> True getFT :: DB.Connection -> CIFileInfo -> IO (Either ChatError FileTransfer) getFT db CIFileInfo {fileId} = runExceptT . withExceptT ChatErrorStore $ getFileTransfer db user fileId updateSndFileCancelled :: DB.Connection -> (FileTransferMeta, [SndFileTransfer]) -> IO () updateSndFileCancelled db (FileTransferMeta {fileId}, sfts) = do updateFileCancelled db user fileId CIFSSndCancelled forM_ sfts $ \sft -> unless (sndFTEnded sft) $ updateSndFileStatus db sft FSCancelled updateRcvFileCancelled :: DB.Connection -> RcvFileTransfer -> IO () updateRcvFileCancelled db ft@RcvFileTransfer {fileId} = do updateFileCancelled db user fileId CIFSRcvCancelled updateRcvFileStatus db fileId FSCancelled deleteRcvFileChunks db ft splitFTTypes :: [Either ChatError FileTransfer] -> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer]) splitFTTypes = foldr addFT ([], []) . rights where addFT f (sfs, rfs) = case f of FTSnd ft@FileTransferMeta {cancelled} sfts | not cancelled -> ((ft, sfts) : sfs, rfs) FTRcv ft@RcvFileTransfer {cancelled} | not cancelled -> (sfs, ft : rfs) _ -> (sfs, rfs) sndFTEnded SndFileTransfer {fileStatus} = fileStatus == FSCancelled || fileStatus == FSComplete deleteFilesLocally :: [CIFileInfo] -> CM () deleteFilesLocally files = withFilesFolder $ \filesFolder -> liftIO . forM_ files $ \CIFileInfo {filePath} -> mapM_ (delete . (filesFolder )) filePath where delete :: FilePath -> IO () delete fPath = removeFile fPath `catchAll` \_ -> removePathForcibly fPath `catchAll_` pure () -- perform an action only if filesFolder is set (i.e. on mobile devices) withFilesFolder :: (FilePath -> CM ()) -> CM () withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action deleteDirectCIs :: User -> Contact -> [CChatItem 'CTDirect] -> CM [ChatItemDeletion] deleteDirectCIs user ct items = do let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items deleteCIFiles user ciFilesInfo (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) unless (null errs) $ toView $ CEvtChatErrors errs pure deletions where deleteItem db (CChatItem md ci) = do deleteDirectChatItem db user ct ci pure $ contactDeletion md ct ci Nothing deleteGroupCIs :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [CChatItem 'CTGroup] -> Maybe GroupMember -> UTCTime -> CM [ChatItemDeletion] deleteGroupCIs user gInfo chatScopeInfo items byGroupMember_ deletedTs = do let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items deleteCIFiles user ciFilesInfo (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) unless (null errs) $ toView $ CEvtChatErrors errs vr <- chatVersionRange deletions' <- case chatScopeInfo of Nothing -> pure deletions Just scopeInfo@GCSIMemberSupport {groupMember_} -> do let decStats = countDeletedUnreadItems groupMember_ deletions gInfo' <- withFastStore' $ \db -> updateGroupScopeUnreadStats db vr user gInfo scopeInfo decStats pure $ map (updateDeletionGroupInfo gInfo') deletions pure deletions' where deleteItem :: DB.Connection -> CChatItem 'CTGroup -> IO ChatItemDeletion deleteItem db (CChatItem md ci) = do ci' <- case byGroupMember_ of Just m -> Just <$> updateGroupChatItemModerated db user gInfo ci m deletedTs Nothing -> Nothing <$ deleteGroupChatItem db user gInfo ci pure $ groupDeletion md gInfo chatScopeInfo ci ci' countDeletedUnreadItems :: Maybe GroupMember -> [ChatItemDeletion] -> (Int, Int, Int) countDeletedUnreadItems scopeMember_ = foldl' countItem (0, 0, 0) where countItem :: (Int, Int, Int) -> ChatItemDeletion -> (Int, Int, Int) countItem (!unread, !unanswered, !mentions) ChatItemDeletion {deletedChatItem} | aChatItemIsRcvNew deletedChatItem = let unread' = unread + 1 unanswered' = case (scopeMember_, aChatItemRcvFromMember deletedChatItem) of (Just scopeMember, Just rcvFromMember) | groupMemberId' rcvFromMember == groupMemberId' scopeMember -> unanswered + 1 _ -> unanswered mentions' = if isACIUserMention deletedChatItem then mentions + 1 else mentions in (unread', unanswered', mentions') | otherwise = (unread, unanswered, mentions) updateDeletionGroupInfo :: GroupInfo -> ChatItemDeletion -> ChatItemDeletion updateDeletionGroupInfo gInfo' ChatItemDeletion {deletedChatItem, toChatItem} = ChatItemDeletion { deletedChatItem = updateACIGroupInfo gInfo' deletedChatItem, toChatItem = updateACIGroupInfo gInfo' <$> toChatItem } updateACIGroupInfo :: GroupInfo -> AChatItem -> AChatItem updateACIGroupInfo gInfo' = \case AChatItem SCTGroup dir (GroupChat _gInfo chatScopeInfo) ci -> AChatItem SCTGroup dir (GroupChat gInfo' chatScopeInfo) ci aci -> aci deleteGroupMemberCIs :: MsgDirectionI d => User -> GroupInfo -> GroupMember -> GroupMember -> SMsgDirection d -> CM () deleteGroupMemberCIs user gInfo member byGroupMember msgDir = do deletedTs <- liftIO getCurrentTime filesInfo <- withStore' $ \db -> deleteGroupMemberCIs_ db user gInfo member byGroupMember msgDir deletedTs deleteCIFiles user filesInfo deleteGroupMembersCIs :: User -> GroupInfo -> [GroupMember] -> GroupMember -> CM () deleteGroupMembersCIs user gInfo members byGroupMember = do deletedTs <- liftIO getCurrentTime filesInfo <- withStore' $ \db -> fmap concat $ forM members $ \m -> deleteGroupMemberCIs_ db user gInfo m byGroupMember SMDRcv deletedTs deleteCIFiles user filesInfo deleteGroupMemberCIs_ :: MsgDirectionI d => DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> SMsgDirection d -> UTCTime -> IO [CIFileInfo] deleteGroupMemberCIs_ db user gInfo member byGroupMember msgDir deletedTs = do fs <- getGroupMemberFileInfo db user gInfo member updateMemberCIsModerated db user gInfo member byGroupMember msgDir deletedTs pure fs deleteLocalCIs :: User -> NoteFolder -> [CChatItem 'CTLocal] -> Bool -> Bool -> CM ChatResponse deleteLocalCIs user nf items byUser timed = do let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items deleteFilesLocally ciFilesInfo (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) unless (null errs) $ toView $ CEvtChatErrors errs pure $ CRChatItemsDeleted user deletions byUser timed where deleteItem db (CChatItem md ci) = do deleteLocalChatItem db user nf ci pure $ ChatItemDeletion (nfItem md ci) Nothing nfItem :: MsgDirectionI d => SMsgDirection d -> ChatItem 'CTLocal d -> AChatItem nfItem md = AChatItem SCTLocal md (LocalChat nf) deleteCIFiles :: User -> [CIFileInfo] -> CM () deleteCIFiles user filesInfo = do cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo markDirectCIsDeleted :: User -> Contact -> [CChatItem 'CTDirect] -> UTCTime -> CM [ChatItemDeletion] markDirectCIsDeleted user ct items deletedTs = do let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items cancelFilesInProgress user ciFilesInfo (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items) unless (null errs) $ toView $ CEvtChatErrors errs pure deletions where markDeleted db (CChatItem md ci) = do ci' <- markDirectChatItemDeleted db user ct ci deletedTs pure $ contactDeletion md ct ci (Just ci') markGroupCIsDeleted :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [CChatItem 'CTGroup] -> Maybe GroupMember -> UTCTime -> CM [ChatItemDeletion] markGroupCIsDeleted user gInfo chatScopeInfo items byGroupMember_ deletedTs = do let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items cancelFilesInProgress user ciFilesInfo (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items) unless (null errs) $ toView $ CEvtChatErrors errs pure deletions -- pure $ CRChatItemsDeleted user deletions byUser False where markDeleted db (CChatItem md ci) = do ci' <- markGroupChatItemDeleted db user gInfo ci byGroupMember_ deletedTs pure $ groupDeletion md gInfo chatScopeInfo ci (Just ci') markGroupMemberCIsDeleted :: User -> GroupInfo -> GroupMember -> GroupMember -> CM () markGroupMemberCIsDeleted user gInfo member byGroupMember = do deletedTs <- liftIO getCurrentTime filesInfo <- withStore' $ \db -> markGroupMemberCIsDeleted_ db user gInfo member byGroupMember deletedTs cancelFilesInProgress user filesInfo markGroupMembersCIsDeleted :: User -> GroupInfo -> [GroupMember] -> GroupMember -> CM () markGroupMembersCIsDeleted user gInfo members byGroupMember = do deletedTs <- liftIO getCurrentTime filesInfo <- withStore' $ \db -> fmap concat $ forM members $ \m -> markGroupMemberCIsDeleted_ db user gInfo m byGroupMember deletedTs cancelFilesInProgress user filesInfo markGroupMemberCIsDeleted_ :: DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> UTCTime -> IO [CIFileInfo] markGroupMemberCIsDeleted_ db user gInfo member byGroupMember deletedTs = do fs <- getGroupMemberFileInfo db user gInfo member markMemberCIsDeleted db user gInfo member byGroupMember deletedTs pure fs groupDeletion :: MsgDirectionI d => SMsgDirection d -> GroupInfo -> Maybe GroupChatScopeInfo -> ChatItem 'CTGroup d -> Maybe (ChatItem 'CTGroup d) -> ChatItemDeletion groupDeletion md g chatScopeInfo ci ci' = ChatItemDeletion (gItem ci) (gItem <$> ci') where gItem = AChatItem SCTGroup md (GroupChat g chatScopeInfo) contactDeletion :: MsgDirectionI d => SMsgDirection d -> Contact -> ChatItem 'CTDirect d -> Maybe (ChatItem 'CTDirect d) -> ChatItemDeletion contactDeletion md ct ci ci' = ChatItemDeletion (ctItem ci) (ctItem <$> ci') where ctItem = AChatItem SCTDirect md (DirectChat ct) updateCallItemStatus :: User -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> CM () updateCallItemStatus user ct@Contact {contactId} Call {chatItemId} receivedStatus msgId_ = do aciContent_ <- callStatusItemContent user ct chatItemId receivedStatus forM_ aciContent_ $ \aciContent -> do timed_ <- callTimed ct aciContent updateDirectChatItemView user ct chatItemId aciContent False False timed_ msgId_ forM_ (timed_ >>= timedDeleteAt') $ startProximateTimedItemThread user (ChatRef CTDirect contactId Nothing, chatItemId) updateDirectChatItemView :: User -> Contact -> ChatItemId -> ACIContent -> Bool -> Bool -> Maybe CITimed -> Maybe MessageId -> CM () updateDirectChatItemView user ct chatItemId (ACIContent msgDir ciContent) edited live timed_ msgId_ = do ci' <- withStore $ \db -> updateDirectChatItem db user ct chatItemId ciContent edited live timed_ msgId_ toView $ CEvtChatItemUpdated user (AChatItem SCTDirect msgDir (DirectChat ct) ci') callStatusItemContent :: User -> Contact -> ChatItemId -> WebRTCCallStatus -> CM (Maybe ACIContent) callStatusItemContent user Contact {contactId} chatItemId receivedStatus = do CChatItem msgDir ChatItem {meta = CIMeta {updatedAt}, content} <- withStore $ \db -> getDirectChatItem db user contactId chatItemId ts <- liftIO getCurrentTime let callDuration :: Int = nominalDiffTimeToSeconds (ts `diffUTCTime` updatedAt) `div'` 1 callStatus = case content of CISndCall st _ -> Just st CIRcvCall st _ -> Just st _ -> Nothing newState_ = case (callStatus, receivedStatus) of (Just CISCallProgress, WCSConnected) -> Nothing -- if call in-progress received connected -> no change (Just CISCallProgress, WCSDisconnected) -> Just (CISCallEnded, callDuration) -- calculate in-progress duration (Just CISCallProgress, WCSFailed) -> Just (CISCallEnded, callDuration) -- whether call disconnected or failed (Just CISCallPending, WCSDisconnected) -> Just (CISCallMissed, 0) (Just CISCallEnded, _) -> Nothing -- if call already ended or failed -> no change (Just CISCallError, _) -> Nothing (Just _, WCSConnecting) -> Just (CISCallNegotiated, 0) (Just _, WCSConnected) -> Just (CISCallProgress, 0) -- if call ended that was never connected, duration = 0 (Just _, WCSDisconnected) -> Just (CISCallEnded, 0) (Just _, WCSFailed) -> Just (CISCallError, 0) (Nothing, _) -> Nothing -- some other content - we should never get here, but no exception is thrown pure $ aciContent msgDir <$> newState_ where aciContent :: forall d. SMsgDirection d -> (CICallStatus, Int) -> ACIContent aciContent msgDir (callStatus', duration) = case msgDir of SMDSnd -> ACIContent SMDSnd $ CISndCall callStatus' duration SMDRcv -> ACIContent SMDRcv $ CIRcvCall callStatus' duration -- mobile clients use file paths relative to app directory (e.g. for the reason ios app directory changes on updates), -- so we have to differentiate between the file path stored in db and communicated with frontend, and the file path -- used during file transfer for actual operations with file system toFSFilePath :: FilePath -> CM' FilePath toFSFilePath f = maybe f ( f) <$> (chatReadVar' filesFolder) setFileToEncrypt :: RcvFileTransfer -> CM RcvFileTransfer setFileToEncrypt ft@RcvFileTransfer {fileId} = do cfArgs <- atomically . CF.randomArgs =<< asks random withStore' $ \db -> setFileCryptoArgs db fileId cfArgs pure (ft :: RcvFileTransfer) {cryptoArgs = Just cfArgs} receiveFile' :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM ChatResponse receiveFile' user ft userApprovedRelays rcvInline_ filePath_ = do (CRRcvFileAccepted user <$> acceptFileReceive user ft userApprovedRelays rcvInline_ filePath_) `catchAllErrors` processError where -- TODO AChatItem in Cancelled events processError e | rctFileCancelled e = pure $ CRRcvFileAcceptedSndCancelled user ft | otherwise = throwError e receiveFileEvt' :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM ChatEvent receiveFileEvt' user ft userApprovedRelays rcvInline_ filePath_ = do (CEvtRcvFileAccepted user <$> acceptFileReceive user ft userApprovedRelays rcvInline_ filePath_) `catchAllErrors` processError where -- TODO AChatItem in Cancelled events processError e | rctFileCancelled e = pure $ CEvtRcvFileAcceptedSndCancelled user ft | otherwise = throwError e rctFileCancelled :: ChatError -> Bool rctFileCancelled = \case ChatErrorAgent (SMP _ SMP.AUTH) _ _ -> True ChatErrorAgent (CONN DUPLICATE _) _ _ -> True _ -> False acceptFileReceive :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM AChatItem acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId, cryptoArgs} userApprovedRelays rcvInline_ filePath_ = do unless (fileStatus == RFSNew) $ case fileStatus of RFSCancelled _ -> throwChatError $ CEFileCancelled fName _ -> throwChatError $ CEFileAlreadyReceiving fName vr <- chatVersionRange case (xftpRcvFile, fileConnReq) of -- XFTP (Just XFTPRcvFile {userApprovedRelays = approvedBeforeReady}, _) -> do let userApproved = approvedBeforeReady || userApprovedRelays filePath <- getRcvFilePath fileId filePath_ fName False (ci, rfd) <- withStore $ \db -> do -- marking file as accepted and reading description in the same transaction -- to prevent race condition with appending description ci <- xftpAcceptRcvFT db vr user fileId filePath userApproved rfd <- getRcvFileDescrByRcvFileId db fileId pure (ci, rfd) receiveViaCompleteFD user fileId rfd userApproved cryptoArgs pure ci (Nothing, Just _fileConnReq) -> throwChatError $ CEException "accepting file via a separate connection is deprecated" -- group & direct file protocol _ -> do chatRef <- withStore $ \db -> getChatRefByFileId db user fileId case (chatRef, grpMemberId) of (ChatRef CTDirect contactId _, Nothing) -> do ct <- withStore $ \db -> getContact db vr user contactId acceptFile $ \msg -> void $ sendDirectContactMessage user ct msg (ChatRef CTGroup groupId _, Just memId) -> do GroupMember {activeConn} <- withStore $ \db -> getGroupMember db vr user groupId memId case activeConn of Just conn -> do acceptFile $ \msg -> void $ sendDirectMemberMessage conn msg groupId _ -> throwChatError $ CEFileInternal "member connection not active" _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" where acceptFile :: (ChatMsgEvent 'Json -> CM ()) -> CM AChatItem acceptFile send = do filePath <- getRcvFilePath fileId filePath_ fName True inline <- receiveInline vr <- chatVersionRange if | inline -> do -- accepting inline ci <- withStore $ \db -> acceptRcvInlineFT db vr user fileId filePath sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId send $ XFileAcptInv sharedMsgId Nothing fName pure ci | fileInline == Just IFMSent -> throwChatError $ CEFileAlreadyReceiving fName | otherwise -> throwChatError $ CEException "accepting file via a separate connection is deprecated" receiveInline :: CM Bool receiveInline = do ChatConfig {fileChunkSize, inlineFiles = InlineFilesConfig {receiveChunks, offerChunks}} <- asks config pure $ rcvInline_ /= Just False && fileInline == Just IFMOffer && ( fileSize <= fileChunkSize * receiveChunks || (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks) ) receiveViaCompleteFD :: User -> FileTransferId -> RcvFileDescr -> Bool -> Maybe CryptoFileArgs -> CM () receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} userApprovedRelays cfArgs = when fileDescrComplete $ do rd <- parseFileDescription fileDescrText if userApprovedRelays then receive' rd True else do let srvs = fileServers rd unknownSrvs <- getUnknownSrvs srvs let approved = null unknownSrvs ifM ((approved ||) <$> ipProtectedForSrvs srvs) (receive' rd approved) (relaysNotApproved unknownSrvs) where receive' :: ValidFileDescription 'FRecipient -> Bool -> CM () receive' rd approved = do aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd cfArgs approved startReceivingFile user fileId withStore' $ \db -> updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId) fileServers :: ValidFileDescription 'FRecipient -> [XFTPServer] fileServers (FD.ValidFileDescription FD.FileDescription {chunks}) = S.toList $ S.fromList $ concatMap (\FD.FileChunk {replicas} -> map (\FD.FileChunkReplica {server} -> server) replicas) chunks getUnknownSrvs :: [XFTPServer] -> CM [XFTPServer] getUnknownSrvs srvs = do knownSrvs <- L.map protoServer' <$> getKnownAgentServers SPXFTP user pure $ filter (`notElem` knownSrvs) srvs ipProtectedForSrvs :: [XFTPServer] -> CM Bool ipProtectedForSrvs srvs = do netCfg <- lift getNetworkConfig pure $ all (ipAddressProtected netCfg) srvs relaysNotApproved :: [XFTPServer] -> CM () relaysNotApproved unknownSrvs = do aci_ <- resetRcvCIFileStatus user fileId CIFSRcvInvitation forM_ aci_ $ \aci -> do cleanupACIFile aci toView $ CEvtChatItemUpdated user aci throwChatError $ CEFileNotApproved fileId unknownSrvs cleanupACIFile :: AChatItem -> CM () cleanupACIFile (AChatItem _ _ _ ChatItem {file = Just CIFile {fileSource = Just CryptoFile {filePath}}}) = do fsFilePath <- lift $ toFSFilePath filePath removeFile fsFilePath `catchAllErrors` \_ -> pure () cleanupACIFile _ = pure () getKnownAgentServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> User -> CM (NonEmpty (ServerCfg p)) getKnownAgentServers p user = do as <- asks randomAgentServers withStore $ \db -> do opDomains <- operatorDomains . serverOperators <$> getServerOperators db srvs <- liftIO $ getProtocolServers db p user pure $ useServerCfgs p as opDomains srvs protoServer' :: ServerCfg p -> ProtocolServer p protoServer' ServerCfg {server} = protoServer server getNetworkConfig :: CM' NetworkConfig getNetworkConfig = withAgent' $ liftIO . getFastNetworkConfig resetRcvCIFileStatus :: User -> FileTransferId -> CIFileStatus 'MDRcv -> CM (Maybe AChatItem) resetRcvCIFileStatus user fileId ciFileStatus = do vr <- chatVersionRange withStore $ \db -> do liftIO $ do updateCIFileStatus db user fileId ciFileStatus updateRcvFileStatus db fileId FSNew updateRcvFileAgentId db fileId Nothing lookupChatItemByFileId db vr user fileId receiveViaURI :: User -> FileDescriptionURI -> CryptoFile -> CM RcvFileTransfer receiveViaURI user@User {userId} FileDescriptionURI {description} cf@CryptoFile {cryptoArgs} = do fileId <- withStore $ \db -> createRcvStandaloneFileTransfer db userId cf fileSize chunkSize -- currently the only use case is user migrating via their configured servers, so we pass approvedRelays = True aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) description cryptoArgs True withStore $ \db -> do liftIO $ do updateRcvFileStatus db fileId FSConnected updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1 updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId) getRcvFileTransfer db user fileId where FD.ValidFileDescription FD.FileDescription {size = FD.FileSize fileSize, chunkSize = FD.FileSize chunkSize} = description startReceivingFile :: User -> FileTransferId -> CM () startReceivingFile user fileId = do vr <- chatVersionRange ci <- withStore $ \db -> do liftIO $ updateRcvFileStatus db fileId FSConnected liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1 getChatItemByFileId db vr user fileId toView $ CEvtRcvFileStart user ci getRcvFilePath :: FileTransferId -> Maybe FilePath -> String -> Bool -> CM FilePath getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of Nothing -> chatReadVar filesFolder >>= \case Nothing -> do defaultFolder <- lift getDefaultFilesFolder fPath <- liftIO $ defaultFolder `uniqueCombine` fn createEmptyFile fPath $> fPath Just filesFolder -> do fPath <- liftIO $ filesFolder `uniqueCombine` fn createEmptyFile fPath pure $ takeFileName fPath Just fPath -> ifM (doesDirectoryExist fPath) (createInPassedDirectory fPath) $ ifM (doesFileExist fPath) (throwChatError $ CEFileAlreadyExists fPath) (createEmptyFile fPath $> fPath) where createInPassedDirectory :: FilePath -> CM FilePath createInPassedDirectory fPathDir = do fPath <- liftIO $ fPathDir `uniqueCombine` fn createEmptyFile fPath $> fPath createEmptyFile :: FilePath -> CM () createEmptyFile fPath = emptyFile `catchThrow` (ChatError . CEFileWrite fPath . show) where emptyFile :: CM () emptyFile | keepHandle = do h <- getFileHandle fileId fPath rcvFiles AppendMode liftIO $ B.hPut h "" >> hFlush h | otherwise = liftIO $ B.writeFile fPath "" -- TODO [short links] -- Please note: -- - the connection here is created as ConnNew, even though when joining it is created as ConnPrepared. -- (changing it is risky, as there may be existing "prepared" connections that were not accepted in ConnNew status). -- - after accepted, the status is changed by this func caller to ConnSndReady if it is sndSecure, and not changed otherwise - joined changed to ConnJoined in this case. -- - xContactId is set on the contact at the first acceptance attempt, not after accept success, which prevents profile updates after such attempt. -- It may be reasonable to set it when contact is first prepared, but then we can't use it to ignore requests after acceptance, -- and it may lead to race conditions with XInfo events. acceptContactRequest :: NetworkRequestMode -> User -> UserContactRequest -> IncognitoEnabled -> CM (Contact, Connection, SndQueueSecured) acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId = AgentInvId invId, contactId_, cReqChatVRange, localDisplayName = cName, profileId, profile = cp, userContactLinkId_, xContactId, pqSupport} incognito = do subMode <- chatReadVar subscriptionMode let pqSup = PQSupportOn pqSup' = pqSup `CR.pqSupportAnd` pqSupport vr <- chatVersionRange let chatV = vr `peerConnChatVersion` cReqChatVRange (ct, conn, incognitoProfile) <- case contactId_ of Nothing -> do incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing connId <- withAgent $ \a -> prepareConnectionToAccept a (aUserId user) True invId pqSup' (ct, conn) <- withStore' $ \db -> createContactFromRequest db user userContactLinkId_ connId chatV cReqChatVRange cName profileId cp xContactId incognitoProfile subMode pqSup' False pure (ct, conn, incognitoProfile) Just contactId -> do ct <- withFastStore $ \db -> getContact db vr user contactId case contactConn ct of Nothing -> do incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing connId <- withAgent $ \a -> prepareConnectionToAccept a (aUserId user) True invId pqSup' currentTs <- liftIO getCurrentTime conn <- withStore' $ \db -> do forM_ xContactId $ \xcId -> setContactAcceptedXContactId db ct xcId createAcceptedContactConn db user userContactLinkId_ contactId connId chatV cReqChatVRange pqSup' incognitoProfile subMode currentTs pure (ct {activeConn = Just conn} :: Contact, conn, incognitoProfile) Just conn@Connection {customUserProfileId} -> do incognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId pure (ct, conn, ExistingIncognito <$> incognitoProfile) let profileToSend = userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend -- TODO [certs rcv] (ct,conn,) . fst <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode) acceptContactRequestAsync :: User -> Int64 -> Contact -> UserContactRequest -> Maybe IncognitoProfile -> CM Contact acceptContactRequestAsync user uclId ct@Contact {contactId} UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId, pqSupport = cReqPQSup} incognitoProfile = do subMode <- chatReadVar subscriptionMode let profileToSend = userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True vr <- chatVersionRange let chatV = vr `peerConnChatVersion` cReqChatVRange (cmdId, acId) <- agentAcceptContactAsync user True cReqInvId (XInfo profileToSend) subMode cReqPQSup chatV currentTs <- liftIO getCurrentTime withStore $ \db -> do forM_ xContactId $ \xcId -> liftIO $ setContactAcceptedXContactId db ct xcId Connection {connId} <- liftIO $ createAcceptedContactConn db user (Just uclId) contactId acId chatV cReqChatVRange cReqPQSup incognitoProfile subMode currentTs liftIO $ setCommandConnId db user cmdId connId getContact db vr user contactId acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> CM GroupMember acceptGroupJoinRequestAsync user uclId gInfo@GroupInfo {groupProfile, membership, businessChat} cReqInvId cReqChatVRange cReqProfile cReqXContactId_ welcomeMsgId_ gAccepted gLinkMemRole incognitoProfile = do gVar <- asks random let initialStatus = acceptanceToStatus (memberAdmission groupProfile) gAccepted (groupMemberId, memberId) <- withStore $ \db -> createJoiningMember db gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ welcomeMsgId_ gLinkMemRole initialStatus currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo let Profile {displayName} = userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile) GroupMember {memberRole = userRole, memberId = userMemberId} = membership msg = XGrpLinkInv $ GroupLinkInvitation { fromMember = MemberIdRole userMemberId userRole, fromMemberName = displayName, invitedMember = MemberIdRole memberId gLinkMemRole, groupProfile, accepted = Just gAccepted, business = businessChat, groupSize = Just currentMemCount } subMode <- chatReadVar subscriptionMode vr <- chatVersionRange let chatV = vr `peerConnChatVersion` cReqChatVRange connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV withStore $ \db -> do liftIO $ createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode getGroupMemberById db vr user groupMemberId acceptGroupJoinSendRejectAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> GroupRejectionReason -> CM GroupMember acceptGroupJoinSendRejectAsync user uclId gInfo@GroupInfo {groupProfile, membership} cReqInvId cReqChatVRange cReqProfile cReqXContactId_ rejectionReason = do gVar <- asks random (groupMemberId, memberId) <- withStore $ \db -> createJoiningMember db gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ Nothing GRObserver GSMemRejected let GroupMember {memberRole = userRole, memberId = userMemberId} = membership msg = XGrpLinkReject $ GroupLinkRejection { fromMember = MemberIdRole userMemberId userRole, invitedMember = MemberIdRole memberId GRObserver, groupProfile, rejectionReason } subMode <- chatReadVar subscriptionMode vr <- chatVersionRange let chatV = vr `peerConnChatVersion` cReqChatVRange connIds <- agentAcceptContactAsync user False cReqInvId msg subMode PQSupportOff chatV withStore $ \db -> do liftIO $ createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode getGroupMemberById db vr user groupMemberId acceptBusinessJoinRequestAsync :: User -> Int64 -> GroupInfo -> GroupMember -> UserContactRequest -> CM (GroupInfo, GroupMember) acceptBusinessJoinRequestAsync user uclId gInfo@GroupInfo {membership = GroupMember {memberRole = userRole, memberId = userMemberId}} clientMember@GroupMember {groupMemberId, memberId} UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId} = do vr <- chatVersionRange let userProfile@Profile {displayName, preferences} = fromLocalProfile $ profile' user -- TODO [short links] take groupPreferences from group info groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs preferences msg = XGrpLinkInv $ GroupLinkInvitation { fromMember = MemberIdRole userMemberId userRole, fromMemberName = displayName, invitedMember = MemberIdRole memberId GRMember, groupProfile = businessGroupProfile userProfile groupPreferences, accepted = Just GAAccepted, -- This refers to the "title member" that defines the group name and profile. -- This coincides with fromMember to be current user when accepting the connecting user, -- but it will be different when inviting somebody else. business = Just $ BusinessChatInfo {chatType = BCBusiness, businessId = userMemberId, customerId = memberId}, groupSize = Just 1 } subMode <- chatReadVar subscriptionMode let chatV = vr `peerConnChatVersion` cReqChatVRange connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV withStore' $ \db -> do forM_ xContactId $ \xcId -> setBusinessChatAcceptedXContactId db gInfo xcId createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode let cd = CDGroupSnd gInfo Nothing -- TODO [short links] move to profileContactRequest? createInternalChatItem user cd (CISndGroupE2EEInfo E2EInfo {pqEnabled = Just PQEncOff}) Nothing createGroupFeatureItems user cd CISndGroupFeature gInfo -- TODO [short links] get updated business chat group and member? (currently not used) pure (gInfo, clientMember) businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile businessGroupProfile Profile {displayName, fullName, shortDescr, image} groupPreferences = GroupProfile {displayName, fullName, description = Nothing, shortDescr, image, groupPreferences = Just groupPreferences, memberAdmission = Nothing} introduceToModerators :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM () introduceToModerators vr user gInfo@GroupInfo {groupId} m@GroupMember {memberRole, memberId} = do forM_ (memberConn m) $ \mConn -> do let msg = if maxVersion (memberChatVRange m) >= groupKnockingVersion then XGrpLinkAcpt GAPendingReview memberRole memberId else XMsgNew $ MCSimple $ extMsgContent (MCText pendingReviewMessage) Nothing void $ sendDirectMemberMessage mConn msg groupId modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo let rcpModMs = filter shouldIntroduce modMs introduceMember vr user gInfo m rcpModMs (Just $ MSMember $ memberId' m) where shouldIntroduce :: GroupMember -> Bool shouldIntroduce mem = memberCurrent mem && groupMemberId' mem /= groupMemberId' m && maxVersion (memberChatVRange mem) >= groupKnockingVersion introduceToAll :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM () introduceToAll vr user gInfo m = do members <- withStore' $ \db -> getGroupMembers db vr user gInfo vector_ <- withStore' (`getMemberRelationsVector_` m) let recipients = filter (shouldIntroduce vector_) members introduceMember vr user gInfo m recipients Nothing where shouldIntroduce :: Maybe ByteString -> GroupMember -> Bool shouldIntroduce vector_ m' = memberCurrent m' && groupMemberId' m' /= groupMemberId' m && maybe True (\v -> getRelation (indexInGroup m') v == MRNew) vector_ introduceToRemaining :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM () introduceToRemaining vr user gInfo m = do members <- withStore' $ \db -> getGroupMembers db vr user gInfo vector_ <- withStore' (`getMemberRelationsVector_` m) recipients <- filterRecipients vector_ members introduceMember vr user gInfo m recipients Nothing where filterRecipients :: Maybe ByteString -> [GroupMember] -> CM [GroupMember] filterRecipients vector_ members = do newRelation <- case vector_ of Nothing -> do introducedGMIds <- S.fromList <$> withStore' (`getIntroducedGroupMemberIds` m) pure $ \m' -> groupMemberId' m' `S.notMember` introducedGMIds Just vec -> pure $ \m' -> getRelation (indexInGroup m') vec == MRNew pure $ filter (\m' -> groupMemberId' m' /= groupMemberId' m && memberCurrent m' && newRelation m') members introduceMember :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> [GroupMember] -> Maybe MsgScope -> CM () introduceMember _ _ _ GroupMember {activeConn = Nothing} _ _ = throwChatError $ CEInternalError "member connection not active" introduceMember vr user gInfo@GroupInfo {groupId} toMember@GroupMember {activeConn = Just conn} introduceToMembers msgScope = do void . sendGroupMessage' user gInfo introduceToMembers $ XGrpMemNew (memberInfo gInfo toMember) msgScope sendIntroductions introduceToMembers where sendIntroductions reMembers = do updateToMemberVector reMembers reMembers' <- withStore' $ \db -> createIntrosOrUpdateVectors db vr reMembers toMember shuffledReMembers <- liftIO $ shuffleMembers reMembers' if toMember `supportsVersion` batchSendVersion then do let events = map memberIntro shuffledReMembers forM_ (L.nonEmpty events) $ \events' -> sendGroupMemberMessages user conn events' groupId else forM_ shuffledReMembers $ \reMember -> void $ sendDirectMemberMessage conn (memberIntro reMember) groupId updateToMemberVector :: [GroupMember] -> CM () updateToMemberVector reMembers = do let relations = map (\GroupMember {indexInGroup} -> (indexInGroup, (IDReferencedIntroduced, MRIntroduced))) reMembers withStore' $ \db -> setMemberVectorNewRelations db toMember relations memberIntro :: GroupMember -> ChatMsgEvent 'Json memberIntro reMember = let mInfo = memberInfo gInfo reMember mRestrictions = memberRestrictions reMember in XGrpMemIntro mInfo mRestrictions shuffleMembers :: [GroupMember] -> IO [GroupMember] shuffleMembers reMembers = do let (admins, others) = partition isAdmin reMembers (admPics, admNoPics) = partition hasPicture admins (othPics, othNoPics) = partition hasPicture others mconcat <$> mapM shuffle [admPics, admNoPics, othPics, othNoPics] where isAdmin GroupMember {memberRole} = memberRole >= GRAdmin hasPicture GroupMember {memberProfile = LocalProfile {image}} = isJust image userProfileInGroup :: User -> GroupInfo -> Maybe Profile -> Profile userProfileInGroup user = userProfileInGroup' user . groupFeatureUserAllowed SGFSimplexLinks {-# INLINE userProfileInGroup #-} userProfileInGroup' :: User -> Bool -> Maybe Profile -> Profile userProfileInGroup' User {profile = p} allowSimplexLinks incognitoProfile = let p' = fromMaybe (fromLocalProfile p) incognitoProfile in redactedMemberProfile allowSimplexLinks p' memberInfo :: GroupInfo -> GroupMember -> MemberInfo memberInfo g m@GroupMember {memberId, memberRole, memberProfile, activeConn} = MemberInfo { memberId, memberRole, v = ChatVersionRange . peerChatVRange <$> activeConn, profile = redactedMemberProfile allowSimplexLinks $ fromLocalProfile memberProfile } where allowSimplexLinks = groupFeatureMemberAllowed SGFSimplexLinks m g redactedMemberProfile :: Bool -> Profile -> Profile redactedMemberProfile allowSimplexLinks Profile {displayName, fullName, shortDescr, image, peerType} = Profile {displayName, fullName, shortDescr = removeSimplexLink =<< shortDescr, image, contactLink = Nothing, preferences = Nothing, peerType} where removeSimplexLink s | allowSimplexLinks = Just s | otherwise = maybe (Just s) (\fts -> if any ftIsSimplexLink fts then Nothing else Just s) $ parseMaybeMarkdownList s sendHistory :: User -> GroupInfo -> GroupMember -> CM () sendHistory _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active" sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn = Just conn} = when (m `supportsVersion` batchSendVersion) $ do (errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100) (errs', events) <- partitionEithers <$> mapM (tryAllErrors . itemForwardEvents) items let errors = map ChatErrorStore errs <> errs' unless (null errors) $ toView $ CEvtChatErrors errors let events' = concat events events_ <- case descrEvent_ of Just descr -> mkEvents <$> withStore' (\db -> getMemberJoinRequest db user gInfo m) where mkEvents = \case Just (_, Just _welcomeMsgId) -> events' _ -> events' <> [descr] Nothing -> pure events' forM_ (L.nonEmpty events_) $ \events'' -> sendGroupMemberMessages user conn events'' groupId where descrEvent_ :: Maybe (ChatMsgEvent 'Json) descrEvent_ | m `supportsVersion` groupHistoryIncludeWelcomeVersion = do let GroupInfo {groupProfile = GroupProfile {description}} = gInfo fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) Nothing) description | otherwise = Nothing itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json] itemForwardEvents cci = case cci of (CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) | not (blockedByAdmin sender) -> do fInvDescr_ <- join <$> forM file getRcvFileInvDescr processContentItem sender ci mc fInvDescr_ (CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do fInvDescr_ <- join <$> forM file getSndFileInvDescr processContentItem membership ci mc fInvDescr_ _ -> pure [] where getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText)) getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do expired <- fileExpired if fileProtocol /= FPXFTP || fileStatus == CIFSRcvCancelled || expired then pure Nothing else do rfd <- withStore $ \db -> getRcvFileDescrByRcvFileId db fileId pure $ invCompleteDescr ciFile rfd getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe (FileInvitation, RcvFileDescrText)) getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do expired <- fileExpired if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired then pure Nothing else do -- can also lookup in extra_xftp_file_descriptions, though it can be empty; -- would be best if snd file had a single rcv description for all members saved in files table rfd <- withStore $ \db -> getRcvFileDescrBySndFileId db fileId pure $ invCompleteDescr ciFile rfd fileExpired :: CM Bool fileExpired = do ttl <- asks $ rcvFilesTTL . agentConfig . config cutoffTs <- addUTCTime (-ttl) <$> liftIO getCurrentTime pure $ chatItemTs cci < cutoffTs invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText) invCompleteDescr CIFile {fileName, fileSize} RcvFileDescr {fileDescrText, fileDescrComplete} | fileDescrComplete = let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} fInv = xftpFileInvitation fileName fileSize fInvDescr in Just (fInv, fileDescrText) | otherwise = Nothing processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json] processContentItem sender ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ = if isNothing fInvDescr_ && not (msgContentHasText mc) then pure [] else do let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta quotedItemId_ = quoteItemId =<< quotedItem fInv_ = fst <$> fInvDescr_ (mc', _, mentions') = updatedMentionNames mc formattedText mentions mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions' -- TODO [knocking] send history to other scopes too? (chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False let senderVRange = memberChatVRange' sender xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent} fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of (Just fileDescrText, Just msgId) -> do partSize <- asks $ xftpDescrPartSize . config let parts = splitFileDescr partSize fileDescrText pure . L.toList $ L.map (XMsgFileDescr msgId) parts _ -> pure [] let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents GroupMember {memberId} = sender memberName = Just $ memberShortenedName sender msgForwardEvents = map (\cm -> XGrpMsgForward memberId memberName cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) pure msgForwardEvents memberShortenedName :: GroupMember -> ContactName memberShortenedName GroupMember {memberProfile = LocalProfile {displayName}} | T.length displayName <= 16 = displayName | otherwise = T.take 16 displayName `T.snoc` '…' splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr splitFileDescr partSize rfdText = splitParts 1 rfdText where splitParts partNo remText = let (part, rest) = T.splitAt partSize remText complete = T.null rest fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete} in if complete then fileDescr :| [] else fileDescr <| splitParts (partNo + 1) rest setGroupLinkData' :: NetworkRequestMode -> User -> GroupInfo -> CM () setGroupLinkData' nm user gInfo = withFastStore' (\db -> runExceptT $ getGroupLink db user gInfo) >>= \case Right gLink@GroupLink {shortLinkDataSet} | shortLinkDataSet -> void $ setGroupLinkData nm user gInfo gLink _ -> pure () setGroupLinkData :: NetworkRequestMode -> User -> GroupInfo -> GroupLink -> CM GroupLink setGroupLinkData nm user gInfo@GroupInfo {groupProfile} gLink@GroupLink {groupLinkId} = do vr <- chatVersionRange conn <- withFastStore $ \db -> getGroupLinkConnection db vr user gInfo let userData = encodeShortLinkData $ GroupShortLinkData groupProfile userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData} crClientData = encodeJSON $ CRDataGroup groupLinkId sLnk <- shortenShortLink' . toShortGroupLink =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userLinkData (Just crClientData)) withFastStore' $ \db -> setGroupLinkShortLink db gLink sLnk encodeShortLinkData :: J.ToJSON a => a -> UserLinkData encodeShortLinkData d = let s = LB.toStrict $ J.encode d -- 10kb size limit for compression to be used is based on 13784 limit for link data -- and the space reserved for the other fields in ConnLinkData encoding (most of these fields are currently unused). s' | B.length s > 10240 = B.cons 'X' $ Z1.compress compressionLevel s | otherwise = s in UserLinkData s' decodeShortLinkData :: J.FromJSON a => ConnLinkData c -> IO (Maybe a) decodeShortLinkData cData | B.null s = pure Nothing | B.head s == 'X' = case Z1.decompress $ B.drop 1 s of Z1.Error e -> Nothing <$ logError ("Error decompressing link data: " <> tshow e) Z1.Skip -> pure Nothing Z1.Decompress s' -> decode s' | otherwise = decode s where decode s' = case J.eitherDecodeStrict s' of Right d -> pure $ Just d Left e -> Nothing <$ logError ("Error decoding link data: " <> tshow e) s = linkUserData' cData shortenShortLink' :: ConnShortLink m -> CM (ConnShortLink m) shortenShortLink' l = (`shortenShortLink` l) <$> asks (shortLinkPresetServers . config) shortenCreatedLink :: CreatedConnLink m -> CM (CreatedConnLink m) shortenCreatedLink (CCLink cReq sLnk) = CCLink cReq <$> mapM shortenShortLink' sLnk createdGroupLink :: CreatedLinkContact -> CreatedLinkContact createdGroupLink (CCLink cReq shortLink) = CCLink cReq (toShortGroupLink <$> shortLink) toShortGroupLink :: ShortLinkContact -> ShortLinkContact toShortGroupLink (CSLContact sch _ srv k) = CSLContact sch CCTGroup srv k deleteGroupLink' :: User -> GroupInfo -> CM () deleteGroupLink' user gInfo = do vr <- chatVersionRange conn <- withStore $ \db -> getGroupLinkConnection db vr user gInfo deleteGroupLink_ user gInfo conn deleteGroupLinkIfExists :: User -> GroupInfo -> CM () deleteGroupLinkIfExists user gInfo = do vr <- chatVersionRange conn_ <- eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupLinkConnection db vr user gInfo) mapM_ (deleteGroupLink_ user gInfo) conn_ deleteGroupLink_ :: User -> GroupInfo -> Connection -> CM () deleteGroupLink_ user gInfo conn = do deleteAgentConnectionAsync $ aConnId conn withStore' $ \db -> deleteGroupLink db user gInfo startProximateTimedItemThread :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM () startProximateTimedItemThread user itemRef deleteAt = do interval <- asks (cleanupManagerInterval . config) ts <- liftIO getCurrentTime when (diffUTCTime deleteAt ts <= interval) $ startTimedItemThread user itemRef deleteAt startTimedItemThread :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM () startTimedItemThread user itemRef deleteAt = do itemThreads <- asks timedItemThreads threadTVar_ <- atomically $ do exists <- TM.member itemRef itemThreads if not exists then do threadTVar <- newTVar Nothing TM.insert itemRef threadTVar itemThreads pure $ Just threadTVar else pure Nothing forM_ threadTVar_ $ \threadTVar -> do tId <- mkWeakThreadId =<< deleteTimedItem user itemRef deleteAt `forkFinally` const (atomically $ TM.delete itemRef itemThreads) atomically $ writeTVar threadTVar (Just tId) deleteTimedItem :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM () deleteTimedItem user (ChatRef cType chatId scope, itemId) deleteAt = do ts <- liftIO getCurrentTime liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts lift waitChatStartedAndActivated vr <- chatVersionRange case cType of CTDirect -> do (ct, ci) <- withStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId deletions <- deleteDirectCIs user ct [ci] toView $ CEvtChatItemsDeleted user deletions True True CTGroup -> do (gInfo, ci) <- withStore $ \db -> (,) <$> getGroupInfo db vr user chatId <*> getGroupChatItem db user chatId itemId deletedTs <- liftIO getCurrentTime chatScopeInfo <- mapM (getChatScopeInfo vr user) scope deletions <- deleteGroupCIs user gInfo chatScopeInfo [ci] Nothing deletedTs toView $ CEvtChatItemsDeleted user deletions True True _ -> eToView $ ChatError $ CEInternalError "bad deleteTimedItem cType" startUpdatedTimedItemThread :: User -> ChatRef -> ChatItem c d -> ChatItem c d -> CM () startUpdatedTimedItemThread user chatRef ci ci' = case (chatItemTimed ci >>= timedDeleteAt', chatItemTimed ci' >>= timedDeleteAt') of (Nothing, Just deleteAt') -> startProximateTimedItemThread user (chatRef, chatItemId' ci') deleteAt' _ -> pure () metaBrokerTs :: MsgMeta -> UTCTime metaBrokerTs MsgMeta {broker = (_, brokerTs)} = brokerTs createContactPQSndItem :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection) createContactPQSndItem user ct conn@Connection {pqSndEnabled} pqSndEnabled' = flip catchAllErrors (const $ pure (ct, conn)) $ case (pqSndEnabled, pqSndEnabled') of (Just b, b') | b' /= b -> createPQItem $ CISndConnEvent (SCEPqEnabled pqSndEnabled') (Nothing, PQEncOn) -> createPQItem $ CISndDirectE2EEInfo (E2EInfo $ Just pqSndEnabled') _ -> pure (ct, conn) where createPQItem ciContent = do let conn' = conn {pqSndEnabled = Just pqSndEnabled'} :: Connection ct' = ct {activeConn = Just conn'} :: Contact when (contactPQEnabled ct /= contactPQEnabled ct') $ do createInternalChatItem user (CDDirectSnd ct') ciContent Nothing toView $ CEvtContactPQEnabled user ct' pqSndEnabled' pure (ct', conn') updateContactPQRcv :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection) updateContactPQRcv user ct conn@Connection {connId, pqRcvEnabled} pqRcvEnabled' = flip catchAllErrors (const $ pure (ct, conn)) $ case (pqRcvEnabled, pqRcvEnabled') of (Just b, b') | b' /= b -> updatePQ $ CIRcvConnEvent (RCEPqEnabled pqRcvEnabled') (Nothing, PQEncOn) -> updatePQ $ CIRcvDirectE2EEInfo (E2EInfo $ Just pqRcvEnabled') _ -> pure (ct, conn) where updatePQ ciContent = do withStore' $ \db -> updateConnPQRcvEnabled db connId pqRcvEnabled' let conn' = conn {pqRcvEnabled = Just pqRcvEnabled'} :: Connection ct' = ct {activeConn = Just conn'} :: Contact when (contactPQEnabled ct /= contactPQEnabled ct') $ do createInternalChatItem user (CDDirectRcv ct') ciContent Nothing toView $ CEvtContactPQEnabled user ct' pqRcvEnabled' pure (ct', conn') updatePeerChatVRange :: Connection -> VersionRangeChat -> CM Connection updatePeerChatVRange conn@Connection {connId, connChatVersion = v, peerChatVRange, connType, pqSupport, pqEncryption} msgVRange = do v' <- lift $ upgradedConnVersion v msgVRange conn' <- if msgVRange /= peerChatVRange || v' /= v then do withStore' $ \db -> setPeerChatVRange db connId v' msgVRange pure conn {connChatVersion = v', peerChatVRange = msgVRange} else pure conn -- TODO v6.0 remove/review: for contacts only version upgrade should trigger enabling PQ support/encryption if connType == ConnContact && v' >= pqEncryptionCompressionVersion && (pqSupport /= PQSupportOn || pqEncryption /= PQEncOn) then do withStore' $ \db -> updateConnSupportPQ db connId PQSupportOn PQEncOn pure conn' {pqSupport = PQSupportOn, pqEncryption = PQEncOn} else pure conn' updateMemberChatVRange :: GroupMember -> Connection -> VersionRangeChat -> CM (GroupMember, Connection) updateMemberChatVRange mem@GroupMember {groupMemberId, memberChatVRange} conn@Connection {connId, connChatVersion = v, peerChatVRange} msgVRange = do v' <- lift $ upgradedConnVersion v msgVRange if msgVRange /= peerChatVRange || v' /= v || msgVRange /= memberChatVRange then do withStore' $ \db -> do setPeerChatVRange db connId v' msgVRange setMemberChatVRange db groupMemberId msgVRange let conn' = conn {connChatVersion = v', peerChatVRange = msgVRange} pure (mem {memberChatVRange = msgVRange, activeConn = Just conn'}, conn') else pure (mem, conn) upgradedConnVersion :: VersionChat -> VersionRangeChat -> CM' VersionChat upgradedConnVersion v peerVR = do vr <- chatVersionRange' -- don't allow reducing agreed connection version pure $ maybe v (\(Compatible v') -> max v v') $ vr `compatibleVersion` peerVR parseFileDescription :: FilePartyI p => Text -> CM (ValidFileDescription p) parseFileDescription = liftEither . first (ChatError . CEInvalidFileDescription) . (strDecode . encodeUtf8) sendDirectFileInline :: User -> Contact -> FileTransferMeta -> SharedMsgId -> CM () sendDirectFileInline user ct ft sharedMsgId = do msgDeliveryId <- sendFileInline_ ft sharedMsgId $ sendDirectContactMessage user ct withStore $ \db -> updateSndDirectFTDelivery db ct ft msgDeliveryId sendMemberFileInline :: GroupMember -> Connection -> FileTransferMeta -> SharedMsgId -> CM () sendMemberFileInline m@GroupMember {groupId} conn ft sharedMsgId = do msgDeliveryId <- sendFileInline_ ft sharedMsgId $ \msg -> do (sndMsg, msgDeliveryId, _) <- sendDirectMemberMessage conn msg groupId pure (sndMsg, msgDeliveryId) withStore' $ \db -> updateSndGroupFTDelivery db m conn ft msgDeliveryId sendFileInline_ :: FileTransferMeta -> SharedMsgId -> (ChatMsgEvent 'Binary -> CM (SndMessage, Int64)) -> CM Int64 sendFileInline_ FileTransferMeta {filePath, chunkSize} sharedMsgId sendMsg = sendChunks 1 =<< liftIO . B.readFile =<< lift (toFSFilePath filePath) where sendChunks chunkNo bytes = do let (chunk, rest) = B.splitAt chSize bytes (_, msgDeliveryId) <- sendMsg $ BFileChunk sharedMsgId $ FileChunk chunkNo chunk if B.null rest then pure msgDeliveryId else sendChunks (chunkNo + 1) rest chSize = fromIntegral chunkSize parseChatMessage :: Connection -> ByteString -> CM (ChatMessage 'Json) parseChatMessage conn s = do case parseChatMessages s of [msg] -> liftEither . first (ChatError . errType) $ (\(ACMsg _ m) -> checkEncoding m) =<< msg _ -> throwChatError $ CEException "parseChatMessage: single message is expected" where errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s) {-# INLINE parseChatMessage #-} getChatScopeInfo :: VersionRangeChat -> User -> GroupChatScope -> CM GroupChatScopeInfo getChatScopeInfo vr user = \case GCSMemberSupport Nothing -> pure $ GCSIMemberSupport Nothing GCSMemberSupport (Just gmId) -> do supportMem <- withFastStore $ \db -> getGroupMemberById db vr user gmId pure $ GCSIMemberSupport (Just supportMem) getGroupRecipients :: VersionRangeChat -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> VersionChat -> CM [GroupMember] getGroupRecipients vr user gInfo@GroupInfo {useRelays, membership} scopeInfo modsCompatVersion | isTrue useRelays && not (isMemberRelay membership) = do unless (memberCurrent membership && memberActive membership) $ throwChatError $ CECommandError "not current member" withFastStore' $ \db -> getGroupRelays db vr user gInfo | otherwise = case scopeInfo of Nothing -> do unless (memberCurrent membership && memberActive membership) $ throwChatError $ CECommandError "not current member" ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo pure $ filter memberCurrent ms Just (GCSIMemberSupport Nothing) -> do modMs <- withFastStore' $ \db -> getGroupModerators db vr user gInfo let rcpModMs' = filter (\m -> compatible m && memberCurrent m) modMs when (null rcpModMs') $ throwChatError $ CECommandError "no admins support this message" pure rcpModMs' Just (GCSIMemberSupport (Just supportMem)) -> do unless (memberCurrent membership && memberActive membership) $ throwChatError $ CECommandError "not current member" unless (memberCurrentOrPending supportMem) $ throwChatError $ CECommandError "support member not current or pending" if memberStatus supportMem == GSMemPendingApproval then pure [supportMem] else do modMs <- withFastStore' $ \db -> getGroupModerators db vr user gInfo let rcpModMs' = filter (\m -> compatible m && memberCurrent m) modMs pure $ [supportMem] <> rcpModMs' where compatible GroupMember {activeConn, memberChatVRange} = maxVersion (maybe memberChatVRange peerChatVRange activeConn) >= modsCompatVersion mkLocalGroupChatScope :: GroupInfo -> CM (GroupInfo, Maybe GroupChatScopeInfo) mkLocalGroupChatScope gInfo@GroupInfo {membership} | memberPending membership = do (gInfo', scopeInfo) <- mkGroupSupportChatInfo gInfo pure (gInfo', Just scopeInfo) | otherwise = pure (gInfo, Nothing) mkGroupChatScope :: GroupInfo -> GroupMember -> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo) mkGroupChatScope gInfo@GroupInfo {membership} m | memberPending membership = do (gInfo', scopeInfo) <- mkGroupSupportChatInfo gInfo pure (gInfo', m, Just scopeInfo) | memberPending m = do (m', scopeInfo) <- mkMemberSupportChatInfo m pure (gInfo, m', Just scopeInfo) | otherwise = pure (gInfo, m, Nothing) mkGetMessageChatScope :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> MsgContent -> Maybe MsgScope -> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo) mkGetMessageChatScope vr user gInfo@GroupInfo {membership} m mc msgScope_ = mkGroupChatScope gInfo m >>= \case groupScope@(_gInfo', _m', Just _scopeInfo) -> pure groupScope (_, _, Nothing) | isReport mc -> do -- TODO [knocking] return patched _m'? (_m', scopeInfo) <- mkMemberSupportChatInfo m -- only support scope member can send a report (m is sender) pure (gInfo, m, Just scopeInfo) | otherwise -> case msgScope_ of Nothing -> pure (gInfo, m, Nothing) Just (MSMember mId) | sameMemberId mId membership -> do (gInfo', scopeInfo) <- mkGroupSupportChatInfo gInfo pure (gInfo', m, Just scopeInfo) | otherwise -> do referredMember <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo mId -- TODO [knocking] return patched _referredMember'? (_referredMember', scopeInfo) <- mkMemberSupportChatInfo referredMember pure (gInfo, m, Just scopeInfo) mkGroupSupportChatInfo :: GroupInfo -> CM (GroupInfo, GroupChatScopeInfo) mkGroupSupportChatInfo gInfo@GroupInfo {membership} = case supportChat membership of Nothing -> do chatTs <- liftIO getCurrentTime withStore' $ \db -> setSupportChatTs db (groupMemberId' membership) chatTs let gInfo' = gInfo {membership = membership {supportChat = Just $ GroupSupportChat chatTs 0 0 0 Nothing}} scopeInfo = GCSIMemberSupport {groupMember_ = Nothing} pure (gInfo', scopeInfo) Just _supportChat -> let scopeInfo = GCSIMemberSupport {groupMember_ = Nothing} in pure (gInfo, scopeInfo) mkMemberSupportChatInfo :: GroupMember -> CM (GroupMember, GroupChatScopeInfo) mkMemberSupportChatInfo m@GroupMember {groupMemberId, supportChat} = case supportChat of Nothing -> do chatTs <- liftIO getCurrentTime withStore' $ \db -> setSupportChatTs db groupMemberId chatTs let m' = m {supportChat = Just $ GroupSupportChat chatTs 0 0 0 Nothing} scopeInfo = GCSIMemberSupport {groupMember_ = Just m'} pure (m', scopeInfo) Just _supportChat -> let scopeInfo = GCSIMemberSupport {groupMember_ = Just m} in pure (m, scopeInfo) appendFileChunk :: RcvFileTransfer -> Integer -> ByteString -> Bool -> CM () appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs, fileInvitation = FileInvitation {fileName}} chunkNo chunk final = case fileStatus of RFSConnected filePath -> append_ filePath -- sometimes update of file transfer status to FSConnected -- doesn't complete in time before MSG with first file chunk RFSAccepted filePath -> append_ filePath RFSCancelled _ -> pure () _ -> throwChatError $ CEFileInternal "receiving file transfer not in progress" where append_ :: FilePath -> CM () append_ filePath = do fsFilePath <- lift $ toFSFilePath filePath h <- getFileHandle fileId fsFilePath rcvFiles AppendMode liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (fileErr . show) withStore' $ \db -> updatedRcvFileChunkStored db ft chunkNo when final $ do lift $ closeFileHandle fileId rcvFiles forM_ cryptoArgs $ \cfArgs -> do tmpFile <- lift getChatTempDirectory >>= liftIO . (`uniqueCombine` fileName) tryAllErrors (liftError encryptErr $ encryptFile fsFilePath tmpFile cfArgs) >>= \case Right () -> do removeFile fsFilePath `catchAllErrors` \_ -> pure () renameFile tmpFile fsFilePath Left e -> do eToView e removeFile tmpFile `catchAllErrors` \_ -> pure () withStore' (`removeFileCryptoArgs` fileId) where encryptErr e = fileErr $ e <> ", received file not encrypted" fileErr = ChatError . CEFileWrite filePath getFileHandle :: Int64 -> FilePath -> (ChatController -> TVar (Map Int64 Handle)) -> IOMode -> CM Handle getFileHandle fileId filePath files ioMode = do fs <- asks files h_ <- M.lookup fileId <$> readTVarIO fs maybe (newHandle fs) pure h_ where newHandle fs = do h <- openFile filePath ioMode `catchThrow` (ChatError . CEFileInternal . show) atomically . modifyTVar fs $ M.insert fileId h pure h isFileActive :: Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> CM Bool isFileActive fileId files = do fs <- asks files isJust . M.lookup fileId <$> readTVarIO fs cancelRcvFileTransfer :: User -> RcvFileTransfer -> CM () cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, xftpRcvFile} = cancel' `catchAllErrors` \e -> eToView e where cancel' = do lift $ closeFileHandle fileId rcvFiles withStore' $ \db -> do updateFileCancelled db user fileId CIFSRcvCancelled updateRcvFileStatus db fileId FSCancelled deleteRcvFileChunks db ft case xftpRcvFile of Just XFTPRcvFile {agentRcvFileId = Just (AgentRcvFileId aFileId), agentRcvFileDeleted} -> unless agentRcvFileDeleted $ agentXFTPDeleteRcvFile aFileId fileId _ -> pure () cancelSndFile :: User -> FileTransferMeta -> [SndFileTransfer] -> Bool -> CM () cancelSndFile user FileTransferMeta {fileId, xftpSndFile} fts sendCancel = do withStore' (\db -> updateFileCancelled db user fileId CIFSSndCancelled) `catchAllErrors` eToView case xftpSndFile of Nothing -> forM_ fts (\ft -> cancelSndFileTransfer user ft sendCancel) Just xsf -> do forM_ fts (\ft -> cancelSndFileTransfer user ft False) lift (agentXFTPDeleteSndFileRemote user xsf fileId) `catchAllErrors` eToView cancelSndFileTransfer :: User -> SndFileTransfer -> Bool -> CM () cancelSndFileTransfer user@User {userId} ft@SndFileTransfer {fileId, connId, fileStatus, fileInline} sendCancel = unless (fileStatus == FSCancelled || fileStatus == FSComplete) $ cancel' `catchAllErrors` \e -> eToView e where cancel' = do withStore' $ \db -> updateSndFileStatus db ft FSCancelled when sendCancel $ case fileInline of Just _ -> do vr <- chatVersionRange (sharedMsgId, conn) <- withStore $ \db -> (,) <$> getSharedMsgIdByFileId db userId fileId <*> getConnectionById db vr user connId void $ sendDirectMessage_ conn (BFileChunk sharedMsgId FileChunkCancel) (ConnectionId connId) _ -> throwChatError $ CEException "cancelSndFileTransfer: cancelling file via a separate connection is deprecated" closeFileHandle :: Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> CM' () closeFileHandle fileId files = do fs <- asks files h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m) liftIO $ mapM_ hClose h_ `catchAll_` pure () deleteMembersConnections :: User -> [GroupMember] -> CM () deleteMembersConnections user members = deleteMembersConnections' user members False deleteMembersConnections' :: User -> [GroupMember] -> Bool -> CM () deleteMembersConnections' user members waitDelivery = do let memberConns = mapMaybe (\GroupMember {activeConn} -> activeConn) members deleteAgentConnectionsAsync' (map aConnId memberConns) waitDelivery lift . void . withStoreBatch' $ \db -> map (\Connection {connId} -> deleteConnectionRecord db user connId) memberConns deleteMemberConnection :: GroupMember -> CM () deleteMemberConnection mem = deleteMemberConnection' mem False deleteMemberConnection' :: GroupMember -> Bool -> CM () deleteMemberConnection' GroupMember {activeConn} waitDelivery = do forM_ activeConn $ \conn -> do deleteAgentConnectionAsync' (aConnId conn) waitDelivery withStore' $ \db -> updateConnectionStatus db conn ConnDeleted deleteOrUpdateMemberRecord :: User -> GroupInfo -> GroupMember -> CM GroupInfo deleteOrUpdateMemberRecord user gInfo m = withStore' $ \db -> deleteOrUpdateMemberRecordIO db user gInfo m deleteOrUpdateMemberRecordIO :: DB.Connection -> User -> GroupInfo -> GroupMember -> IO GroupInfo deleteOrUpdateMemberRecordIO db user@User {userId} gInfo m = do (gInfo', m') <- deleteSupportChatIfExists db user gInfo m checkGroupMemberHasItems db user m' >>= \case Just _ -> updateGroupMemberStatus db userId m' GSMemRemoved Nothing -> deleteGroupMember db user m' pure gInfo' updateMemberRecordDeleted :: User -> GroupInfo -> GroupMember -> GroupMemberStatus -> CM GroupInfo updateMemberRecordDeleted user@User {userId} gInfo m newStatus = withStore' $ \db -> do (gInfo', m') <- deleteSupportChatIfExists db user gInfo m updateGroupMemberStatus db userId m' newStatus pure gInfo' deleteSupportChatIfExists :: DB.Connection -> User -> GroupInfo -> GroupMember -> IO (GroupInfo, GroupMember) deleteSupportChatIfExists db user gInfo m = do gInfo' <- if gmRequiresAttention m then decreaseGroupMembersRequireAttention db user gInfo else pure gInfo m' <- if isJust (supportChat m) then deleteGroupMemberSupportChat db m else pure m pure (gInfo', m') sendDirectContactMessages :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage] sendDirectContactMessages user ct events = do Connection {connChatVersion = v} <- liftEither $ contactSendConn_ ct if v >= batchSend2Version then sendDirectContactMessages' user ct events else forM (L.toList events) $ \evt -> (Right . fst <$> sendDirectContactMessage user ct evt) `catchAllErrors` \e -> pure (Left e) sendDirectContactMessages' :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage] sendDirectContactMessages' user ct events = do conn@Connection {connId} <- liftEither $ contactSendConn_ ct let idsEvts = L.map (ConnectionId connId,) events msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} sndMsgs_ <- lift $ createSndMessages idsEvts (sndMsgs', pqEnc_) <- batchSendConnMessagesB user conn msgFlags sndMsgs_ forM_ pqEnc_ $ \pqEnc' -> void $ createContactPQSndItem user ct conn pqEnc' pure sndMsgs' sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64) sendDirectContactMessage user ct chatMsgEvent = do conn@Connection {connId} <- liftEither $ contactSendConn_ ct r <- sendDirectMessage_ conn chatMsgEvent (ConnectionId connId) let (sndMessage, msgDeliveryId, pqEnc') = r void $ createContactPQSndItem user ct conn pqEnc' pure (sndMessage, msgDeliveryId) contactSendConn_ :: Contact -> Either ChatError Connection contactSendConn_ ct@Contact {activeConn} = case activeConn of Nothing -> err $ CEContactNotReady ct Just conn | not (connReady conn) -> err $ CEContactNotReady ct | not (contactActive ct) -> err $ CEContactNotActive ct | connDisabled conn -> err $ CEContactDisabled ct | otherwise -> Right conn where err = Left . ChatError -- unlike sendGroupMemberMessage, this function will not store message as pending -- TODO v5.8 we could remove pending messages once all clients support forwarding sendDirectMemberMessage :: MsgEncodingI e => Connection -> ChatMsgEvent e -> GroupId -> CM (SndMessage, Int64, PQEncryption) sendDirectMemberMessage conn chatMsgEvent groupId = sendDirectMessage_ conn chatMsgEvent (GroupId groupId) sendDirectMessage_ :: MsgEncodingI e => Connection -> ChatMsgEvent e -> ConnOrGroupId -> CM (SndMessage, Int64, PQEncryption) sendDirectMessage_ conn chatMsgEvent connOrGroupId = do when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn) msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent connOrGroupId -- TODO move compressed body to SndMessage and compress in createSndMessage (msgDeliveryId, pqEnc') <- deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId pure (msg, msgDeliveryId, pqEnc') createSndMessage :: MsgEncodingI e => ChatMsgEvent e -> ConnOrGroupId -> CM SndMessage createSndMessage chatMsgEvent connOrGroupId = liftEither . runIdentity =<< lift (createSndMessages $ Identity (connOrGroupId, chatMsgEvent)) createSndMessages :: forall e t. (MsgEncodingI e, Traversable t) => t (ConnOrGroupId, ChatMsgEvent e) -> CM' (t (Either ChatError SndMessage)) createSndMessages idsEvents = do g <- asks random vr <- chatVersionRange' withStoreBatch $ \db -> fmap (createMsg db g vr) idsEvents where createMsg :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> (ConnOrGroupId, ChatMsgEvent e) -> IO (Either ChatError SndMessage) createMsg db g vr (connOrGroupId, evnt) = runExceptT $ do withExceptT ChatErrorStore $ createNewSndMessage db g connOrGroupId evnt encodeMessage where encodeMessage sharedMsgId = encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt} sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> Connection -> NonEmpty (ChatMsgEvent e) -> GroupId -> CM () sendGroupMemberMessages user conn events groupId = do when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn) let idsEvts = L.map (GroupId groupId,) events (errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts unless (null errs) $ toView $ CEvtChatErrors errs forM_ (L.nonEmpty msgs) $ \msgs' -> batchSendConnMessages user conn MsgFlags {notification = True} msgs' batchSendConnMessages :: User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption) batchSendConnMessages user conn msgFlags msgs = batchSendConnMessagesB user conn msgFlags $ L.map Right msgs batchSendConnMessagesB :: User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption) batchSendConnMessagesB _user conn msgFlags msgs_ = do let batched_ = batchSndMessagesJSON msgs_ case L.nonEmpty batched_ of Just batched' -> do let msgReqs = L.map (fmap msgBatchReq_) batched' delivered <- deliverMessagesB msgReqs let msgs' = concat $ L.zipWith flattenMsgs batched' delivered pqEnc = findLastPQEnc delivered when (length msgs' /= length msgs_) $ logError "batchSendConnMessagesB: msgs_ and msgs' length mismatch" pure (msgs', pqEnc) Nothing -> pure ([], Nothing) where msgBatchReq_ :: MsgBatch -> ChatMsgReq msgBatchReq_ (MsgBatch batchBody sndMsgs) = (conn, msgFlags, (vrValue batchBody, map (\SndMessage {msgId} -> msgId) sndMsgs)) flattenMsgs :: Either ChatError MsgBatch -> Either ChatError ([Int64], PQEncryption) -> [Either ChatError SndMessage] flattenMsgs (Right (MsgBatch _ sndMsgs)) (Right _) = map Right sndMsgs flattenMsgs (Right (MsgBatch _ sndMsgs)) (Left ce) = replicate (length sndMsgs) (Left ce) flattenMsgs (Left ce) _ = [Left ce] -- restore original ChatError findLastPQEnc :: NonEmpty (Either ChatError ([Int64], PQEncryption)) -> Maybe PQEncryption findLastPQEnc = foldr' (\x acc -> case x of Right (_, pqEnc) -> Just pqEnc; Left _ -> acc) Nothing batchSndMessagesJSON :: NonEmpty (Either ChatError SndMessage) -> [Either ChatError MsgBatch] batchSndMessagesJSON = batchMessages maxEncodedMsgLength . L.toList encodeConnInfo :: MsgEncodingI e => ChatMsgEvent e -> CM ByteString encodeConnInfo chatMsgEvent = do vr <- chatVersionRange encodeConnInfoPQ PQSupportOff (maxVersion vr) chatMsgEvent encodeConnInfoPQ :: MsgEncodingI e => PQSupport -> VersionChat -> ChatMsgEvent e -> CM ByteString encodeConnInfoPQ pqSup v chatMsgEvent = do vr <- chatVersionRange let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent} case encodeChatMessage maxEncodedInfoLength info of ECMEncoded connInfo -> case pqSup of PQSupportOn | v >= pqEncryptionCompressionVersion && B.length connInfo > maxCompressedInfoLength -> do let connInfo' = compressedBatchMsgBody_ connInfo when (B.length connInfo' > maxCompressedInfoLength) $ throwChatError $ CEException "large compressed info" pure connInfo' _ -> pure connInfo ECMLarge -> throwChatError $ CEException "large info" deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption) deliverMessage conn cmEventTag msgBody msgId = do let msgFlags = MsgFlags {notification = hasNotification cmEventTag} deliverMessage' conn msgFlags msgBody msgId deliverMessage' :: Connection -> MsgFlags -> MsgBody -> MessageId -> CM (Int64, PQEncryption) deliverMessage' conn msgFlags msgBody msgId = deliverMessages ((conn, msgFlags, (vrValue msgBody, [msgId])) :| []) >>= \case r :| [] -> case r of Right ([deliveryId], pqEnc) -> pure (deliveryId, pqEnc) Right (deliveryIds, _) -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 delivery id, got " <> show (length deliveryIds) Left e -> throwError e rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs) -- [MessageId] - SndMessage ids inside MsgBatch, or single message id type ChatMsgReq = (Connection, MsgFlags, (ValueOrRef MsgBody, [MessageId])) deliverMessages :: NonEmpty ChatMsgReq -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption))) deliverMessages msgs = deliverMessagesB $ L.map Right msgs deliverMessagesB :: NonEmpty (Either ChatError ChatMsgReq) -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption))) deliverMessagesB msgReqs = do msgReqs' <- if any connSupportsPQ msgReqs then liftIO compressBodies else pure msgReqs sent <- L.zipWith prepareBatch msgReqs' <$> withAgent (`sendMessagesB` snd (mapAccumL toAgent Nothing msgReqs')) lift . void $ withStoreBatch' $ \db -> map (updatePQSndEnabled db) (rights . L.toList $ sent) lift . withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent where connSupportsPQ = \case Right (Connection {pqSupport = PQSupportOn, connChatVersion = v}, _, _) -> v >= pqEncryptionCompressionVersion _ -> False compressBodies = forME msgReqs $ \(conn, msgFlags, (mbr, msgIds)) -> runExceptT $ do mbr' <- case mbr of VRValue i msgBody | B.length msgBody > maxCompressedMsgLength -> do let msgBody' = compressedBatchMsgBody_ msgBody when (B.length msgBody' > maxCompressedMsgLength) $ throwError $ ChatError $ CEException "large compressed message" pure $ VRValue i msgBody' v -> pure v pure (conn, msgFlags, (mbr', msgIds)) toAgent prev = \case Right (conn@Connection {connId, pqEncryption}, msgFlags, (mbr, _msgIds)) -> let cId = case prev of Just prevId | prevId == connId -> "" _ -> aConnId conn in (Just connId, Right (cId, pqEncryption, msgFlags, mbr)) Left _ce -> (prev, Left (AP.INTERNAL "ChatError, skip")) -- as long as it is Left, the agent batchers should just step over it prepareBatch (Right req) (Right ar) = Right (req, ar) prepareBatch (Left ce) _ = Left ce -- restore original ChatError prepareBatch _ (Left ae) = Left $ ChatErrorAgent ae (AgentConnId "") Nothing createDelivery :: DB.Connection -> (ChatMsgReq, (AgentMsgId, PQEncryption)) -> IO (Either ChatError ([Int64], PQEncryption)) createDelivery db ((Connection {connId}, _, (_, msgIds)), (agentMsgId, pqEnc')) = do Right . (,pqEnc') <$> mapM (createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId})) msgIds updatePQSndEnabled :: DB.Connection -> (ChatMsgReq, (AgentMsgId, PQEncryption)) -> IO () updatePQSndEnabled db ((Connection {connId, pqSndEnabled}, _, _), (_, pqSndEnabled')) = case (pqSndEnabled, pqSndEnabled') of (Just b, b') | b' /= b -> updatePQ (Nothing, PQEncOn) -> updatePQ _ -> pure () where updatePQ = updateConnPQSndEnabled db connId pqSndEnabled' sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage sendGroupMessage user gInfo gcScope members chatMsgEvent = do sendGroupMessages user gInfo gcScope members (chatMsgEvent :| []) >>= \case ((Right msg) :| [], _) -> pure msg _ -> throwChatError $ CEInternalError "sendGroupMessage: expected 1 message" sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage sendGroupMessage' user gInfo members chatMsgEvent = sendGroupMessages_ user gInfo members (chatMsgEvent :| []) >>= \case ((Right msg) :| [], _) -> pure msg _ -> throwChatError $ CEInternalError "sendGroupMessage': expected 1 message" sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) sendGroupMessages user gInfo scope members events = do -- TODO [knocking] send current profile to pending member after approval? when shouldSendProfileUpdate $ sendProfileUpdate `catchAllErrors` eToView sendGroupMessages_ user gInfo members events where User {profile = p, userMemberProfileUpdatedAt} = user GroupInfo {userMemberProfileSentAt} = gInfo shouldSendProfileUpdate | isJust scope = False -- why not sending profile updates to scopes? | incognitoMembership gInfo = False | otherwise = case (userMemberProfileSentAt, userMemberProfileUpdatedAt) of (Just lastSentTs, Just lastUpdateTs) -> lastSentTs < lastUpdateTs (Nothing, Just _) -> True _ -> False sendProfileUpdate = do let members' = filter (`supportsVersion` memberProfileUpdateVersion) members allowSimplexLinks = groupFeatureUserAllowed SGFSimplexLinks gInfo profileUpdateEvent = XInfo $ redactedMemberProfile allowSimplexLinks $ fromLocalProfile p void $ sendGroupMessage' user gInfo members' profileUpdateEvent currentTs <- liftIO getCurrentTime withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs data GroupSndResult = GroupSndResult { sentTo :: [(GroupMemberId, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption))], pending :: [(GroupMemberId, Either ChatError MessageId, Either ChatError ())], forwarded :: [GroupMember] } sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) sendGroupMessages_ _user gInfo@GroupInfo {groupId} recipientMembers events = do let idsEvts = L.map (GroupId groupId,) events sndMsgs_ <- lift $ createSndMessages idsEvts recipientMembers' <- liftIO $ shuffleMembers recipientMembers let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} (toSendSeparate, toSendBatched, toPending, forwarded, _, dups) = foldr' (addMember recipientMembers') ([], [], [], [], S.empty, 0 :: Int) recipientMembers' when (dups /= 0) $ logError $ "sendGroupMessages_: " <> tshow dups <> " duplicate members" -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here -- Deliver to toSend members let (sendToMemIds, msgReqs) = prepareMsgReqs msgFlags sndMsgs_ toSendSeparate toSendBatched delivered <- maybe (pure []) (fmap L.toList . deliverMessagesB) $ L.nonEmpty msgReqs when (length delivered /= length sendToMemIds) $ logError "sendGroupMessages_: sendToMemIds and delivered length mismatch" -- Save as pending for toPending members let (pendingMemIds, pendingReqs) = preparePending sndMsgs_ toPending stored <- lift $ withStoreBatch (\db -> map (bindRight $ createPendingMsg db) pendingReqs) when (length stored /= length pendingMemIds) $ logError "sendGroupMessages_: pendingMemIds and stored length mismatch" -- Zip for easier access to results let sentTo = zipWith3 (\mId mReq r -> (mId, fmap (\(_, _, (_, msgIds)) -> msgIds) mReq, r)) sendToMemIds msgReqs delivered pending = zipWith3 (\mId pReq r -> (mId, fmap snd pReq, r)) pendingMemIds pendingReqs stored pure (sndMsgs_, GroupSndResult {sentTo, pending, forwarded}) where shuffleMembers :: [GroupMember] -> IO [GroupMember] shuffleMembers ms = do let (adminMs, otherMs) = partition isAdmin ms liftM2 (<>) (shuffle adminMs) (shuffle otherMs) where isAdmin GroupMember {memberRole} = memberRole >= GRAdmin addMember members m acc@(toSendSeparate, toSendBatched, pending, forwarded, !mIds, !dups) = case memberSendAction gInfo events members m of Just a | mId `S.member` mIds -> (toSendSeparate, toSendBatched, pending, forwarded, mIds, dups + 1) | otherwise -> case a of MSASend conn -> ((m, conn) : toSendSeparate, toSendBatched, pending, forwarded, mIds', dups) MSASendBatched conn -> (toSendSeparate, (m, conn) : toSendBatched, pending, forwarded, mIds', dups) MSAPending -> (toSendSeparate, toSendBatched, m : pending, forwarded, mIds', dups) MSAForwarded -> (toSendSeparate, toSendBatched, pending, m : forwarded, mIds', dups) Nothing -> acc where mId = groupMemberId' m mIds' = S.insert mId mIds prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> [(GroupMember, Connection)] -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq]) prepareMsgReqs msgFlags msgs toSendSeparate toSendBatched = do let batched_ = batchSndMessagesJSON msgs case L.nonEmpty batched_ of Just batched' -> do let lenMsgs = length msgs (memsSep, mreqsSep) = foldMembers lenMsgs sndMessageMBR msgs toSendSeparate (memsBtch, mreqsBtch) = foldMembers (length batched' + lenMsgs) msgBatchMBR batched' toSendBatched (memsSep <> memsBtch, mreqsSep <> mreqsBtch) Nothing -> ([], []) where foldMembers :: forall a. Int -> (Maybe Int -> Int -> a -> (ValueOrRef MsgBody, [MessageId])) -> NonEmpty (Either ChatError a) -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq]) foldMembers lastRef mkMb mbs mems = snd $ foldr' foldMsgBodies (lastMemIdx_, ([], [])) mems where lastMemIdx_ = let len = length mems in if len > 1 then Just len else Nothing foldMsgBodies :: (GroupMember, Connection) -> (Maybe Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) -> (Maybe Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) foldMsgBodies (GroupMember {groupMemberId}, conn) (memIdx_, memIdsReqs) = (subtract 1 <$> memIdx_,) $ snd $ foldr' addBody (lastRef, memIdsReqs) mbs where addBody :: Either ChatError a -> (Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) -> (Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) addBody mb (i, (memIds, reqs)) = let req = (conn,msgFlags,) . mkMb memIdx_ i <$> mb in (i - 1, (groupMemberId : memIds, req : reqs)) sndMessageMBR :: Maybe Int -> Int -> SndMessage -> (ValueOrRef MsgBody, [MessageId]) sndMessageMBR memIdx_ i SndMessage {msgId, msgBody} = (vrValue_ memIdx_ i msgBody, [msgId]) msgBatchMBR :: Maybe Int -> Int -> MsgBatch -> (ValueOrRef MsgBody, [MessageId]) msgBatchMBR memIdx_ i (MsgBatch batchBody sndMsgs) = (vrValue_ memIdx_ i batchBody, map (\SndMessage {msgId} -> msgId) sndMsgs) vrValue_ memIdx_ i v = case memIdx_ of Nothing -> VRValue Nothing v -- sending to one member, do not reference bodies Just 1 -> VRValue (Just i) v Just _ -> VRRef i preparePending :: NonEmpty (Either ChatError SndMessage) -> [GroupMember] -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) preparePending msgs_ = foldr' foldMsgs ([], []) where foldMsgs :: GroupMember -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) foldMsgs GroupMember {groupMemberId} memIdsReqs = foldr' (\msg_ (memIds, reqs) -> (groupMemberId : memIds, fmap pendingReq msg_ : reqs)) memIdsReqs msgs_ where pendingReq :: SndMessage -> (GroupMemberId, MessageId) pendingReq SndMessage {msgId} = (groupMemberId, msgId) createPendingMsg :: DB.Connection -> (GroupMemberId, MessageId) -> IO (Either ChatError ()) createPendingMsg db (groupMemberId, msgId) = createPendingGroupMessage db groupMemberId msgId Nothing $> Right () data MemberSendAction = MSASend Connection | MSASendBatched Connection | MSAPending | MSAForwarded memberSendAction :: GroupInfo -> NonEmpty (ChatMsgEvent e) -> [GroupMember] -> GroupMember -> Maybe MemberSendAction memberSendAction GroupInfo {useRelays, membership} events members m@GroupMember {memberRole, memberStatus} -- groups with relays require newer version - we don't need to check member version for batching and forwarding support | isTrue useRelays = if -- if user is chat relay, send to all non chat relay members | isMemberRelay membership && not (isMemberRelay m) -> MSASendBatched . snd <$> readyMemberConn m -- if user is not chat relay, send only to chat relays | not (isMemberRelay membership) && isMemberRelay m -> MSASendBatched . snd <$> readyMemberConn m | otherwise -> Nothing -- TODO [channels fwd] MSAForwarded to create GSSForwarded snd statuses? | otherwise = case memberConn m of Nothing -> pendingOrForwarded Just conn@Connection {connStatus} | connDisabled conn || connStatus == ConnDeleted || memberStatus == GSMemRejected -> Nothing | connInactive conn -> Just MSAPending | connStatus == ConnSndReady || connStatus == ConnReady -> sendBatchedOrSeparate conn | otherwise -> pendingOrForwarded where sendBatchedOrSeparate conn -- admin doesn't support batch forwarding - send messages separately so that admin can forward one by one | memberRole >= GRAdmin && not (m `supportsVersion` batchSend2Version) = Just (MSASend conn) -- either member is not admin, or admin supports batched forwarding | otherwise = Just (MSASendBatched conn) pendingOrForwarded = case memberCategory m of GCUserMember -> Nothing -- shouldn't happen GCInviteeMember -> Just MSAPending GCHostMember -> Just MSAPending GCPreMember -> forwardSupportedOrPending (invitedByGroupMemberId membership) GCPostMember -> forwardSupportedOrPending (invitedByGroupMemberId m) where forwardSupportedOrPending invitingMemberId_ | membersSupport && all isForwardedGroupMsg events = Just MSAForwarded | any isXGrpMsgForward events = Nothing | otherwise = Just MSAPending where membersSupport = m `supportsVersion` groupForwardVersion && invitingMemberSupportsForward invitingMemberSupportsForward = case invitingMemberId_ of Just invMemberId -> -- can be optimized for large groups by replacing [GroupMember] with Map GroupMemberId GroupMember case find (\m' -> groupMemberId' m' == invMemberId) members of Just invitingMember -> invitingMember `supportsVersion` groupForwardVersion Nothing -> False Nothing -> False isXGrpMsgForward event = case event of XGrpMsgForward {} -> True _ -> False -- Should match memberSendAction logic readyMemberConn :: GroupMember -> Maybe (GroupMemberId, Connection) readyMemberConn GroupMember {groupMemberId, activeConn = Just conn@Connection {connStatus}, memberStatus} | (connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn) && not (connInactive conn) && memberStatus /= GSMemRejected = Just (groupMemberId, conn) | otherwise = Nothing readyMemberConn GroupMember {activeConn = Nothing} = Nothing sendGroupMemberMessage :: MsgEncodingI e => GroupInfo -> GroupMember -> ChatMsgEvent e -> Maybe GroupMemberIntro -> CM () -> CM () sendGroupMemberMessage gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId} chatMsgEvent intro_ postDeliver = do msg <- createSndMessage chatMsgEvent (GroupId groupId) messageMember msg `catchAllErrors` eToView where messageMember :: SndMessage -> CM () messageMember SndMessage {msgId, msgBody} = forM_ (memberSendAction gInfo (chatMsgEvent :| []) [m] m) $ \case MSASend conn -> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId >> postDeliver MSASendBatched conn -> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId >> postDeliver MSAPending -> withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId (introId <$> intro_) MSAForwarded -> pure () -- TODO ensure order - pending messages interleave with user input messages sendPendingGroupMessages :: User -> GroupMember -> Connection -> CM () sendPendingGroupMessages user GroupMember {groupMemberId} conn = do pgms <- withStore' $ \db -> getPendingGroupMessages db groupMemberId forM_ (L.nonEmpty pgms) $ \pgms' -> do let msgs = L.map (\(sndMsg, _, _) -> sndMsg) pgms' void $ batchSendConnMessages user conn MsgFlags {notification = True} msgs lift . void . withStoreBatch' $ \db -> L.map (\SndMessage {msgId} -> deletePendingGroupMessage db groupMemberId msgId) msgs lift . void . withStoreBatch' $ \db -> L.map (\(_, tag, introId_) -> updateIntro_ db tag introId_) pgms' where updateIntro_ :: DB.Connection -> ACMEventTag -> Maybe Int64 -> IO () updateIntro_ db tag introId_ = case (tag, introId_) of (ACMEventTag _ XGrpMemFwd_, Just introId) -> updateIntroStatus db introId GMIntroInvForwarded _ -> pure () saveDirectRcvMSG :: MsgEncodingI e => Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (Connection, RcvMessage) saveDirectRcvMSG conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do conn' <- updatePeerChatVRange conn chatVRange let agentMsgId = fst $ recipient agentMsgMeta brokerTs = metaBrokerTs agentMsgMeta newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing pure (conn', msg) saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (GroupMember, Connection, RcvMessage) saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do (am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- updateMemberChatVRange authorMember conn chatVRange let agentMsgId = fst $ recipient agentMsgMeta brokerTs = metaBrokerTs agentMsgMeta newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} msg <- withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery $ Just amGroupMemId) `catchAllErrors` \e -> case e of ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do vr <- chatVersionRange fm <- withStore $ \db -> getGroupMember db vr user groupId forwardedByGroupMemberId forM_ (memberConn fm) $ \fmConn -> void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemId) groupId throwError e _ -> throwError e pure (am', conn', msg) saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> UTCTime -> CM (Maybe RcvMessage) saveGroupFwdRcvMsg user GroupInfo {groupId, useRelays} forwardingMember refAuthorMember@GroupMember {memberId = refMemberId} msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} brokerTs = do let newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs} fwdMemberId = Just $ groupMemberId' forwardingMember refAuthorId = Just $ groupMemberId' refAuthorMember -- TODO [channels fwd] TBC highlighting difference between deduplicated messages (useRelays branch) withStore' (\db -> runExceptT $ createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) >>= \case Right msg -> pure $ Just msg Left e@SEDuplicateGroupMessage {authorGroupMemberId, forwardedByGroupMemberId} | isTrue useRelays -> pure Nothing -- with chat relays, duplicates are expected | otherwise -> case (authorGroupMemberId, forwardedByGroupMemberId) of (Just authorGMId, Nothing) -> do vr <- chatVersionRange am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db vr user groupId authorGMId if sameMemberId refMemberId am then forM_ (memberConn forwardingMember) $ \fmConn -> void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemberId) groupId else toView $ CEvtMessageError user "error" "saveGroupFwdRcvMsg: referenced author member id doesn't match message member id" throwError $ ChatErrorStore e _ -> throwError $ ChatErrorStore e Left e -> throwError $ ChatErrorStore e saveSndChatItem :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> CM (ChatItem c 'MDSnd) saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing Nothing False -- TODO [mentions] optimize by avoiding unnecesary parsing of control messages saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd) saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live = do let itemTexts = ciContentTexts content saveSndChatItems user cd [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case [Right ci] -> pure ci _ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item" data NewSndChatItemData c = NewSndChatItemData { msg :: SndMessage, content :: CIContent 'MDSnd, itemTexts :: (Text, Maybe MarkdownList), itemMentions :: Map MemberName CIMention, ciFile :: Maybe (CIFile 'MDSnd), quotedItem :: Maybe (CIQuote c), itemForwarded :: Maybe CIForwardedFrom } saveSndChatItems :: forall c. ChatTypeI c => User -> ChatDirection c 'MDSnd -> [Either ChatError (NewSndChatItemData c)] -> Maybe CITimed -> Bool -> CM [Either ChatError (ChatItem c 'MDSnd)] saveSndChatItems user cd itemsData itemTimed live = do createdAt <- liftIO getCurrentTime vr <- chatVersionRange when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $ void $ withStore' (\db -> updateChatTsStats db vr user cd createdAt Nothing) lift $ withStoreBatch (\db -> map (bindRight $ createItem db createdAt) itemsData) where createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd)) createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt let ci = mkChatItem_ cd False ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False createdAt Nothing createdAt Right <$> case cd of CDGroupSnd g _scope | not (null itemMentions) -> createGroupCIMentions db g ci itemMentions _ -> pure ci saveRcvChatItemNoParse :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> CM (ChatItem c 'MDRcv, ChatInfo c) saveRcvChatItemNoParse user cd msg brokerTs = saveRcvChatItem user cd msg brokerTs . ciContentNoParse saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> CM (ChatItem c 'MDRcv, ChatInfo c) saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty ciContentNoParse :: CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) ciContentNoParse content = (content, (ciContentToText content, Nothing)) saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv, ChatInfo c) saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do createdAt <- liftIO getCurrentTime vr <- chatVersionRange withStore' $ \db -> do (mentions' :: Map MemberName CIMention, userMention) <- case cd of CDGroupRcv g@GroupInfo {membership} _scope _m -> do mentions' <- getRcvCIMentions db user g ft_ mentions let userReply = case cmToQuotedMsg chatMsgEvent of Just QuotedMsg {msgRef = MsgRef {memberId = Just mId}} -> sameMemberId mId membership _ -> False userMention' = userReply || any (\CIMention {memberId} -> sameMemberId memberId membership) mentions' in pure (mentions', userMention') CDDirectRcv _ -> pure (M.empty, False) cInfo' <- if (ciRequiresAttention content || contactChatDeleted cd) then updateChatTsStats db vr user cd createdAt (memberChatStats userMention) else pure $ toChatInfo cd (ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live userMention brokerTs createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt let ci = mkChatItem_ cd False ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention brokerTs forwardedByMember createdAt ci' <- case cd of CDGroupRcv g _scope _m | not (null mentions') -> createGroupCIMentions db g ci mentions' _ -> pure ci pure (ci', cInfo') where memberChatStats :: Bool -> Maybe (Int, MemberAttention, Int) memberChatStats userMention = case cd of CDGroupRcv _g (Just scope) m -> do let unread = fromEnum $ ciCreateStatus content == CISRcvNew in Just (unread, memberAttentionChange unread (Just brokerTs) m scope, fromEnum userMention) _ -> Nothing -- TODO [mentions] optimize by avoiding unnecessary parsing mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs = let ts = ciContentTexts content in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs = let itemStatus = ciCreateStatus content meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention currentTs itemTs forwardedByMember showGroupAsSender currentTs currentTs in ChatItem {chatDir = toCIDirection cd, meta, content, mentions = M.empty, formattedText, quotedItem, reactions = [], file} createAgentConnectionAsync :: ConnectionModeI c => User -> CommandFunction -> Bool -> SConnectionMode c -> SubscriptionMode -> CM (CommandId, ConnId) createAgentConnectionAsync user cmdFunction enableNtfs cMode subMode = do cmdId <- withStore' $ \db -> createCommand db user Nothing cmdFunction connId <- withAgent $ \a -> createConnectionAsync a (aUserId user) (aCorrId cmdId) enableNtfs cMode IKPQOff subMode pure (cmdId, connId) joinAgentConnectionAsync :: User -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> CM (CommandId, ConnId) joinAgentConnectionAsync user enableNtfs cReqUri cInfo subMode = do cmdId <- withStore' $ \db -> createCommand db user Nothing CFJoinConn connId <- withAgent $ \a -> joinConnectionAsync a (aUserId user) (aCorrId cmdId) enableNtfs cReqUri cInfo PQSupportOff subMode pure (cmdId, connId) allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> ChatMsgEvent e -> CM () allowAgentConnectionAsync user conn@Connection {connId, pqSupport, connChatVersion} confId msg = do cmdId <- withStore' $ \db -> createCommand db user (Just connId) CFAllowConn dm <- encodeConnInfoPQ pqSupport connChatVersion msg withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId dm withStore' $ \db -> updateConnectionStatus db conn ConnAccepted agentAcceptContactAsync :: MsgEncodingI e => User -> Bool -> InvitationId -> ChatMsgEvent e -> SubscriptionMode -> PQSupport -> VersionChat -> CM (CommandId, ConnId) agentAcceptContactAsync user enableNtfs invId msg subMode pqSup chatV = do cmdId <- withStore' $ \db -> createCommand db user Nothing CFAcceptContact dm <- encodeConnInfoPQ pqSup chatV msg connId <- withAgent $ \a -> acceptContactAsync a (aUserId user) (aCorrId cmdId) enableNtfs invId dm pqSup subMode pure (cmdId, connId) deleteAgentConnectionAsync :: ConnId -> CM () deleteAgentConnectionAsync acId = deleteAgentConnectionAsync' acId False {-# INLINE deleteAgentConnectionAsync #-} deleteAgentConnectionAsync' :: ConnId -> Bool -> CM () deleteAgentConnectionAsync' acId waitDelivery = do withAgent (\a -> deleteConnectionAsync a waitDelivery acId) `catchAllErrors` eToView deleteAgentConnectionsAsync :: [ConnId] -> CM () deleteAgentConnectionsAsync acIds = deleteAgentConnectionsAsync' acIds False {-# INLINE deleteAgentConnectionsAsync #-} deleteAgentConnectionsAsync' :: [ConnId] -> Bool -> CM () deleteAgentConnectionsAsync' [] _ = pure () deleteAgentConnectionsAsync' acIds waitDelivery = do withAgent (\a -> deleteConnectionsAsync a waitDelivery acIds) `catchAllErrors` eToView agentXFTPDeleteRcvFile :: RcvFileId -> FileTransferId -> CM () agentXFTPDeleteRcvFile aFileId fileId = do lift $ withAgent' (`xftpDeleteRcvFile` aFileId) withStore' $ \db -> setRcvFTAgentDeleted db fileId agentXFTPDeleteRcvFiles :: [(XFTPRcvFile, FileTransferId)] -> CM' () agentXFTPDeleteRcvFiles rcvFiles = do let rcvFiles' = filter (not . agentRcvFileDeleted . fst) rcvFiles rfIds = mapMaybe fileIds rcvFiles' withAgent' $ \a -> xftpDeleteRcvFiles a (map fst rfIds) void . withStoreBatch' $ \db -> map (setRcvFTAgentDeleted db . snd) rfIds where fileIds :: (XFTPRcvFile, FileTransferId) -> Maybe (RcvFileId, FileTransferId) fileIds (XFTPRcvFile {agentRcvFileId = Just (AgentRcvFileId aFileId)}, fileId) = Just (aFileId, fileId) fileIds _ = Nothing agentXFTPDeleteSndFileRemote :: User -> XFTPSndFile -> FileTransferId -> CM' () agentXFTPDeleteSndFileRemote user xsf fileId = agentXFTPDeleteSndFilesRemote user [(xsf, fileId)] agentXFTPDeleteSndFilesRemote :: User -> [(XFTPSndFile, FileTransferId)] -> CM' () agentXFTPDeleteSndFilesRemote user sndFiles = do (_errs, redirects) <- partitionEithers <$> withStoreBatch' (\db -> map (lookupFileTransferRedirectMeta db user . snd) sndFiles) let redirects' = mapMaybe mapRedirectMeta $ concat redirects sndFilesAll = redirects' <> sndFiles sndFilesAll' = filter (not . agentSndFileDeleted . fst) sndFilesAll -- while file is being prepared and uploaded, it would not have description available; -- this partitions files into those with and without descriptions - -- files with description are deleted remotely, files without description are deleted internally (sfsNoDescr, sfsWithDescr) <- partitionSndDescr sndFilesAll' [] [] withAgent' $ \a -> xftpDeleteSndFilesInternal a sfsNoDescr withAgent' $ \a -> xftpDeleteSndFilesRemote a (aUserId user) sfsWithDescr void . withStoreBatch' $ \db -> map (setSndFTAgentDeleted db user . snd) sndFilesAll' where mapRedirectMeta :: FileTransferMeta -> Maybe (XFTPSndFile, FileTransferId) mapRedirectMeta FileTransferMeta {fileId = fileId, xftpSndFile = Just sndFileRedirect} = Just (sndFileRedirect, fileId) mapRedirectMeta _ = Nothing partitionSndDescr :: [(XFTPSndFile, FileTransferId)] -> [SndFileId] -> [(SndFileId, ValidFileDescription 'FSender)] -> CM' ([SndFileId], [(SndFileId, ValidFileDescription 'FSender)]) partitionSndDescr [] filesWithoutDescr filesWithDescr = pure (filesWithoutDescr, filesWithDescr) partitionSndDescr ((XFTPSndFile {agentSndFileId = AgentSndFileId aFileId, privateSndFileDescr}, _) : xsfs) filesWithoutDescr filesWithDescr = case privateSndFileDescr of Nothing -> partitionSndDescr xsfs (aFileId : filesWithoutDescr) filesWithDescr Just sfdText -> tryAllErrors' (parseFileDescription sfdText) >>= \case Left _ -> partitionSndDescr xsfs (aFileId : filesWithoutDescr) filesWithDescr Right sfd -> partitionSndDescr xsfs filesWithoutDescr ((aFileId, sfd) : filesWithDescr) connRequestPQEncryption :: ConnectionRequestUri c -> Maybe PQEncryption connRequestPQEncryption = \case CRContactUri _ -> Nothing CRInvitationUri _ (CR.E2ERatchetParamsUri vr' _ _ pq) -> Just $ PQEncryption $ maxVersion vr' >= CR.pqRatchetE2EEncryptVersion && isJust pq createRcvFeatureItems :: User -> Contact -> Contact -> CM' () createRcvFeatureItems user ct ct' = createFeatureItems user ct ct' CDDirectRcv CIRcvChatFeature CIRcvChatPreference contactPreference createSndFeatureItems :: User -> Contact -> Contact -> CM' () createSndFeatureItems user ct ct' = createFeatureItems user ct ct' CDDirectSnd CISndChatFeature CISndChatPreference getPref where getPref ContactUserPreference {userPreference} = case userPreference of CUPContact {preference} -> preference CUPUser {preference} -> preference -- Used when contact is changed after creating initial feature items via createFeatureEnabledItems_ -- (APIChangePreparedContactUser, APIConnectPreparedContact with incognito = True); -- creates feature items with CDDirectRcv direction so that changed feature items stay in the same place in chat view createContactChangedFeatureItems :: User -> Contact -> Contact -> CM' () createContactChangedFeatureItems user ct ct' = createFeatureItems user ct ct' CDDirectRcv CIRcvChatFeature CIRcvChatPreference getPref where getPref ContactUserPreference {userPreference} = case userPreference of CUPContact {preference} -> preference CUPUser {preference} -> preference type FeatureContent a d = ChatFeature -> a -> Maybe Int -> CIContent d createFeatureEnabledItems :: User -> Contact -> CM () createFeatureEnabledItems user ct = createFeatureEnabledItems_ user ct >>= toView . CEvtNewChatItems user createFeatureEnabledItems_ :: User -> Contact -> CM [AChatItem] createFeatureEnabledItems_ user ct@Contact {mergedPreferences} = forM allChatFeatures $ \(ACF f) -> do let state = featureState $ getContactUserPreference f mergedPreferences createChatItem user (CDDirectRcv ct) False (uncurry (CIRcvChatFeature $ chatFeature f) state) Nothing Nothing createFeatureItems :: MsgDirectionI d => User -> Contact -> Contact -> (Contact -> ChatDirection 'CTDirect d) -> FeatureContent PrefEnabled d -> FeatureContent FeatureAllowed d -> (forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) -> CM' () createFeatureItems user ct ct' = createContactsFeatureItems user [(ct, ct')] createContactsFeatureItems :: forall d. MsgDirectionI d => User -> [(Contact, Contact)] -> (Contact -> ChatDirection 'CTDirect d) -> FeatureContent PrefEnabled d -> FeatureContent FeatureAllowed d -> (forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) -> CM' () createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do let dirsCIContents = map contactChangedFeatures cts (errs, acis) <- partitionEithers <$> createChatItems user Nothing dirsCIContents unless (null errs) $ toView' $ CEvtChatErrors errs toView' $ CEvtNewChatItems user acis where contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) contactChangedFeatures (Contact {mergedPreferences = cups}, ct'@Contact {mergedPreferences = cups'}) = do let contents = mapMaybe (\(ACF f) -> featureCIContent_ f) allChatFeatures (chatDir ct', False, contents) where featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d, Maybe SharedMsgId) featureCIContent_ f | state /= state' = Just (fContent ciFeature state', Nothing) | prefState /= prefState' = Just (fContent ciOffer prefState', Nothing) | otherwise = Nothing where fContent :: FeatureContent a d -> (a, Maybe Int) -> CIContent d fContent ci (s, param) = ci f' s param f' = chatFeature f state = featureState cup state' = featureState cup' prefState = preferenceState $ getPref cup prefState' = preferenceState $ getPref cup' cup = getContactUserPreference f cups cup' = getContactUserPreference f cups' createGroupFeatureChangedItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> GroupInfo -> CM () createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences = gps} GroupInfo {fullGroupPreferences = gps'} = forM_ allGroupFeatures $ \(AGF f) -> do let state = groupFeatureState $ getGroupPreference f gps pref' = getGroupPreference f gps' state'@(_, param', role') = groupFeatureState pref' when (state /= state') $ createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref') param' role') Nothing sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing} createGroupFeatureItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> CM () createGroupFeatureItems user cd ciContent g = createGroupFeatureItems_ user cd False ciContent g >>= toView . CEvtNewChatItems user createGroupFeatureItems_ :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> ShowGroupAsSender -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> CM [AChatItem] createGroupFeatureItems_ user cd showGroupAsSender ciContent GroupInfo {fullGroupPreferences} = forM allGroupFeatures $ \(AGF f) -> do let p = getGroupPreference f fullGroupPreferences (_, param, role) = groupFeatureState p createChatItem user cd showGroupAsSender (ciContent (toGroupFeature f) (toGroupPreference p) param role) Nothing Nothing createInternalChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM () createInternalChatItem user cd content itemTs_ = do ci <- createChatItem user cd False content Nothing itemTs_ toView $ CEvtNewChatItems user [ci] createChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Maybe UTCTime -> CM AChatItem createChatItem user cd showGroupAsSender content sharedMsgId itemTs_ = lift (createChatItems user itemTs_ [(cd, showGroupAsSender, [(content, sharedMsgId)])]) >>= \case [Right ci] -> pure ci [Left e] -> throwError e rs -> throwChatError $ CEInternalError $ "createInternalChatItem: expected 1 result, got " <> show (length rs) -- Supports items with shared msg ID that are created for all conversation parties, but were not communicated via the usual messages. -- This includes address welcome message and contact request message. createChatItems :: forall c d. (ChatTypeI c, MsgDirectionI d) => User -> Maybe UTCTime -> [(ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)])] -> CM' [Either ChatError AChatItem] createChatItems user itemTs_ dirsCIContents = do createdAt <- liftIO getCurrentTime let itemTs = fromMaybe createdAt itemTs_ vr <- chatVersionRange' void . withStoreBatch' $ \db -> map (updateChat db vr createdAt) dirsCIContents withStoreBatch' $ \db -> concatMap (createACIs db itemTs createdAt) dirsCIContents where updateChat :: DB.Connection -> VersionRangeChat -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> IO () updateChat db vr createdAt (cd, _, contents) | any (ciRequiresAttention . fst) contents || contactChatDeleted cd = void $ updateChatTsStats db vr user cd createdAt memberChatStats | otherwise = pure () where memberChatStats :: Maybe (Int, MemberAttention, Int) memberChatStats = case cd of CDGroupRcv _g (Just scope) m -> do let unread = length $ filter (ciRequiresAttention . fst) contents in Just (unread, memberAttentionChange unread itemTs_ m scope, 0) _ -> Nothing createACIs :: DB.Connection -> UTCTime -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> [IO AChatItem] createACIs db itemTs createdAt (cd, showGroupAsSender, contents) = map createACI contents where createACI (content, sharedMsgId) = do ciId <- createNewChatItemNoMsg db user cd showGroupAsSender content sharedMsgId itemTs createdAt let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci memberAttentionChange :: Int -> (Maybe UTCTime) -> GroupMember -> GroupChatScopeInfo -> MemberAttention memberAttentionChange unread brokerTs_ rcvMem = \case GCSIMemberSupport (Just suppMem) | groupMemberId' suppMem == groupMemberId' rcvMem -> MAInc unread brokerTs_ | msgIsNewerThanLastUnanswered -> MAReset | otherwise -> MAInc 0 Nothing where msgIsNewerThanLastUnanswered = case (supportChat suppMem >>= lastMsgFromMemberTs, brokerTs_) of (Just lastMsgTs, Just brokerTs) -> lastMsgTs < brokerTs _ -> False GCSIMemberSupport Nothing -> MAInc 0 Nothing createLocalChatItems :: User -> ChatDirection 'CTLocal 'MDSnd -> NonEmpty (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> UTCTime -> CM [ChatItem 'CTLocal 'MDSnd] createLocalChatItems user cd itemsData createdAt = do vr <- chatVersionRange void $ withStore' $ \db -> updateChatTsStats db vr user cd createdAt Nothing (errs, items) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (createItem db) $ L.toList itemsData) unless (null errs) $ toView $ CEvtChatErrors errs pure items where createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd) createItem db (content, ciFile, itemForwarded, ts) = do ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False createdAt Nothing createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False createdAt Nothing createdAt withUser' :: (User -> CM ChatResponse) -> CM ChatResponse withUser' action = asks currentUser >>= readTVarIO >>= maybe (throwChatError CENoActiveUser) action withUser :: (User -> CM ChatResponse) -> CM ChatResponse withUser action = withUser' $ \user -> ifM (lift chatStarted) (action user) (throwChatError CEChatNotStarted) withUser_ :: CM ChatResponse -> CM ChatResponse withUser_ = withUser . const withUserId' :: UserId -> (User -> CM ChatResponse) -> CM ChatResponse withUserId' userId action = withUser' $ \user -> do checkSameUser userId user action user withUserId :: UserId -> (User -> CM ChatResponse) -> CM ChatResponse withUserId userId action = withUser $ \user -> do checkSameUser userId user action user checkSameUser :: UserId -> User -> CM () checkSameUser userId User {userId = activeUserId} = when (userId /= activeUserId) $ throwChatError (CEDifferentActiveUser userId activeUserId) chatStarted :: CM' Bool chatStarted = fmap isJust . readTVarIO =<< asks agentAsync waitChatStartedAndActivated :: CM' () waitChatStartedAndActivated = do agentStarted <- asks agentAsync chatActivated <- asks chatActivated atomically $ do started <- readTVar agentStarted activated <- readTVar chatActivated unless (isJust started && activated) retry chatVersionRange :: CM VersionRangeChat chatVersionRange = lift chatVersionRange' {-# INLINE chatVersionRange #-} chatVersionRange' :: CM' VersionRangeChat chatVersionRange' = do ChatConfig {chatVRange} <- asks config pure chatVRange {-# INLINE chatVersionRange' #-} adminContactReq :: ConnReqContact adminContactReq = either error id $ strDecode "simplex:/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23MCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%3D" simplexTeamContactProfile :: Profile simplexTeamContactProfile = Profile { displayName = "Ask SimpleX Team", fullName = "", shortDescr = Just "Send questions about SimpleX Chat app and your suggestions", image = Just (ImageData "data:image/jpg;base64,/9j/4AAQSkZJRgABAgAAAQABAAD/2wBDAAUDBAQEAwUEBAQFBQUGBwwIBwcHBw8KCwkMEQ8SEhEPERATFhwXExQaFRARGCEYGhwdHx8fExciJCIeJBweHx7/2wBDAQUFBQcGBw4ICA4eFBEUHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh7/wAARCAETARMDASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAAAgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKSo0NTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl5ufo6erx8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREAAgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYkNOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOEhYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwD7LooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiivP/iF4yFvv0rSpAZek0yn7v+yPeunC4WpiqihBf8A8rOc5w2UYZ4jEPTourfZDvH3jL7MW03SpR53SWUfw+w96veA/F0erRLY3zKl6owD2k/8Ar15EWLEljknqadDK8MqyxMUdTlWB5Br66WS0Hh/ZLfv1ufiNLj7Mo5m8ZJ3g9OTpy+Xn5/pofRdFcd4B8XR6tEthfMEvVHyk9JB/jXY18fiMPUw9R06i1P3PK80w2aYaOIw8rxf3p9n5hRRRWB6AUUVDe3UFlavc3MixxIMsxppNuyJnOMIuUnZIL26gsrV7m5kWOJBlmNeU+I/Gd9e6sk1hI8FvA2Y1z973NVPGnimfXLoxRFo7JD8if3vc1zefevr8syiNKPtKyvJ9Ox+F8Ycb1cdU+rYCTjTi/iWjk1+nbue3eEPEdtrtoMER3SD95Hn9R7Vu18+6bf3On3kd1aSmOVDkEd/Y17J4P8SW2vWY6R3aD97F/Ue1eVmmVPDP2lP4fyPtODeMoZrBYXFO1Zf+Tf8AB7r5o3qKKK8Q/QgooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAqavbTXmmz20Fw1vJIhVZB1FeDa3p15pWoSWl6hWQHr2YeoNfQlY3izw9Z6/YGGZQky8xSgcqf8K9jKcyWEnyzXuv8D4njLhZ51RVSi7VYLRdGu3k+z+88HzRuq1rWmXmkX8lnexFHU8Hsw9RVLNfcxlGcVKLumfgFahUozdOorSWjT6E0M0kMqyxOyOpyrKcEGvXPAPjCPVolsb9wl6owGPAkH+NeO5p8M0kMqyxOyOpyrA4INcWPy+njKfLLfoz2+HuIMTkmI9pT1i/ij0a/wA+zPpGiuM+H/jCPV4lsL91S+QfKTwJR/jXW3t1BZWslzcyLHFGMsxNfB4jC1aFX2U1r+fof0Rl2bYXMMKsVRl7vXy7p9rBfXVvZWr3NzKscSDLMTXjnjbxVPrtyYoiY7JD8if3vc0zxv4ruNeujFEWjsoz8if3vc1zOa+synKFh0qtVe9+X/BPxvjLjKWZSeEwjtSW7/m/4H5kmaM1HmlB54r3bH51YkzXo3wz8MXMc0es3ZeED/VR5wW9z7VB8O/BpnMerarEREDuhhb+L3Pt7V6cAAAAAAOgFfL5xmqs6FH5v9D9a4H4MlzQzHGq1tYR/KT/AEXzCiiivlj9hCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxfFvh208QWBhmASdRmKUdVP+FeH63pl5pGoSWV5EUdTwezD1HtX0VWL4t8O2fiHTzBONk6g+TKByp/wr28pzZ4WXs6msH+B8NxdwhTzeDxGHVqy/8m8n59n954FmjNW9b0y80fUHsr2MpIp4PZh6iqWfevuYyjOKlF3TPwetQnRm6dRWktGmSwzSQyrLE7I6nKsDgg1teIPFOqa3a29vdy4jiUAheN7f3jWBmjNROhTnJTkrtbGtLF4ijSnRpzajPddHbuP3e9Lmo80ua0scth+a9E+HXgw3Hl6tqsZEX3oYmH3vc+1J8OPBZnKavq0eIhzDCw+9/tH29q9SAAAAGAOgr5bOM35b0KD16v8ARH6twXwXz8uPx0dN4xfXzf6IFAUAAAAdBRRRXyZ+wBRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFB4GTXyj+1p+0ONJjufA3ga6DX7qU1DUY24gB4McZH8Xqe38tqFCdefLETaSufQ3h/4geEde8Uah4a0rWra51Ow/wBfCrD8ceuO+OldRX5I+GfEWseG/ENvr2j30ttqFvJ5iSqxyT3z6g96/RH9nD41aT8U9AWGcx2fiK1QC7tC33/+mieqn07V14zL3QXNHVEQnc9dooorzjQKKKKACiis7xHrel+HdGudY1m8is7K2QvLLI2AAP600m3ZAYfxUg8Pr4VutT1+7isYbSMuLp/4Pb3z6V8++HNd0zxDpq6hpVys8DHGRwVPoR2NeIftJ/G7VPifrbWVk8lp4btZD9mtwcGU/wDPR/c9h2rgfh34z1LwdrAurV2ktZCBcW5PyyD/AB9DX2WTyqYWny1Ho+nY+C4t4Wp5tF16CtVX/k3k/Ps/vPr/ADRmsjwx4g07xFpMWpaZOJInHI/iQ9wR61qbq+mVmro/D6tCdGbp1FZrdEma6/4XafpWoa7jUpV3oA0MLdJD/ntXG5p8E0kMqyxOyOhyrKcEGsMTRlWpShGVm+p1ZbiYYPFQr1IKai72fU+nFAUAKAAOABRXEfDnxpFrMK6fqDhL9BhSeko9frXb1+a4rDVMNUdOotT+k8szLD5lh44jDu8X968n5hRRRXOegFFFFABUGoXlvYWkl1dSrHFGMliaL+7t7C0kuruVYoYxlmNeI+OvFtx4huzHFuisYz+7jz97/aNenluW1MbU00it2fM8S8SUMkoXetR/DH9X5fmeteF/E+m+IFkFoxSWMnMb9cev0rbr5t0vULrTb6K8s5TFNGcgj+R9q9w8E+KbXxDYjlY7xB+9i/qPaurNsneE/eUtYfkeTwlxjHNV9XxVo1V90vTz8vmjoqKKK8I+8CiiigAooooAKKKKACiiigD5V/a8+P0mgvdeAvCUskepFdl9eDjyQR9xPfHeviiR3lkaSR2d2OWZjkk+tfoj+058CtP+Jektq2jxRWnie2T91KMKLlR/yzf+h7V+fOuaVqGiarcaXqtpLaXls5jlikXDKRX0mWSpOlaG/U56l76lKtPwtr+reGNetdb0S8ls761cPHJG2D9D6g9MVmUV6TSasyD9Jf2cfjXpPxR0MW9w0dp4gtkAubYnHmf7aeo/lXr1fkh4W1/V/DGuW2taHey2d9bOHjkjP6H1HtX6Jfs5fGvR/inoQgmeOz8RWqD7XaE439vMT1U+navnMfgHRfPD4fyN4Tvoz12iis7xJremeHdEutZ1i7jtLK1jLyyucAAf1rzUm3ZGgeJNb0vw7otzrOs3kVpZWyF5ZZDgAD+Z9q/PL9pP436r8UNZaxs2ks/Dlq5+z24ODMf77+p9B2o/aU+N2p/FDXDZ2LS2fhy1ci3t84Mx/wCej+/oO1eNV9DgMAqS55/F+RhOd9EFFFABJwBkmvUMzqPh34y1Lwjq63FszSWshAntyeHHt719Z2EstzpVlqD2txbR3kCzxLPGUbawyODXK/slfs8nUpbXx144tGFkhElhp8q4849pHB/h9B3r608X+GLDxBpX2WRFiljX9xIowUPYfT2rGnnkMPWVJ6x6vt/XU+P4o4SjmtN4igrVV/5N5Pz7P7z56zRmrmvaVe6LqMljexMkiHg9mHqKoZr6uEozipRd0z8Rq0J0ZunUVmtGmTwTSQTJNC7JIhyrKcEGvZvhz41j1mJdP1GRUv0GFY8CX/69eJZqSCaWCVZYXZHU5VlOCDXDmGXU8bT5ZaPo+x7WQZ9iMlxHtKesX8UejX+fZn1FRXDfDbxtHrUKadqDqmoIuAx4EoHf613NfnWKwtTC1HTqKzR/QGW5lh8yw8cRh3eL+9Ps/MKr6heW1hZyXd3KsUUYyzGjUby20+zku7yZYoY13MzGvDPHvi+48RXpjiZorCM/u4/73+0feuvLMsqY6pZaRW7/AK6nlcScR0MloXetR/DH9X5D/Hni648Q3nlxlo7GM/u48/e9zXL7qZmjNfodDDwoU1TpqyR+AY7G18dXlXryvJ/19w/dVvSdRutMvo7yzlaOVDkY7+xqkDmvTPhn4HMxj1jV4v3Y+aCFh97/AGjWGPxNHDUXKrt27+R15JlWLzHFxp4XSS1v/L53PQ/C+oXGqaJb3t1bNbyyLkoe/v8AQ1p0AAAAAADoBRX5nUkpSbirLsf0lh6c6dKMJy5mkrvv5hRRRUGwUUUUAFFFFABRRRQAV4d+038CdO+JWkyavo8cdp4mtkzHIBhbkD+B/f0Ne40VpSqypSUovUTV9GfkTruk6joer3Ok6taS2d7ayGOaGVdrKRVKv0T/AGnfgXp/xK0h9Y0iOO18TWqZikAwLkD+B/6Gvz51zStQ0TVbjS9UtZbW8tnKSxSLgqRX1GExccRG636o55RcSlWp4V1/VvDGvWut6JeSWl9bOGjkQ4/A+oPpWXRXU0mrMk/RP4LftDeFvF3ge41HxDfW+lappkG+/idsBwP40HfJ7V8o/tJ/G/VPifrbWVk8tn4btn/0e2zgykfxv6n0HavGwSM4JGeuO9JXFRwFKlUc18vIpzbVgoooAJIAGSa7SQr6x/ZM/Z4k1J7Xxz44tClkMSWFhIuDL3Ejg/w+g70fsmfs8NqMtt448c2eLJCJLCwlX/WnqHcH+H0HevtFFVECIoVVGAAMACvFx+PtenTfqzWEOrEjRI41jjUIigBVAwAPSnUUV4ZsYXjLwzZeJNOaCcBLhQfJmA5U/wCFeBa/pV7ompSWF9GUkToccMOxHtX01WF4z8M2XiXTTBOAk6AmGYDlD/hXvZPnEsHL2dTWD/A+K4r4UhmsHXoK1Zf+TeT8+z+8+c80Zq5r2k3ui6jJY30ZSRTwezD1FUM1+gQlGcVKLumfiFWjOjN06is1umTwTSQTJNE7JIh3KynBBr2PwL8QrO701odbnSC5t0yZCcCUD+teK5pd1cWPy2ljoctTdbPqetkme4rJ6rqUHdPdPZ/8Mdb4/wDGFz4ivDFGxisIz+7j/ve5rls1HuozXTQw1PD01TpqyR5+OxlfHV5V68ryf9fcSZozTAa9P+GHgQzmPWdZhIjHzQQMPvf7R9qxxuMpYOk6lR/8E6MpyfEZriFQoL1fRLux/wAMvApmMesazFiP70EDfxf7R9vavWFAUAAAAcACgAAAAAAdBRX5xjsdVxtXnn8l2P3/ACXJcNlGHVGivV9W/wCugUUUVxHrhRRRQAUUUUAFFFFABRRRQAUUUUAFeH/tOfArT/iXpUmsaSsVp4mto/3UuMLcgDhH/oe1e4Vn+I9a0zw7otzrGsXkVpZWyF5ZZGwAB/WtaNSdOalDcTSa1PyZ1zStQ0TVrnStVtZLS8tnMcsUgwVIqlXp/wC0l8S7T4nePn1aw0q3srO3XyYJBGBNOoPDSHv7DtXmFfXU5SlBOSszlYUUUVYAAScDk19Zfsmfs7vqLW3jjx1ZFLMESafYSjmXuJHHZfQd6+VtLvJtO1K2v7cRtLbyrKgkQOpKnIyp4I46Gv0b/Zv+NOjfFDw+lrIIrDX7RAtzZ8AMMffj9V9u1efmVSrCn7m3Vl00m9T16NEjjWONVRFGFUDAA9KWiivmToCiiigAooooAwfGnhiy8S6cYJwEuEH7mYDlT/hXz7r+k32h6lJYahFskQ8Hsw9QfSvpjUr2106ykvLyZYYYxlmY18+/EXxa/ijU1aOMRWkGRCCBuPuT/Svr+GK2KcnTSvT/ACfl/kfmPiBhMvUI1m7Vn0XVefp0fy9Oa3UbqZmjNfa2PynlJM+9AOajzTo5GjkV0YqynIPoaVg5T1P4XeA/P8vWdaiIj+9BAw+9/tH29q9dAAAAAAHQVwPwx8dQ63Ammai6R6hGuFJ4Ew9vf2rvq/Ms5qYmeJaxGjWy6W8j+gOFcPl9LAReBd0931b8+3oFFFFeSfSBRRRQAUUUUAFFFFABRRRQAUUUUAFFFZ3iTW9L8OaJdazrN5HaWNqheWWQ4AH+NNJt2QB4l1vTPDmiXWs6xdx2llaxl5ZHOAAO3ufavzx/aT+N2qfFDWzZWbSWfhy2ci3tg2DKf77+p9B2pf2lfjdqfxQ1trGxeW08N2z/AOj2+cGYj/lo/v6DtXjVfQ4DAKkuefxfkYTnfRBRRQAScAZNeoZhRXv3w2/Zh8V+Lfh7deJprgadcvHv02zlT5rgdcsf4Qe1eHa5pWoaJq1zpWq2ktpeW0hjlikXDKwrOFanUk4xd2htNFKtTwrr+reGNdtta0S8ltL22cPHIhx07H1HtWXRWjSasxH6S/s4/GrSfijoYtp3jtfENqg+1WpON4/vp6j27V69X5IeFfEGr+F9etdc0O9ks7+1cPHKh/QjuD3Ffoj+zl8bNI+KWhLbztFZ+IraMfa7TON+Osieqn07V85j8A6L54fD+RvCd9GevUUUV5hoFVtTvrXTbGW9vJligiXczNRqd9aabYy3t7MsMEQyzMa+ffiN42uvE96YoS0OmxH91F3b/ab3r1spympmFSy0it3+i8z57iDiCjlFG71qPZfq/Id8RPGl14lvTFEzRafGf3cf97/aNclmmZozX6Xh8NTw1NU6askfheNxdbG1pV68ryY/NGTTM16R4J+GVxrGkSX+pSSWfmJ/oq45J7MR6Vni8ZRwkOes7I1y7K8TmNX2WHjd7/0zzvJozV3xDpF7oepyWF/EUkQ8HHDD1FZ+feuiEozipRd0zjq0Z0puE1ZrdE0E8sEyTQu0ciHKspwQa9z+GHjuLXIU0zUpFTUEXCseBKB/WvBs1JBPLBMk0LmORCGVlOCDXn5lllLH0uWWjWz7HsZFnlfJ6/tKesXuu6/z7M+tKK4D4X+PItdhTTNSdY9SQYVicCYDuPf2rv6/M8XhKuEqulVVmj92y7MaGYUFXoO6f4Ps/MKKKK5juCiiigAooooAKKKKACiig9KAM7xLrmleG9EudZ1q8jtLG2QvLK5wAPQep9q/PH9pP43ap8T9beyspJbTw3bSH7NbZx5pH8b+p9u1bH7YPxL8XeJPG114V1G0udH0jT5SIrNuDOR0kbs2e3pXgdfRZfgVTSqT3/IwnO+iCiigAkgAZJr1DMK+s/2TP2d31Brbxz46tNtmMSafp8i8y9/MkB6L0wO9J+yb+zwdSe28b+ObLFmpEljYSr/rT1DuP7voO9faCKqIERQqqMAAYAFeLj8fa9Om/VmsIdWEaJGixooVFGFUDAA9K8Q/ac+BWnfErSZNY0mOO08T2yZilAwtyAPuP/Q9q9worx6VWVKSlF6mrSasfkTrmlahomrXOlaray2l7bSGOaKRcMrCqVfon+098C7D4l6U+s6Skdr4mtY/3UmMC5UdI29/Q1+fOt6XqGi6rcaVqlrJa3ls5SWKQYKkV9RhMXHERut+qOeUeUpVqeFfEGreGNdttb0W7ktb22cNG6HH4H1FZdFdTSasyT9Jf2cPjVpXxR0Fbe4eK18Q2qD7Va7sbx/z0T1H8q9V1O+tdNsZb29mWGCJdzMxr8ovAOoeIdK8W2GoeF5podVhlDQtEefcH2PevsbxP4417xTp1jDq3lQGKFPOigJ2NLj5m59849K4KHD0sTX9x2h18vJHj55xDSyqhd61Hsv1fkaXxG8bXXie9MURaLTo2/dR5+9/tH3rkM1HmjNffYfC08NTVOmrJH4ljMXWxtaVau7yZJmgHmmAmvWfhN8PTceVrmuQkRDDW9uw+9/tN7Vjj8dSwNJ1ar9F3OjK8pr5nXVGivV9Eu7H/Cf4emcx63rkJEfDW9u4+9/tMPT2r2RQFAVQABwAKAAAAAAB0Aor8uzDMKuOq+0qfJdj9zyjKMPlVBUaK9X1bOf8b+FbHxRppt7gCO4UfuZwOUP9R7V86+IdHv8AQtTk0/UIikqHg9mHqD6V9VVz3jnwrY+KNMNvcKEuEBME2OUP+FenkmdywUvZVdab/A8PijheGZw9vQVqq/8AJvJ+fZnzLuo3Ve8Q6Pf6FqclhqERjkQ8Hsw9Qazs1+jwlGpFSi7pn4xVozpTcJqzW6J7eeSCZJoZGjkQhlZTgg17t8LvHsWuQppmpOseooMKxPEw/wAa8DzV3Q7fULvVIIdLWQ3ZcGMx8EH1z2rzs1y2jjaLVTRrZ9v+AezkGcYnK8SpUVzKWjj3/wCD2PrCiqOgx38Oj20eqTJNeLGBK6jAJq9X5VOPLJq9z98pyc4KTVr9H0CiiipLCiiigAooooAKKKKAPK/2hfg3o/xT8PFdsVprlupNnebec/3W9VNfnR4y8Naz4R8RXWg69ZvaXts5V1YcEdmB7g9jX6115V+0P8GtF+Knh05SO0161UmzvQuD/uP6qf0r08DjnRfJP4fyM5wvqj80RycCvrP9kz9ndtRNr458dWTLaAiTT9PlXBl9JJB/d7gd+tXv2bv2Y7yz19vEHxFs1VbKYi1sCQwlZTw7f7PcDvX2CiLGioihVUYAAwAK6cfmGns6T9WTCHVhGiRoqRqFRRgKBgAUtFFeGbBRRRQAV4h+038CtP8AiZpTatpCQ2fia2jPlS4wtyo52P8A0Pavb6K0pVZUpKUXqJq+jPyJ1zStQ0TVrnStVtJbS9tnMcsUgwVIqPS7C61O+isrKFpZ5W2qor9AP2r/AIM6J448OzeJLV7fTtesoyRO3yrcqP4H9/Q14F8OvBlp4XsvMkCTajKP3suM7f8AZX0H86+1yiDzFcy0S3Pms+zqllNLXWb2X6vyH/DnwZaeF7EPIEm1CUDzZcfd/wBke1dfmo80ua+0pUY0oqMVofjWLxNXF1XWrO8mSZozUea9N+B/hTTdau5NUv5opvsrjbak8k9mYelc+OxcMHQlWqbI1y3LqmYYmOHpbvuafwj+HhnMWva5DiMENb27D73ozD09q9oAAAAAAHQCkUBVCqAAOABS1+U5jmNXH1XUqfJdj9yyjKKGV0FRor1fVsKKKK4D1AooooA57xz4UsPFOmG3uFEdwgJgnA5Q/wBR7V84eI9Gv9A1SXT9RhMcqHg/wuOxB7ivrCud8d+E7DxTpZt51CXKDMEwHKn/AAr6LI88lgpeyq603+Hmv1Pj+J+GIZnB16KtVX/k3k/Psz5p0uxu9Tv4rGxheaeVtqIoyTX0T8OPBNp4XsRJKFm1GQfvZf7v+yvtR8OfBFn4UtDIxW41CUfvJsdB/dX0FdfWue568W3RoP3Pz/4BhwvwtHL0sTiVeq9l/L/wQooor5g+3CiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKrarf2ml2E19fTpBbwrud2OAKTVdQtNLsJb6+mWGCJcszGvm34nePLzxXfmGEtDpkTfuos/f/wBpvevZyfJ6uZVbLSC3f6LzPBz3PaOVUbvWb2X6vyH/ABM8d3fiq/MULPDpsR/dRdN3+03vXF5pm6jdX6phsLTw1JUqSskfjGLxVbGVnWrO8mSZ96M0wGnSq8UhjkRkdeCrDBFb2OXlFzWn4b1y/wBA1SPUNPmMciHkdmHoR6Vk7hS596ipTjUi4zV0y6c50pqcHZrZn1X4C8W2HizShc27BLmMATwZ5Q/4V0dfIfhvXL/w/qseo6dMY5U6js47gj0r6Y8BeLtP8WaUtzbER3KAefATyh/qPevzPPshlgJe1pa03+Hk/wBGfr/DfEkcygqNbSqv/JvNefdHSUUUV80fWhRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFVtVv7TS7CW+vp1ht4l3O7HpSatqNnpWny319OsMES7mZjXzP8UfH154tv8AyYWeDS4WPlQ5xvP95vU/yr2smyarmVWy0gt3+i8zws8zylldK71m9l+r8h/xP8eXfiy/MUJaHTIm/cxZ5b/ab3ris0zNGa/V8NhaWFpKlSVkj8bxeKrYuq61Z3kx+aX2pmTXsnwc+GrXBh8Qa/CViB3W9sw5b0Zh6e1YZhj6OAourVfourfY3y3LK+Y11Ror1fRLux3wc+GxuPK1/X4SIgQ1tbuPvf7TD09BXT/Fv4dQ6/bPqukxpFqca5KgYE4Hb6+9ekKAqhVAAHAApa/L62fYupi1ilKzWy6W7f5n63R4bwVPBPBuN0931v3/AMj4wuIZred4J42jlQlWVhgg0zNfRHxc+HUXiCB9W0mNI9TRcso4EwH9a+eLiKW2neCeNo5UO1kYYIPpX6TlOa0cypc8NJLddv8AgH5XnOS1srrck9YvZ9/+CJmtPw1rl/4f1WLUdPmMcqHkZ4Yeh9qys0Zr0qlONSLhNXTPKpznSmpwdmtmfWHgDxfp/i3SVubZhHcoAJ4CfmQ/1HvXSV8feGdd1Dw9q0WpabMY5UPIz8rr3UjuK+nPAHjDT/FulLcW7CO6QYngJ5Q/1FfmGfZBLAS9rS1pv8PJ/oz9c4c4jjmMFRraVV/5N5rz7o6WiiivmT6wKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAOY+JXhRfFvh5rAXDwTod8LA/KW9GHcV8s65pV/oupzadqNu0FxC2GVu/uPUV9m1x/xM8DWHi/TD8qw6jEP3E4HP+6fUV9Tw7n7wEvY1v4b/AAf+Xc+S4k4eWYR9vR/iL8V29ex8q5o+gq9ruk32i6nLp2oQNFPG2CCOvuPUV6v8Gvhk1w0PiDxDBiH71tbOPvejMPT2r9Cx2Z4fB4f283o9rdfQ/OMBlWIxuI+rwjZre/T1F+DPw0NwYfEPiCDEQ+a2tnH3vRmHp6Cvc1AVQqgADgAUKoVQqgAAYAHalr8lzPMq2Y1nVqv0XRI/YsryuhltBUqS9X1bCiiivOPSCvNfi98OYvEVu+raTEseqRrllHAnHoff3r0qiuvBY2tgqyq0nZr8fJnHjsDRx1F0ayun+Hmj4ruIZbad4J42ilQlWRhgg1Hmvoz4vfDiLxDA+raRGseqRjLIOBOP8a8AsdI1K91hdIgtJDetJ5ZiK4Knvn0xX6zleb0Mwoe1Ts1uu3/A8z8dzbJK+XYj2TV0/hff/g+Q3SbC81XUIbCwgee4mYKiKOpr6a+F3ga28IaaWkYTajOo8+Tsv+yvtTPhd4DtPCWnCWULNqcq/vZcfd/2V9q7avh+IeIHjG6FB/u1u+//AAD73hrhuOBSxGIV6j2X8v8AwQooor5M+xCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxdd8LaHrd/a32pWKTT2rbo2Pf2PqK2VAVQqgAAYAHalorSVWc4qMm2lt5GcKNOEnKMUm9/MKKKKzNAooooAKKKKACs+HRdLh1iXV4rKFb6VQrzBfmIrQoqozlG/K7XJlCMrOSvYKKKKkoKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooA//2Q=="), contactLink = Just $ CLFull adminContactReq, peerType = Nothing, preferences = Nothing } simplexStatusContactProfile :: Profile simplexStatusContactProfile = Profile { displayName = "SimpleX Status", fullName = "", shortDescr = Just "Automatic server status and app release updates", image = Just (ImageData "data:image/jpg;base64,/9j/4AAQSkZJRgABAQAASABIAAD/4QBYRXhpZgAATU0AKgAAAAgAAgESAAMAAAABAAEAAIdpAAQAAAABAAAAJgAAAAAAA6ABAAMAAAABAAEAAKACAAQAAAABAAAAr6ADAAQAAAABAAAArwAAAAD/7QA4UGhvdG9zaG9wIDMuMAA4QklNBAQAAAAAAAA4QklNBCUAAAAAABDUHYzZjwCyBOmACZjs+EJ+/8AAEQgArwCvAwEiAAIRAQMRAf/EAB8AAAEFAQEBAQEBAAAAAAAAAAABAgMEBQYHCAkKC//EALUQAAIBAwMCBAMFBQQEAAABfQECAwAEEQUSITFBBhNRYQcicRQygZGhCCNCscEVUtHwJDNicoIJChYXGBkaJSYnKCkqNDU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6g4SFhoeIiYqSk5SVlpeYmZqio6Slpqeoqaqys7S1tre4ubrCw8TFxsfIycrS09TV1tfY2drh4uPk5ebn6Onq8fLz9PX29/j5+v/EAB8BAAMBAQEBAQEBAQEAAAAAAAABAgMEBQYHCAkKC//EALURAAIBAgQEAwQHBQQEAAECdwABAgMRBAUhMQYSQVEHYXETIjKBCBRCkaGxwQkjM1LwFWJy0QoWJDThJfEXGBkaJicoKSo1Njc4OTpDREVGR0hJSlNUVVZXWFlaY2RlZmdoaWpzdHV2d3h5eoKDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uLj5OXm5+jp6vLz9PX29/j5+v/bAEMAAQEBAQEBAgEBAgMCAgIDBAMDAwMEBgQEBAQEBgcGBgYGBgYHBwcHBwcHBwgICAgICAkJCQkJCwsLCwsLCwsLC//bAEMBAgICAwMDBQMDBQsIBggLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLC//dAAQAC//aAAwDAQACEQMRAD8A/v4ooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAP/Q/v4ooooAKKKKACiiigAoorE8R+ItF8J6Jc+IvEVwlrZ2iGSWWQ4CgVUISlJRirtmdatTo05VaslGMU223ZJLVtvokbdFfl3of/BRbS734rtpup2Ig8LSsIYrjnzkOcea3bafTqBX6cafqFjq1jFqemSrPbzqHjkQ5VlPIINetm2Q43LXD65T5eZXX+XquqPiuC/Efh/itYh5HiVUdGTjJWaflJJ6uEvsy2fqXKKKK8c+5Ciq17e2mnWkl/fyLDDCpd3c4VVHJJJr8c/2kf8Ago34q8M3mpTfByG3fT7CGSJZrlC3nStwJF5GFU8gd69LA5VicXTrVaMfdpxcpPokk397toj4LjvxKyLhGjRqZxValVkowhFc05O9m0tPdjfV7dN2kfq346+J3w9+GWlPrXxA1m00i1QZL3Uqxj8Mnn8K/Mj4tf8ABYD4DeEJ5dM+Gmn3niq4TIE0YEFtn/ffBI+imv51vHfxA8b/ABR1+bxT8RNUuNXvp3LtJcOWCk84VeigdgBXI18LXzupLSkrL72fzrxH9IXNsTKVPKKMaMOkpe/P8fdXpaXqfqvrf/BYH9p6+1w3+iafo1jZA8WrRPKSPeTcpz9BX1l8J/8Ags34PvxDp/xn8M3OmSnAe709hcQfUoSHA/A1/PtSE4/GuKGZ4mLvz39T4TL/ABe4swlZ1ljpTvvGaUo/dbT/ALdsf2rfCX9pT4HfHGzF18M/EdnqTYBaFXCzJn+9G2GH5V7nX8IOm6hqGkX8eraLcy2d3EcpPbuY5FPsykGv6gf+CWf7QPxB+OPwX1Ky+JF22pX3h69+yJdyf62WJlDrvPdlzjPevdwGae3l7OcbP8D+i/DTxm/1ixkcqx2H5K7TalF3jLlV2rPWLtqtWvM/T2iiivYP3c//0f7+KKKKACiiigAooooAK/Fv/goX8Qvi2fFcXgfWrRtP8NDEls0bZS7YfxORxlT0Xt1r9pK8u+L/AMI/Cfxp8F3HgvxbFujlGYpgB5kMg6Op9R+tfR8K5vQy3MYYnE01KK0843+0vNf8NZn5f4wcFZhxTwziMpy3FOjVeqSdo1Lf8u5u11GXk97Xuro/mBFyDX3t+yL+2Be/CW+h8B+OHafw7cyALIxJa0Ldx6p6jt1FfMvx/wDgR4w/Z+8YN4d8RoZrSbLWd4owk6D+TDuK8KF0K/pLFYHA51geWVp0pq6a/Brs1/wH2P8ALvJsz4h4D4h9tR5qGLoS5ZRls11jJbSjJferSi9mf1uafqFlqtlFqWmyrPBOoeORDlWU8gg069vrPTbSS/v5FhghUu7ucKqjqSa/CH9j79sm++EuoQ/D/wAeSNceHbmRVjlZstZk9x6p6jt2q3+15+2fffFS8n8AfD2V7bw9CxWWZThrwj+Se3evxB+G2Zf2n9TX8Lf2nTl/+S/u/PbU/v2P0nuGv9Vf7cf+9/D9Xv73tLd/+ffXn7afF7pqftbfth3nxUu5vAXgGR7fw/A5WWUHDXZX19E9B361+Z/xKm3eCL9R3UfzFbQul6Cn+I/A3ivxR8LPEXivSbVn07RoVkurg8Iu5gAue7HPSv1HOsrwmVcN4uhRSjBUp6vq3Fq7fVt/5I/gTNeI884x4kjmeYOVWtKSdop2hCPvWjFbQjFNv5ybbuz4Toqa0ge9uoLOIhWnkSNSxwAXIUEnsBnmv0+/aK/4Jg+O/gj8Hoviz4b1n/hJFt40l1G2ig2NDG4yZEIJ3KvfgHHNfxVTw9SpGUoK6W5+xZVw1mWZYfEYrA0XOFBKU2raJ31te72b0T0R+XRIAyegr+gr/glx+yZoHhjwBc/tKfFywiafUY2OmpeIGS3sVGWmIbgF+TkjhR71+YP7DX7Lt9+1H8ZLfR75WTw5pBS61ScDKsoIKwg+snf0Ffqd/wAFSv2o4Phf4Ltv2WvhmVtrjUbRBfvA2Ps1kOFhAHQyAc9ML9a9HL6UacHi6q0W3mz9Q8M8owuV4KvxpnEL0aN40Yv/AJeVXpp5LZPo7v7J+M/7U/jX4e/EL4/+JfFXwrsI9P0Ke5K26RKESTZw0oUcAOeQBX7J/wDBFU5+HPjYf9RWH/0SK/nqACgKOgr+hT/giouPh143b11SH/0SKWVzc8YpPrf8jHwexk8XxzSxVRJSn7WTSVknKMnoui7H7a0UUV9cf3Mf/9L+/iiiigAoorzX4wfGD4afAP4bav8AF74v6xbaD4d0K3e6vb26cJHHGgyevUnoAOSeBTjFyajFXYHpVFf55Xxt/wCDu34nj9vzS/G3wX0Qz/ArQ2ksLnSp1CXurQyMA15uPMTqBmJD2+914/uU/Y//AGxfgH+3P8ENL+P37OutxazoWpoNwHyzW02PmhmjPKSKeCD9RxXqY/JcXg4QqV4WUvw8n2ZnCrGTaTPqGiiivKNDy/4u/CLwd8afBtx4N8ZW4kilBMUoH7yGTs6HsR+tfzjftA/AXxl+z54yfw34jQzWkuXs7xF/dzR/0YdxX9OPiDxBofhPQ7vxN4mu4rDT7CF57m4ncJHFFGMszMcAAAZJNf53n/Bav/g5W1H4ufGjTvg5+xB5F14E8JX4l1HVriIE6xNE2GjhLDKQdRuGC55HHX9L8Os+x2ExP1eKcsO/iX8vmvPy6/ifg3jZ4NYDjDBPFUEqeYU17k/50vsT8n0lvF+V0fq0LhTUgnA4r4y/ZG/bJ+FX7YXw9HjDwBP5N/ahV1LTZeJrSUjoR3U/wsOK+sRdL/n/APXX9G0nCrBTpu6Z/mVmuSYvLcXUwOPpOnWg7SjJWaf9ap7NarQ+pf2dP2evGH7Q3i4aLogNvp1uQ15esMpEnoPVj2Ffrd+1V8GvDnw5/YU8X+APh/Z7IrewEjYGXlZGUs7nqSQM18C/sO/ti6b8F7o/Dnx6qpoN9LvS6RRvglbjL45ZT69vpX7wX1poHjjwxNYzbL3TdUt2jbaQySRSrg4PoQa/nnxXxGaTxLwmIjy4e3uW2lpu33Xbp87v+7Po58I8L4nhfFVMuqKeY1oTp1nJe9S5k0oxWtoPfmXxve1uVfwqKA0YHYiv6Ev+CZ37bVv490eP9mb4zXAn1GKJo9Murg5F3bgYMLk9XUcD+8tflR+1/wDsn+Nv2XfiNdadqFs8vh28md9Mv1GY3iJyEY9nXoQa+UrC/v8ASr+DVdJnktbq2dZYZomKvG6nIZSOhFfztQrVMJW1Xqu5+Z8PZ5mvBWeSc4NSg+WrTeinHqv1jL56ptP+s7xHZ/A//gnR8EfE/jTwra+RHqF5JdxWpbLTXcwwkSnrsGPwXNfyrfEDx54l+J/jXU/iB4wna51LVZ3nmdj3Y8KPQKOAPQV2vxX/AGhvjT8corC3+K2vz6vFpq7beNgERT3YqvBY92NeNVeOxirNRpq0Fsju8RePKWfTo4TLqPscFRXuU9F7z+KTSuvJK7srvqwr+ir/AIIuaVd2/wAH/FesSIRDd6uFjb+8Y41Dfka/BX4YfCzx78ZfGVr4C+G+nyajqV22Aqj5I17u7dFUdya/r+/ZV+Aenfs2fBLSPhbZyC4ntVaW7nAx5tzKd0jfTJwPYV1ZLQk63tbaI+w8AOHcXiM8ebcjVClGS5ujlJWUV3sm27baX3R9FUUUV9Uf2gf/0/7+KKKKACv4If8Ag8QT9vN9W8IsVk/4Z+WJedOL7f7Xyd32/HGNu3yc/LnPev73q84+Lnwj+G/x3+HGr/CT4uaRba74d123e1vbK6QPHJG4weD0I6gjkHkV6WUY9YLFQxDgpJdP8vMipDmi0f4W1frt/wAEhP8Agrt8af8AglD8b38V+Fo21zwPr7xp4i0B3KpcRoeJoTyEnjBO04+boeK+m/8AguZ/wQz+I3/BMD4kyfEn4Ww3fiD4Oa5KzWWolC76XKx4tbphwOuI3PDAc81/PdX7LCeFzHC3VpU5f18mjympU5eZ/t9fsk/tb/Av9tv4G6N+0F+z3rUWs6BrEQYFCPNt5cfPDMnVJEPDKf5V794h8Q6F4T0O78TeJ7uGw06wiae4uZ3EcUUaDLMzHAAA6k1/j9f8EiP+Cunxv/4JTfHAeKPCZfWfAuuyRx+IvD8jkRTxg486Lsk8YJ2n+Loa/V7/AILy/wDBxZd/t2eHl/Zc/Y6mu9I+Gl1DDNrWoSBoLvUpGAY2+OqQoeH/AL5GOlfneI4OxCxio0taT+12Xn59u53xxMeW73ND/g4M/wCDgzVP2yNV1H9jz9j3UZrD4ZWE7waxrEDlH110ONiEYItgQe/7z6V/I6AAMDgCgAKNo6Cv0j/4Jkf8Ex/j/wD8FOvj/Y/Cj4UWE9voFvNGdf18xk2um2pPzEt0MhGdiZyTX6FhsNhctwvLH3YR1bfXzfn/AEjhlKVSR77/AMEMf2Rf2v8A9qr9tPRrb9mNpdL0fSp438UaxKjNYW+nk/PHKOA7uoIjTrnniv7Lfj98CvG37PPjiXwj4uiLxNl7S7UYjuIuzD39R1Ffvt+wn+wd+z5/wTy+A+n/AAF/Z70pbKyt1V728cA3V/c4w0079WYnoOijgV7V8cPgb4G+Pngqfwb41twwYEwXCgebBJ2ZT/MdDXi5N4mTwmYWqRvhXpb7S/vL9V28z8c8YfBXC8XYL61hbQx9Ne7LpNfyT8v5ZfZfkfyXi5r9Lf2Jv24bn4S3UHwz+JkzT+HZ5AsNy5LNZlu3vHn8q+KPj38CPHf7PPjabwn4yt2ELMxtLsD91cRg8Mp6Z9R2rxAXAPANfuePyzL89y/2c7TpTV1JdOzT6Nf8Bn8C5FnGfcEZ79Yw96OJpPlnCS0a6xkusX/k4u9mf2IeK/B/w++Mngt9C8U2ltrWi6lEGCuA6OrDhlPY+hHNfztftw/8E4tN+AGlTfE34ba3HJo0koVdMvGC3CFv4Ym/5aAenBArvf2PP2+9R+CGmv4B+JSy6joEUbtaOp3TQOBkRj1Rjx7V8uftEftH+Nf2i/G7+KPEzmG0hyllZqT5cEef1Y9zX4LT8GMTisynhsY7UI6qot5J7Jefe+i87o/prxI8YuEM/wCF6WM+rc2ZSXKo6qVJrdykvih/Ktebsmnb4DkilicxyqVYdQRzXUaN4R1HVMSzjyIf7zDk/QV6dIlpJIJ5Y1Z16MRk1+qf7DX7Ed58ULmH4p/Fe2kt/D8Dq9paSDabwjncf+mf/oX0rKXg3lOR+0zDPMW6lCL92EVyufZN3vfyjbvdI/AeFsJnHFOPp5TktD97L4pP4YLrJu2iXnq3ok20es/8Erv2f/G/gf8AtD4ozj7Bo2pwiFIpY/3t2VOQ4J5VFzx659q/aKq9paWthax2VlGsUMShERBtVVHAAA6AVYr4LNcdTxWIdSjRjSpqyjGKslFber7t6tn+k3APB1LhjJaOUUqsqjjdylJ/FKTvJpfZV9orbzd2yiiivNPsj//U/v4ooooAKKKKAPO/iz8Jvh18c/h1q/wm+LGk2+ueHtdt3tb2yukDxyxuMEEHoR1B6g81/lm/8Fy/+CFfxG/4Jh/ENvid8J4bzxF8Htdmke1vliaRtHctxbXTAEBecRyHAbGDzX+q54j8R6B4Q0C88U+KbyHT9N0+F7i5ubhxHFFFGMszMcAADqa/zM/+Dhb/AIL06p+3f4rvP2Tf2Xr6S0+Eui3DR397GcHXriM8N7W6EfIP4jz6V9fwfPGLFctD+H9q+3/D9jmxKjy+9ufyq0UAY4or9ZPMP0v/AOCX3/BLf9oT/gqP8d4Phf8ACa0lsvDtjLG3iDxDJGTa6bbse56NKwB8uPOSfav9ZX9hD9hT4Df8E8v2fdK/Z7+AenLbWNkoe8vHUfab+6I+eeZhyWY9B0UcCv8AKC/4JUf8FV/j1/wSu+PCfEf4aSHUvC+rPHH4i0CViIL63U43D+7MgJKN+B4r/Wd/Yy/bM+BH7eHwH0j9oL9n7Vo9S0fU4182LI8+0nx88MydVdTxz16ivzbjZ43nipfwOlu/n59uh6GE5Labn1ZRRRXwB2Hi3x3+BPgj9oHwJceCPGcIIYFre4UfvYJezKf5jvX8vH7QvwB8d/s4eOZfB/jKEtDIS9neKP3VxFngqfX1Hav6gvj58e/An7PHgK48ceN7gLtBW2twf3txL2RR/M9hX8rX7Qn7Rnjz9o3x5L418ZyhUXKWlqh/dW8WeFUevqe5r988G4Zu3Ut/ueu/839z/wBu6fM/jj6UdPhlwo8y/wCFTS3Lb+H/ANPf/bPtf9unlQuAec077SPWueFznrTxc1+/eyP4udE/XX9g79h24+K8tv8AF74qQvD4fgkDWdo64N4V53H/AKZg/wDfX0r+ge0tLWwtY7KyjWKGJQiIgwqqOAAOwFfzc/sIft2XnwO1KH4ZfEeVp/Ct5L8k7Es9k7YHH/TMnkjt1r+kDTNT07WtOg1fSJ0ubW5QSRSxncjowyCCOoNfyr4q0s3jmreYfwtfZW+Hl/8Akv5r6/Kx/or9HSXDX+rqhkqtidPb81vac/d/3P5Lab/auXqKKK/Lz+gwooooA//V/v4ooooAKxfEniTQPB2gXnirxVew6dpunQvcXV1cOI4oYoxlndjgAADJJrar/PV/4Ozf+CiX7Xlr8Yrf9hCx0u98GfDaS0iv5L1GZT4iZs5HmKceTERgx9d3LcYr08py2eOxMaEXbu/L9SKk1CN2fIX/AAcD/wDBfrXv27vFF1+yx+ylqFzpnwl0id476+icxSa/MhwGOMEWykHYv8fU9hX8qoAAwOAKUAAYFfqj/wAEnf8AglH8cv8Agqp8ek+Hvw/R9M8I6NJFJ4k19lzHZW7k/ImeGmcAhF/E8V+xUKGFyzC2Xuwju/1fds8tuVSXmM/4JQ/8Epfjr/wVU+Pcfw5+HiPpXhPSXjl8ReIZEJhsoGP3E7PO4B2J+J4r7o/4Li/8EC/H3/BL/UYPjH8Hp7vxV8JNQMcL3sy7rnTLkgDbcFRjZI3KPwATg9q/0rP2MP2MPgL+wZ8BdI/Z5/Z60hNM0bS4x5kpANxeTn7887gAvI55JPToOK9y+J/ww8AfGfwBqvwu+KOlW+t6Brdu9re2V0gkilicYIIP6HqDXwVbjSu8YqlNfulpy9139e3Y7VhY8tnuf4VdfqD/AMErP+Cpvx1/4Jb/ALQNn8S/h7cS6j4VvpUj8QeH2kIt723zgsB0WVRyjetffn/BeH/ghJ4x/wCCZvjlvjP8EYbvXPg5rk7GKcqZJdGmc5FvOwH+rOcRyH0wea/nCr9ApVcNmOGuvehL+vk0cLUqcvM/24v2Mf20PgH+3l8CdK/aA/Z61iPVNI1FF86LI+0Wc+PnhnTqjqeOevUcV3nx/wD2gfh/+zp4CuPHHjq5CBQVtrZT+9uJeyIP5noBX+Ud/wAEL/25f2t/2NP2u7A/s7xPrPhzW5Yk8T6LOzCyls1PzTE9I5UXJRupPHIr+p39o79pXx/+0v8AEGbxv42l2RrlLO0QnyreLPCqPX1PUmvM4b8KauYZg5VJWwkdW/tP+6vPu+i8z8r8VvF3D8L4P6vhbTx017sekF/PL/21fafkjV/aF/aN8e/tHePZ/GvjOc+XuK2lopPlW8WeFUevqe9eFfasDmsL7UB1r9kv+Cen/BPuX4mPa/Gv41Wrw6HE4k0/T5FwbsjkO4PPl56D+L6V/QWbZjlnDmW+1q2hSgrRit2+kYrq/wDh2fw9kXDmdcZ526NK9SvUfNOctorrKT6JdF6JIh/Yq/4JyXXxq8MSfEn4wtPpukXkLLp1vH8s0hYcTHPRR1Ud6+KP2nP2bvHX7MXj+Twl4pUz2U+Xsb5QRHcRZ/Rh/Etf2D2trbWNtHZ2caxRRKEREGFVRwAAOgFeSfHL4G+Af2gvAVz4A8f2wmt5huimUDzYJB0dD2I/Wv5/yrxgx0c3niMcr4abtyL7C6OPdrr/ADeWlv604g+jdlFTh6ngsrfLjaauqj/5eS6xn2i/s2+Hz1v/ABi+d3r9O/2DP28r/wCBGpRfDT4lSvdeFL2UBJmYs9izcZX1j7kduor48/ah/Zr8bfsu/EWTwZ4pHn2c4MtheqMJcQ5IB9mHRhXzd9oAFf0Djsuy3iHLeSdqlGorpr8Gn0a/4DW6P5DyrMc74Mzz2tG9LE0XaUXs11jJdYv/ACaezP7pdK1bTNd02DWdGnS6tLlBJFLEwZHRuQQR1FaFfix/wSG1n47X3hPVLHXUL+BoT/oEtxneLjPzLD6pjr2B6d6/aev424nyP+yMyrZf7RT5Huvv17NdV0Z/pTwPxP8A6w5Lh82dGVJ1FrGXdaNp9YveL6oKKKK8A+sP/9b+/iiiigAr4E/4KI/8E4f2b/8AgpZ8DLr4M/H7SklljV5NJ1aJQLzTblhxLC/Uc43L0YcGvvuitKNadKaqU3aS2Ymk1Zn+Vt8Nf+DZH9vDxJ/wUEn/AGQfGti+m+DdMkF5eeNlTNjLpRb5Xgz964cfL5XVWyTx1/0lv2L/ANif9nv9gn4H6b8Bv2dNDh0jSrFF8+YKDcXs4GGmuJOskjHPJ6dBxX1lgZz3pa9bNc+xWPjGFV2iui6vu/60M6dKMNgooorxTU4T4m/DHwB8ZfAeqfDH4paRba7oGtQPbXtjeRiWGaJxghlII/wr/M//AOCw/wDwbq/En9kb9o7Ttc/ZhQ6h8KvGl4VgknkUyaJIxy0UmTueMDmNgCexr/SN/aA/aA+Hf7N3w6u/iL8RbtYYIFIggBHm3Ev8Mca9yfyA5NfyB/tTftZfEX9qv4gSeL/GEv2exgLJYWEZPlW8WeOO7H+Ju9fsXhRwnmOZYl4hNwwi+Jv7T/lj5930Xnofj3iv4nYThrCPD0bTxs17kekV/PPy7L7T8rn58fs1fs1/Df8AZg8Dp4U8CwB7qYK19fuAZrmQDkseyjsvQV9GfaWrAWcjvUnnt6mv62w+Cp0KapUo2itkfwFmOLxWPxNTGYyo51Zu8pN6t/1stktEftx/wTa/YHsfi6sHx2+L8aT6BFJnT7DcGFy6dWlAzhQf4T171/SBaWltY20dlZRrFDEoREQYVVHAAA6AV/Hv+xJ+3N4y/ZO8Wi0ui+oeE9QkX7dYk5KdjLFzw49Ohr+tj4c/Efwb8WPB1l498A30eoaZqEYkiljOevVWHZh0IPIr+TPGXLs6p5p9Zxz5sO9KbXwxX8rXSXd/a3Wmi/t76P8AmHD08l+qZZDkxUdaydueT/mT0vDsl8Oz1d33FFFFfjR/QB4x8dPgN8O/2hvA1x4F+Idms8MgJhmAxLbydnjbqCP1r8RPg3/wSV8Z/wDC9r7T/izMreDNIlEkM8TYfUVPKpgcoAPv+/Ar+iKivrsh43zbKMLWweCq2hUXXXlf80eza0/HdJnwPFHhpkHEGOw+YZlQ5qlJ7rTnXSM/5op6/hs2jD8NeGdA8HaHbeGvC9nFYWFmgjhghUIiKOwArcoor5Oc5Tk5Sd292fd06cacVCCtFaJLZLsgoooqSz//1/7+KKKKACiiigAooooAK8J/aK/aG+H37M/wzvPiX8QrgRwwDbb26kebczH7saDuSep7DmvdW3bTt69s1/Hj/wAFS9c/acu/2hbiw+Psf2fTYWf+w47bd9ha2zw0ZPWQj7+eQfav0Dw44PpcRZssLXqqFOK5pK9pSS6RXfu+i1PzvxN4zrcN5PLF4ei51JPli7XjFv7U327Lq9Dwr9qv9rn4lftZ+Pv+Ev8AG8i29na7ksNPiJ8m2iJ7Ak5Y/wATHrXy/wDacDJNYfn45PFftR/wTX/4Ju6j8aryz+OXxttpLXwtbSrJY2Mi7W1Bl53MD0hB/wC+vpX9jZpmGU8LZT7WolTo01aMVu30jFdW/wDNvqz+HcryTOeLs4dODdSvUd5Tlsl1lJ9Eui9Elsix/wAE8/8Agmpc/Hq3HxZ+OcFxY+F8f6Daj93Jen++eMiMdum76V88ft4fsM+LP2RvGH9p6MJtS8G6gxNnfMMmFj/yxmIAAYfwnuPev7DbGxs9Ms4tP0+JYIIFCRxoNqqq8AADoBXL+P8AwB4R+KHhG+8C+OrGPUNM1CMxTQyjIIPcehHUEdDX8x4PxqzWOdvH11fDS0dJbKPRp/zrdvrtta39V47wCyWeQRy7D6YqOqrPeUuqkv5Hsl9ndXd7/wACwuGHevvT9iL9u7x1+yP4n+wMDqXhPUJVN/YMTlOxlh/uuB+BqH9vD9hXxl+yD4v/ALS03zNT8HajIfsV8VyYSf8AljNjgMOx/iHvX59C6bHav6fjDKeJsqurVcPVX9ecZRfzTP5LdLOeE850vRxNJ/15SjJfJo/v3+GnxJ8HfF3wRp/xC8BXiX2l6lEJYZEPr1Vh2YdCDyDXd1/PD/wRa8KftJW8moeKfPNp8N7kMBBdKT9ouR/Hbgn5QP4m6Gv6Hq/iHjXh6lkmb1svoVlUjF6Nbq/2ZdOZdbfhsf6AcC8SVs9yahmWIoOlOS1T2dvtR68r3V/x3ZRRRXyh9eFFFFABRRRQB//Q/v4ooooAKKKKACiiigAr5u/aj/Zg+HX7VvwyuPh14+i2N/rLO8jA861mHR0Pp2YdCOK+kaK6sDjq+DxEMVhZuFSDumt00cmOwOHxuHnhcVBTpzVpJ7NM/nF/ZW/4I2eINL+MV9rH7Rk0Vz4d0G5H2GCA8anjlXfuiDjcvJJ46V/RfY2FlpdlFpumxJBbwII444wFVEUYAAHAAFW6K9/injHM+Ia8a+Y1L8qsorSK7tLu3q3+iSPn+E+C8q4dw86GW07czvJvWT7Jvstkv1bYUUUV8sfVnEfEb4c+Dvix4Mv/AAB49sY9Q0vUYjFNDIMjB7j0YdQRyDX4HeH/APgiNJB+0LKNe1vzvhzARcxBeLyUEn/R27ADu46jtmv6KKK+r4d42zjI6Vajl1ZxjUVmt7P+aN9pW0uv0R8lxJwNk2e1aFfMqCnKk7p7XX8srbxvrZ/qzn/CnhXw/wCCPDll4R8K2sdlp2nQrBbwRDCoiDAAFdBRRXy05ynJzm7t6tvqfVwhGEVCCsloktkgoooqSgooooAKKKKAP//R/v4ooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAP/Z"), contactLink = Just (either error CLFull $ strDecode "simplex:/contact/#/?v=1-2&smp=smp%3A%2F%2Fu2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU%3D%40smp4.simplex.im%2FShQuD-rPokbDvkyotKx5NwM8P3oUXHxA%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEA6fSx1k9zrOmF0BJpCaTarZvnZpMTAVQhd3RkDQ35KT0%253D%26srv%3Do5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"), peerType = Just CPTBot, preferences = Nothing } timeItToView :: String -> CM' a -> CM' a timeItToView s action = do t1 <- liftIO getCurrentTime a <- action t2 <- liftIO getCurrentTime let diff = diffToMilliseconds $ diffUTCTime t2 t1 toView' $ CEvtTimedAction s diff pure a epochStart :: UTCTime epochStart = UTCTime (fromGregorian 1970 1 1) (secondsToDiffTime 0)