{-# 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.Subscriber where

import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (lefts, partitionEithers, rights)
import Data.Foldable (foldr')
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (find)
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 Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as V4
import Data.Word (Word32)
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Delivery
import Simplex.Chat.Library.Internal
import Simplex.Chat.Messages
import Simplex.Chat.Messages.Batch (batchDeliveryTasks1)
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
import Simplex.Chat.Protocol
import Simplex.Chat.Store
import Simplex.Chat.Store.Connections
import Simplex.Chat.Store.ContactRequest
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Delivery
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.FileTransfer.Description (ValidFileDescription)
import qualified Simplex.FileTransfer.Description as FD
import Simplex.FileTransfer.Protocol (FilePartyI)
import qualified Simplex.FileTransfer.Transport as XFTP
import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId)
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Client (getAgentWorker, waitForWork, withWork_, withWorkItems)
import Simplex.Messaging.Agent.Env.SQLite (Worker (..))
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 (ProxyClientError (..), NetworkRequestMode (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), 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 (ErrorType (..), MsgFlags (..))
import qualified Simplex.Messaging.Protocol as SMP
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (TransportError (..))
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import qualified System.FilePath as FP
import Text.Read (readMaybe)
import UnliftIO.Concurrent (forkIO)
import UnliftIO.Directory
import UnliftIO.STM

smallGroupsRcptsMemLimit :: Int
smallGroupsRcptsMemLimit :: Int
smallGroupsRcptsMemLimit = Int
20

processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
processAgentMessage :: ByteString -> ByteString -> AEvent 'AEConn -> CM ()
processAgentMessage ByteString
_ ByteString
_ (DEL_RCVQS NonEmpty (ByteString, SMPServer, RecipientId, Maybe AgentErrorType)
delQs) =
  ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ NonEmpty DeletedRcvQueue -> ChatEvent
CEvtAgentRcvQueuesDeleted (NonEmpty DeletedRcvQueue -> ChatEvent)
-> NonEmpty DeletedRcvQueue -> ChatEvent
forall a b. (a -> b) -> a -> b
$ ((ByteString, SMPServer, RecipientId, Maybe AgentErrorType)
 -> DeletedRcvQueue)
-> NonEmpty
     (ByteString, SMPServer, RecipientId, Maybe AgentErrorType)
-> NonEmpty DeletedRcvQueue
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (ByteString, SMPServer, RecipientId, Maybe AgentErrorType)
-> DeletedRcvQueue
rcvQ NonEmpty (ByteString, SMPServer, RecipientId, Maybe AgentErrorType)
delQs
  where
    rcvQ :: (ByteString, SMPServer, RecipientId, Maybe AgentErrorType)
-> DeletedRcvQueue
rcvQ (ByteString
connId, SMPServer
server, RecipientId
rcvId, Maybe AgentErrorType
err_) = AgentConnId
-> SMPServer
-> AgentQueueId
-> Maybe AgentErrorType
-> DeletedRcvQueue
DeletedRcvQueue (ByteString -> AgentConnId
AgentConnId ByteString
connId) SMPServer
server (RecipientId -> AgentQueueId
AgentQueueId RecipientId
rcvId) Maybe AgentErrorType
err_
processAgentMessage ByteString
_ ByteString
_ (DEL_CONNS NonEmpty ByteString
connIds) =
  ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ NonEmpty AgentConnId -> ChatEvent
CEvtAgentConnsDeleted (NonEmpty AgentConnId -> ChatEvent)
-> NonEmpty AgentConnId -> ChatEvent
forall a b. (a -> b) -> a -> b
$ (ByteString -> AgentConnId)
-> NonEmpty ByteString -> NonEmpty AgentConnId
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map ByteString -> AgentConnId
AgentConnId NonEmpty ByteString
connIds
processAgentMessage ByteString
_ ByteString
"" (ERR AgentErrorType
e) =
  ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
e (ByteString -> AgentConnId
AgentConnId ByteString
"") Maybe ConnectionEntity
forall a. Maybe a
Nothing
processAgentMessage ByteString
corrId ByteString
connId AEvent 'AEConn
msg = do
  ChatLockEntity
lockEntity <- ByteString -> CM ChatLockEntity -> CM ChatLockEntity
forall a. ByteString -> CM a -> CM a
critical ByteString
connId ((Connection -> ExceptT StoreError IO ChatLockEntity)
-> CM ChatLockEntity
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (Connection -> AgentConnId -> ExceptT StoreError IO ChatLockEntity
`getChatLockEntity` ByteString -> AgentConnId
AgentConnId ByteString
connId))
  Text -> ChatLockEntity -> CM () -> CM ()
forall a. Text -> ChatLockEntity -> CM a -> CM a
withEntityLock Text
"processAgentMessage" ChatLockEntity
lockEntity (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
    VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
    -- getUserByAConnId never throws logical errors, only SEDBBusyError can be thrown here
    ByteString -> CM (Maybe User) -> CM (Maybe User)
forall a. ByteString -> CM a -> CM a
critical ByteString
connId ((Connection -> IO (Maybe User)) -> CM (Maybe User)
forall a. (Connection -> IO a) -> CM a
withStore' (Connection -> AgentConnId -> IO (Maybe User)
`getUserByAConnId` ByteString -> AgentConnId
AgentConnId ByteString
connId)) CM (Maybe User) -> (Maybe User -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just User
user -> VersionRangeChat
-> User -> ByteString -> ByteString -> AEvent 'AEConn -> CM ()
processAgentMessageConn VersionRangeChat
vr User
user ByteString
corrId ByteString
connId AEvent 'AEConn
msg CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> CM ()
eToView
      Maybe User
_ -> ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentConnId -> ChatErrorType
CENoConnectionUser (ByteString -> AgentConnId
AgentConnId ByteString
connId)

-- CRITICAL error will be shown to the user as alert with restart button in Android/desktop apps.
-- SEDBBusyError will only be thrown on IO exceptions or SQLError during DB queries,
-- e.g. when database is locked or busy for longer than 3s.
-- In this case there is no better mitigation than showing alert:
-- - without ACK the message delivery will be stuck,
-- - with ACK message will be lost, as it failed to be saved.
-- Full app restart is likely to resolve database condition and the message will be received and processed again.
critical :: ConnId -> CM a -> CM a
critical :: forall a. ByteString -> CM a -> CM a
critical ByteString
agentConnId CM a
a =
  CM a
a CM a -> (ChatError -> CM a) -> CM a
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \case
    ChatErrorStore SEDBBusyError {String
message :: String
message :: StoreError -> String
message} -> ChatError -> CM a
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> CM a) -> ChatError -> CM a
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent (Bool -> String -> AgentErrorType
CRITICAL Bool
True String
message) (ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) Maybe ConnectionEntity
forall a. Maybe a
Nothing
    ChatError
e -> ChatError -> CM a
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
e

processAgentMessageNoConn :: AEvent 'AENone -> CM ()
processAgentMessageNoConn :: AEvent 'AENone -> CM ()
processAgentMessageNoConn = \case
  CONNECT AProtocolType
p TransportHost
h -> ChatEvent -> CM ()
hostEvent (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ AProtocolType -> TransportHost -> ChatEvent
CEvtHostConnected AProtocolType
p TransportHost
h
  DISCONNECT AProtocolType
p TransportHost
h -> ChatEvent -> CM ()
hostEvent (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ AProtocolType -> TransportHost -> ChatEvent
CEvtHostDisconnected AProtocolType
p TransportHost
h
  DOWN SMPServer
srv [ByteString]
conns -> SMPServer -> SubscriptionStatus -> [ByteString] -> CM ()
serverEvent SMPServer
srv SubscriptionStatus
SSPending [ByteString]
conns
  UP SMPServer
srv [ByteString]
conns -> SMPServer -> SubscriptionStatus -> [ByteString] -> CM ()
serverEvent SMPServer
srv SubscriptionStatus
SSActive [ByteString]
conns
  AEvent 'AENone
SUSPENDED -> ChatEvent -> CM ()
toView ChatEvent
CEvtChatSuspended
  DEL_USER GroupMemberId
agentUserId -> ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> ChatEvent
CEvtAgentUserDeleted GroupMemberId
agentUserId
  ERRS NonEmpty (ByteString, AgentErrorType)
cErrs -> [(ByteString, AgentErrorType)] -> CM ()
errsEvent ([(ByteString, AgentErrorType)] -> CM ())
-> [(ByteString, AgentErrorType)] -> CM ()
forall a b. (a -> b) -> a -> b
$ NonEmpty (ByteString, AgentErrorType)
-> [(ByteString, AgentErrorType)]
forall a. NonEmpty a -> [a]
L.toList NonEmpty (ByteString, AgentErrorType)
cErrs
  where
    hostEvent :: ChatEvent -> CM ()
    hostEvent :: ChatEvent -> CM ()
hostEvent = ExceptT ChatError (ReaderT ChatController IO) Bool
-> CM () -> CM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((ChatController -> Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ChatController -> Bool)
 -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> (ChatController -> Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a b. (a -> b) -> a -> b
$ ChatConfig -> Bool
hostEvents (ChatConfig -> Bool)
-> (ChatController -> ChatConfig) -> ChatController -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config) (CM () -> CM ()) -> (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatEvent -> CM ()
toView
    serverEvent :: SMPServer -> SubscriptionStatus -> [ConnId] -> CM ()
    serverEvent :: SMPServer -> SubscriptionStatus -> [ByteString] -> CM ()
serverEvent SMPServer
srv SubscriptionStatus
nsStatus [ByteString]
conns = ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ SMPServer -> SubscriptionStatus -> [AgentConnId] -> ChatEvent
CEvtSubscriptionStatus SMPServer
srv SubscriptionStatus
nsStatus ([AgentConnId] -> ChatEvent) -> [AgentConnId] -> ChatEvent
forall a b. (a -> b) -> a -> b
$ (ByteString -> AgentConnId) -> [ByteString] -> [AgentConnId]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> AgentConnId
AgentConnId [ByteString]
conns
    errsEvent :: [(ConnId, AgentErrorType)] -> CM ()
    errsEvent :: [(ByteString, AgentErrorType)] -> CM ()
errsEvent = ChatEvent -> CM ()
toView (ChatEvent -> CM ())
-> ([(ByteString, AgentErrorType)] -> ChatEvent)
-> [(ByteString, AgentErrorType)]
-> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChatError] -> ChatEvent
CEvtChatErrors ([ChatError] -> ChatEvent)
-> ([(ByteString, AgentErrorType)] -> [ChatError])
-> [(ByteString, AgentErrorType)]
-> ChatEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, AgentErrorType) -> ChatError)
-> [(ByteString, AgentErrorType)] -> [ChatError]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
cId, AgentErrorType
e) -> AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
e (ByteString -> AgentConnId
AgentConnId ByteString
cId) Maybe ConnectionEntity
forall a. Maybe a
Nothing)

processAgentMsgSndFile :: ACorrId -> SndFileId -> AEvent 'AESndFile -> CM ()
processAgentMsgSndFile :: ByteString -> ByteString -> AEvent 'AESndFile -> CM ()
processAgentMsgSndFile ByteString
_corrId ByteString
aFileId AEvent 'AESndFile
msg = do
  (Maybe ChatRef
cRef_, GroupMemberId
fileId) <- (Connection
 -> ExceptT StoreError IO (Maybe ChatRef, GroupMemberId))
-> CM (Maybe ChatRef, GroupMemberId)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (Connection
-> AgentSndFileId
-> ExceptT StoreError IO (Maybe ChatRef, GroupMemberId)
`getXFTPSndFileDBIds` ByteString -> AgentSndFileId
AgentSndFileId ByteString
aFileId)
  Maybe ChatRef -> CM () -> CM ()
forall a. Maybe ChatRef -> CM a -> CM a
withEntityLock_ Maybe ChatRef
cRef_ (CM () -> CM ()) -> (CM () -> CM ()) -> CM () -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> GroupMemberId -> CM () -> CM ()
forall a. Text -> GroupMemberId -> CM a -> CM a
withFileLock Text
"processAgentMsgSndFile" GroupMemberId
fileId (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$
    (Connection -> IO (Maybe User)) -> CM (Maybe User)
forall a. (Connection -> IO a) -> CM a
withStore' (Connection -> AgentSndFileId -> IO (Maybe User)
`getUserByASndFileId` ByteString -> AgentSndFileId
AgentSndFileId ByteString
aFileId) CM (Maybe User) -> (Maybe User -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just User
user -> User -> GroupMemberId -> CM ()
process User
user GroupMemberId
fileId CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> CM ()
eToView
      Maybe User
_ -> do
        ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a. (AgentClient -> IO a) -> CM' a
withAgent' (AgentClient -> ByteString -> IO ()
`xftpDeleteSndFileInternal` ByteString
aFileId)
        ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentSndFileId -> ChatErrorType
CENoSndFileUser (AgentSndFileId -> ChatErrorType)
-> AgentSndFileId -> ChatErrorType
forall a b. (a -> b) -> a -> b
$ ByteString -> AgentSndFileId
AgentSndFileId ByteString
aFileId
  where
    withEntityLock_ :: Maybe ChatRef -> CM a -> CM a
    withEntityLock_ :: forall a. Maybe ChatRef -> CM a -> CM a
withEntityLock_ = \case
      Just (ChatRef ChatType
CTDirect GroupMemberId
contactId Maybe GroupChatScope
_) -> Text -> GroupMemberId -> CM a -> CM a
forall a. Text -> GroupMemberId -> CM a -> CM a
withContactLock Text
"processAgentMsgSndFile" GroupMemberId
contactId
      Just (ChatRef ChatType
CTGroup GroupMemberId
groupId Maybe GroupChatScope
_scope) -> Text -> GroupMemberId -> CM a -> CM a
forall a. Text -> GroupMemberId -> CM a -> CM a
withGroupLock Text
"processAgentMsgSndFile" GroupMemberId
groupId
      Maybe ChatRef
_ -> CM a -> CM a
forall a. a -> a
id
    process :: User -> FileTransferId -> CM ()
    process :: User -> GroupMemberId -> CM ()
process User
user GroupMemberId
fileId = do
      (ft :: FileTransferMeta
ft@FileTransferMeta {Maybe GroupMemberId
xftpRedirectFor :: Maybe GroupMemberId
xftpRedirectFor :: FileTransferMeta -> Maybe GroupMemberId
xftpRedirectFor, Bool
cancelled :: Bool
cancelled :: FileTransferMeta -> Bool
cancelled}, [SndFileTransfer]
sfts) <- (Connection
 -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer]))
-> CM (FileTransferMeta, [SndFileTransfer])
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection
  -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer]))
 -> CM (FileTransferMeta, [SndFileTransfer]))
-> (Connection
    -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer]))
-> CM (FileTransferMeta, [SndFileTransfer])
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupMemberId
-> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer])
getSndFileTransfer Connection
db User
user GroupMemberId
fileId
      VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cancelled (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ case AEvent 'AESndFile
msg of
        SFPROG GroupMemberId
sndProgress GroupMemberId
sndTotal -> do
          let status :: CIFileStatus 'MDSnd
status = CIFSSndTransfer {GroupMemberId
sndProgress :: GroupMemberId
sndProgress :: GroupMemberId
sndProgress, GroupMemberId
sndTotal :: GroupMemberId
sndTotal :: GroupMemberId
sndTotal}
          Maybe AChatItem
ci <- (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe AChatItem))
 -> CM (Maybe AChatItem))
-> (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
            IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> User -> GroupMemberId -> CIFileStatus 'MDSnd -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> GroupMemberId -> CIFileStatus d -> IO ()
updateCIFileStatus Connection
db User
user GroupMemberId
fileId CIFileStatus 'MDSnd
status
            Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO (Maybe AChatItem)
lookupChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> Maybe AChatItem
-> FileTransferMeta
-> GroupMemberId
-> GroupMemberId
-> ChatEvent
CEvtSndFileProgressXFTP User
user Maybe AChatItem
ci FileTransferMeta
ft GroupMemberId
sndProgress GroupMemberId
sndTotal
        SFDONE ValidFileDescription 'FSender
sndDescr [ValidFileDescription 'FRecipient]
rfds -> do
          (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> Text -> IO ()
setSndFTPrivateSndDescr Connection
db User
user GroupMemberId
fileId (ValidFileDescription 'FSender -> Text
forall (p :: FileParty).
FilePartyI p =>
ValidFileDescription p -> Text
fileDescrText ValidFileDescription 'FSender
sndDescr)
          Maybe AChatItem
ci <- (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe AChatItem))
 -> CM (Maybe AChatItem))
-> (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO (Maybe AChatItem)
lookupChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
          case Maybe AChatItem
ci of
            Maybe AChatItem
Nothing -> do
              ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a. (AgentClient -> IO a) -> CM' a
withAgent' (AgentClient -> ByteString -> IO ()
`xftpDeleteSndFileInternal` ByteString
aFileId)
              (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> [Text] -> IO ()
createExtraSndFTDescrs Connection
db User
user GroupMemberId
fileId ((ValidFileDescription 'FRecipient -> Text)
-> [ValidFileDescription 'FRecipient] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ValidFileDescription 'FRecipient -> Text
forall (p :: FileParty).
FilePartyI p =>
ValidFileDescription p -> Text
fileDescrText [ValidFileDescription 'FRecipient]
rfds)
              case [ValidFileDescription 'FRecipient]
rfds of
                [] -> FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM ()
sendFileError (Text -> FileError
FileErrOther Text
"no receiver descriptions") Text
"no receiver descriptions" VersionRangeChat
vr FileTransferMeta
ft
                ValidFileDescription 'FRecipient
rfd : [ValidFileDescription 'FRecipient]
_ -> case [ValidFileDescription 'FRecipient
fd | fd :: ValidFileDescription 'FRecipient
fd@(FD.ValidFileDescription FD.FileDescription {chunks :: forall (p :: FileParty). FileDescription p -> [FileChunk]
chunks = [Item [FileChunk]
_]}) <- [ValidFileDescription 'FRecipient]
rfds] of
                  [] -> case Maybe GroupMemberId
xftpRedirectFor of
                    Maybe GroupMemberId
Nothing -> User
-> GroupMemberId
-> ValidFileDescription 'FRecipient
-> CM FileTransferMeta
xftpSndFileRedirect User
user GroupMemberId
fileId ValidFileDescription 'FRecipient
rfd CM FileTransferMeta -> (FileTransferMeta -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChatEvent -> CM ()
toView (ChatEvent -> CM ())
-> (FileTransferMeta -> ChatEvent) -> FileTransferMeta -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> FileTransferMeta -> FileTransferMeta -> ChatEvent
CEvtSndFileRedirectStartXFTP User
user FileTransferMeta
ft
                    Just GroupMemberId
_ -> FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM ()
sendFileError (Text -> FileError
FileErrOther Text
"chaining redirects") Text
"Prohibit chaining redirects" VersionRangeChat
vr FileTransferMeta
ft
                  [ValidFileDescription 'FRecipient]
rfds' -> do
                    -- we have 1 chunk - use it as URI whether it is redirect or not
                    FileTransferMeta
ft' <- CM FileTransferMeta
-> (GroupMemberId -> CM FileTransferMeta)
-> Maybe GroupMemberId
-> CM FileTransferMeta
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FileTransferMeta -> CM FileTransferMeta
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileTransferMeta
ft) (\GroupMemberId
fId -> (Connection -> ExceptT StoreError IO FileTransferMeta)
-> CM FileTransferMeta
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO FileTransferMeta)
 -> CM FileTransferMeta)
-> (Connection -> ExceptT StoreError IO FileTransferMeta)
-> CM FileTransferMeta
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User -> GroupMemberId -> ExceptT StoreError IO FileTransferMeta
getFileTransferMeta Connection
db User
user GroupMemberId
fId) Maybe GroupMemberId
xftpRedirectFor
                    ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> FileTransferMeta -> [Text] -> ChatEvent
CEvtSndStandaloneFileComplete User
user FileTransferMeta
ft' ([Text] -> ChatEvent) -> [Text] -> ChatEvent
forall a b. (a -> b) -> a -> b
$ (ValidFileDescription 'FRecipient -> Text)
-> [ValidFileDescription 'FRecipient] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Text
decodeLatin1 (ByteString -> Text)
-> (ValidFileDescription 'FRecipient -> ByteString)
-> ValidFileDescription 'FRecipient
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileDescriptionURI -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (FileDescriptionURI -> ByteString)
-> (ValidFileDescription 'FRecipient -> FileDescriptionURI)
-> ValidFileDescription 'FRecipient
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidFileDescription 'FRecipient -> FileDescriptionURI
FD.fileDescriptionURI) [ValidFileDescription 'FRecipient]
rfds'
            Just (AChatItem SChatType c
_ SMsgDirection d
d ChatInfo c
cInfo _ci :: ChatItem c d
_ci@ChatItem {meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta = CIMeta {itemSharedMsgId :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> Maybe SharedMsgId
itemSharedMsgId = Maybe SharedMsgId
msgId_, Maybe (CIDeleted c)
itemDeleted :: Maybe (CIDeleted c)
itemDeleted :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> Maybe (CIDeleted c)
itemDeleted}}) ->
              case (Maybe SharedMsgId
msgId_, Maybe (CIDeleted c)
itemDeleted) of
                (Just SharedMsgId
sharedMsgId, Maybe (CIDeleted c)
Nothing) -> do
                  Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ValidFileDescription 'FRecipient] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ValidFileDescription 'FRecipient]
rfds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [SndFileTransfer] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SndFileTransfer]
sfts) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError String
"not enough XFTP file descriptions to send"
                  -- TODO either update database status or move to SFPROG
                  ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> Maybe AChatItem
-> FileTransferMeta
-> GroupMemberId
-> GroupMemberId
-> ChatEvent
CEvtSndFileProgressXFTP User
user Maybe AChatItem
ci FileTransferMeta
ft GroupMemberId
1 GroupMemberId
1
                  case ([ValidFileDescription 'FRecipient]
rfds, [SndFileTransfer]
sfts, SMsgDirection d
d, ChatInfo c
cInfo) of
                    (ValidFileDescription 'FRecipient
rfd : [ValidFileDescription 'FRecipient]
extraRFDs, SndFileTransfer
sft : [SndFileTransfer]
_, SMsgDirection d
SMDSnd, DirectChat Contact
ct) -> do
                      (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> [Text] -> IO ()
createExtraSndFTDescrs Connection
db User
user GroupMemberId
fileId ((ValidFileDescription 'FRecipient -> Text)
-> [ValidFileDescription 'FRecipient] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ValidFileDescription 'FRecipient -> Text
forall (p :: FileParty).
FilePartyI p =>
ValidFileDescription p -> Text
fileDescrText [ValidFileDescription 'FRecipient]
extraRFDs)
                      conn :: Connection
conn@Connection {GroupMemberId
connId :: GroupMemberId
connId :: Connection -> GroupMemberId
connId} <- Either ChatError Connection
-> ExceptT ChatError (ReaderT ChatController IO) Connection
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either ChatError Connection
 -> ExceptT ChatError (ReaderT ChatController IO) Connection)
-> Either ChatError Connection
-> ExceptT ChatError (ReaderT ChatController IO) Connection
forall a b. (a -> b) -> a -> b
$ Contact -> Either ChatError Connection
contactSendConn_ Contact
ct
                      ConnOrGroupId
-> NonEmpty (Connection, SndFileTransfer, Text)
-> SharedMsgId
-> CM
     (Maybe
        (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))))
sendFileDescriptions (GroupMemberId -> ConnOrGroupId
ConnectionId GroupMemberId
connId) ((Connection
conn, SndFileTransfer
sft, ValidFileDescription 'FRecipient -> Text
forall (p :: FileParty).
FilePartyI p =>
ValidFileDescription p -> Text
fileDescrText ValidFileDescription 'FRecipient
rfd) (Connection, SndFileTransfer, Text)
-> [(Connection, SndFileTransfer, Text)]
-> NonEmpty (Connection, SndFileTransfer, Text)
forall a. a -> [a] -> NonEmpty a
:| []) SharedMsgId
sharedMsgId CM
  (Maybe
     (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))))
-> (Maybe
      (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption)))
    -> CM ())
-> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Just NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))
rs -> case NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))
-> Either ChatError ([GroupMemberId], PQEncryption)
forall a. NonEmpty a -> a
L.last NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))
rs of
                          Right ([Item [GroupMemberId]
msgDeliveryId], PQEncryption
_) ->
                            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> SndFileTransfer -> GroupMemberId -> IO ()
updateSndFTDeliveryXFTP Connection
db SndFileTransfer
sft GroupMemberId
Item [GroupMemberId]
msgDeliveryId
                          Right ([GroupMemberId]
deliveryIds, PQEncryption
_) -> ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ChatError
ChatError (ChatErrorType -> ChatError) -> ChatErrorType -> ChatError
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError (String -> ChatErrorType) -> String -> ChatErrorType
forall a b. (a -> b) -> a -> b
$ String
"SFDONE, sendFileDescriptions: expected 1 delivery id, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([GroupMemberId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GroupMemberId]
deliveryIds)
                          Left ChatError
e -> ChatError -> CM ()
eToView ChatError
e
                        Maybe (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption)))
Nothing -> ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ChatError
ChatError (ChatErrorType -> ChatError) -> ChatErrorType -> ChatError
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError String
"SFDONE, sendFileDescriptions: expected at least 1 result"
                      ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a. (AgentClient -> IO a) -> CM' a
withAgent' (AgentClient -> ByteString -> IO ()
`xftpDeleteSndFileInternal` ByteString
aFileId)
                    ([ValidFileDescription 'FRecipient]
_, [SndFileTransfer]
_, SMsgDirection d
SMDSnd, GroupChat g :: GroupInfo
g@GroupInfo {GroupMemberId
groupId :: GroupMemberId
groupId :: GroupInfo -> GroupMemberId
groupId} Maybe GroupChatScopeInfo
_scope) -> do
                      -- TODO [channels fwd] single description for all recipients
                      [GroupMember]
ms <- CM [GroupMember]
getRecipients
                      let rfdsMemberFTs :: [(Connection, SndFileTransfer, Text)]
rfdsMemberFTs = (ValidFileDescription 'FRecipient
 -> (Connection, SndFileTransfer)
 -> (Connection, SndFileTransfer, Text))
-> [ValidFileDescription 'FRecipient]
-> [(Connection, SndFileTransfer)]
-> [(Connection, SndFileTransfer, Text)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ValidFileDescription 'FRecipient
rfd (Connection
conn, SndFileTransfer
sft) -> (Connection
conn, SndFileTransfer
sft, ValidFileDescription 'FRecipient -> Text
forall (p :: FileParty).
FilePartyI p =>
ValidFileDescription p -> Text
fileDescrText ValidFileDescription 'FRecipient
rfd)) [ValidFileDescription 'FRecipient]
rfds ([GroupMember] -> [(Connection, SndFileTransfer)]
memberFTs [GroupMember]
ms)
                          extraRFDs :: [ValidFileDescription 'FRecipient]
extraRFDs = Int
-> [ValidFileDescription 'FRecipient]
-> [ValidFileDescription 'FRecipient]
forall a. Int -> [a] -> [a]
drop ([(Connection, SndFileTransfer, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Connection, SndFileTransfer, Text)]
rfdsMemberFTs) [ValidFileDescription 'FRecipient]
rfds
                      (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> [Text] -> IO ()
createExtraSndFTDescrs Connection
db User
user GroupMemberId
fileId ((ValidFileDescription 'FRecipient -> Text)
-> [ValidFileDescription 'FRecipient] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ValidFileDescription 'FRecipient -> Text
forall (p :: FileParty).
FilePartyI p =>
ValidFileDescription p -> Text
fileDescrText [ValidFileDescription 'FRecipient]
extraRFDs)
                      Maybe (NonEmpty (Connection, SndFileTransfer, Text))
-> (NonEmpty (Connection, SndFileTransfer, Text)
    -> CM
         (Maybe
            (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption)))))
-> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Connection, SndFileTransfer, Text)]
-> Maybe (NonEmpty (Connection, SndFileTransfer, Text))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [(Connection, SndFileTransfer, Text)]
rfdsMemberFTs) ((NonEmpty (Connection, SndFileTransfer, Text)
  -> CM
       (Maybe
          (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption)))))
 -> CM ())
-> (NonEmpty (Connection, SndFileTransfer, Text)
    -> CM
         (Maybe
            (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption)))))
-> CM ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty (Connection, SndFileTransfer, Text)
rfdsMemberFTs' ->
                        ConnOrGroupId
-> NonEmpty (Connection, SndFileTransfer, Text)
-> SharedMsgId
-> CM
     (Maybe
        (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))))
sendFileDescriptions (GroupMemberId -> ConnOrGroupId
GroupId GroupMemberId
groupId) NonEmpty (Connection, SndFileTransfer, Text)
rfdsMemberFTs' SharedMsgId
sharedMsgId
                      AChatItem
ci' <- (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem)
-> (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                        IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> User -> GroupMemberId -> CIFileStatus 'MDSnd -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> GroupMemberId -> CIFileStatus d -> IO ()
updateCIFileStatus Connection
db User
user GroupMemberId
fileId CIFileStatus 'MDSnd
CIFSSndComplete
                        Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO AChatItem
getChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
                      ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a. (AgentClient -> IO a) -> CM' a
withAgent' (AgentClient -> ByteString -> IO ()
`xftpDeleteSndFileInternal` ByteString
aFileId)
                      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> FileTransferMeta -> ChatEvent
CEvtSndFileCompleteXFTP User
user AChatItem
ci' FileTransferMeta
ft
                      where
                        getRecipients :: CM [GroupMember]
getRecipients
                          | BoolDef -> Bool
isTrue (GroupInfo -> BoolDef
useRelays GroupInfo
g) = (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [GroupMember]) -> CM [GroupMember])
-> (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
getGroupRelays Connection
db VersionRangeChat
vr User
user GroupInfo
g
                          | Bool
otherwise = (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [GroupMember]) -> CM [GroupMember])
-> (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
getGroupMembers Connection
db VersionRangeChat
vr User
user GroupInfo
g
                        memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)]
                        memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)]
memberFTs [GroupMember]
ms = Map GroupMemberId (Connection, SndFileTransfer)
-> [(Connection, SndFileTransfer)]
forall k a. Map k a -> [a]
M.elems (Map GroupMemberId (Connection, SndFileTransfer)
 -> [(Connection, SndFileTransfer)])
-> Map GroupMemberId (Connection, SndFileTransfer)
-> [(Connection, SndFileTransfer)]
forall a b. (a -> b) -> a -> b
$ (Connection -> SndFileTransfer -> (Connection, SndFileTransfer))
-> Map GroupMemberId Connection
-> Map GroupMemberId SndFileTransfer
-> Map GroupMemberId (Connection, SndFileTransfer)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (,) ([(GroupMemberId, Connection)] -> Map GroupMemberId Connection
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(GroupMemberId, Connection)]
mConns') ([(GroupMemberId, SndFileTransfer)]
-> Map GroupMemberId SndFileTransfer
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(GroupMemberId, SndFileTransfer)]
sfts')
                          where
                            mConns' :: [(GroupMemberId, Connection)]
mConns' = (GroupMember -> Maybe (GroupMemberId, Connection))
-> [GroupMember] -> [(GroupMemberId, Connection)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe GroupMember -> Maybe (GroupMemberId, Connection)
readyMemberConn [GroupMember]
ms
                            sfts' :: [(GroupMemberId, SndFileTransfer)]
sfts' = (SndFileTransfer -> Maybe (GroupMemberId, SndFileTransfer))
-> [SndFileTransfer] -> [(GroupMemberId, SndFileTransfer)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\sft :: SndFileTransfer
sft@SndFileTransfer {Maybe GroupMemberId
groupMemberId :: Maybe GroupMemberId
groupMemberId :: SndFileTransfer -> Maybe GroupMemberId
groupMemberId} -> (,SndFileTransfer
sft) (GroupMemberId -> (GroupMemberId, SndFileTransfer))
-> Maybe GroupMemberId -> Maybe (GroupMemberId, SndFileTransfer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GroupMemberId
groupMemberId) [SndFileTransfer]
sfts
                    ([ValidFileDescription 'FRecipient], [SndFileTransfer],
 SMsgDirection d, ChatInfo c)
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                (Maybe SharedMsgId, Maybe (CIDeleted c))
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- TODO error?
        SFWARN AgentErrorType
e -> do
          let err :: Text
err = AgentErrorType -> Text
forall a. Show a => a -> Text
tshow AgentErrorType
e
          Text -> CM ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logWarn (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"Sent file warning: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
          Maybe AChatItem
ci <- (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe AChatItem))
 -> CM (Maybe AChatItem))
-> (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
            IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> User -> GroupMemberId -> CIFileStatus 'MDSnd -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> GroupMemberId -> CIFileStatus d -> IO ()
updateCIFileStatus Connection
db User
user GroupMemberId
fileId (FileError -> CIFileStatus 'MDSnd
CIFSSndWarning (FileError -> CIFileStatus 'MDSnd)
-> FileError -> CIFileStatus 'MDSnd
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> FileError
agentFileError AgentErrorType
e)
            Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO (Maybe AChatItem)
lookupChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Maybe AChatItem -> FileTransferMeta -> Text -> ChatEvent
CEvtSndFileWarning User
user Maybe AChatItem
ci FileTransferMeta
ft Text
err
        SFERR AgentErrorType
e ->
          FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM ()
sendFileError (AgentErrorType -> FileError
agentFileError AgentErrorType
e) (AgentErrorType -> Text
forall a. Show a => a -> Text
tshow AgentErrorType
e) VersionRangeChat
vr FileTransferMeta
ft
      where
        fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text
        fileDescrText :: forall (p :: FileParty).
FilePartyI p =>
ValidFileDescription p -> Text
fileDescrText = ByteString -> Text
safeDecodeUtf8 (ByteString -> Text)
-> (ValidFileDescription p -> ByteString)
-> ValidFileDescription p
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidFileDescription p -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode
        sendFileDescriptions :: ConnOrGroupId -> NonEmpty (Connection, SndFileTransfer, RcvFileDescrText) -> SharedMsgId -> CM (Maybe (NonEmpty (Either ChatError ([Int64], PQEncryption))))
        sendFileDescriptions :: ConnOrGroupId
-> NonEmpty (Connection, SndFileTransfer, Text)
-> SharedMsgId
-> CM
     (Maybe
        (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))))
sendFileDescriptions ConnOrGroupId
connOrGroupId NonEmpty (Connection, SndFileTransfer, Text)
connsTransfersDescrs SharedMsgId
sharedMsgId = do
          ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ((Connection -> NonEmpty (IO ()))
    -> ReaderT ChatController IO ())
-> (Connection -> NonEmpty (IO ()))
-> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ChatController IO (NonEmpty (Either ChatError ()))
-> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO (NonEmpty (Either ChatError ()))
 -> ReaderT ChatController IO ())
-> ((Connection -> NonEmpty (IO ()))
    -> ReaderT ChatController IO (NonEmpty (Either ChatError ())))
-> (Connection -> NonEmpty (IO ()))
-> ReaderT ChatController IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> NonEmpty (IO ()))
-> ReaderT ChatController IO (NonEmpty (Either ChatError ()))
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' ((Connection -> NonEmpty (IO ())) -> CM ())
-> (Connection -> NonEmpty (IO ())) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ((Connection, SndFileTransfer, Text) -> IO ())
-> NonEmpty (Connection, SndFileTransfer, Text) -> NonEmpty (IO ())
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\(Connection
_, SndFileTransfer
sft, Text
rfdText) -> Connection -> User -> SndFileTransfer -> Text -> IO ()
updateSndFTDescrXFTP Connection
db User
user SndFileTransfer
sft Text
rfdText) NonEmpty (Connection, SndFileTransfer, Text)
connsTransfersDescrs
          Int
partSize <- (ChatController -> Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ChatController -> Int)
 -> ExceptT ChatError (ReaderT ChatController IO) Int)
-> (ChatController -> Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall a b. (a -> b) -> a -> b
$ ChatConfig -> Int
xftpDescrPartSize (ChatConfig -> Int)
-> (ChatController -> ChatConfig) -> ChatController -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config
          let connsIdsEvts :: NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
connsIdsEvts = Int -> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
connDescrEvents Int
partSize
          NonEmpty (Either ChatError SndMessage)
sndMsgs_ <- ReaderT ChatController IO (NonEmpty (Either ChatError SndMessage))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (NonEmpty (Either ChatError SndMessage))
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO (NonEmpty (Either ChatError SndMessage))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (NonEmpty (Either ChatError SndMessage)))
-> ReaderT
     ChatController IO (NonEmpty (Either ChatError SndMessage))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (NonEmpty (Either ChatError SndMessage))
forall a b. (a -> b) -> a -> b
$ NonEmpty (ConnOrGroupId, ChatMsgEvent 'Json)
-> ReaderT
     ChatController IO (NonEmpty (Either ChatError SndMessage))
forall (e :: MsgEncoding) (t :: * -> *).
(MsgEncodingI e, Traversable t) =>
t (ConnOrGroupId, ChatMsgEvent e)
-> CM' (t (Either ChatError SndMessage))
createSndMessages (NonEmpty (ConnOrGroupId, ChatMsgEvent 'Json)
 -> ReaderT
      ChatController IO (NonEmpty (Either ChatError SndMessage)))
-> NonEmpty (ConnOrGroupId, ChatMsgEvent 'Json)
-> ReaderT
     ChatController IO (NonEmpty (Either ChatError SndMessage))
forall a b. (a -> b) -> a -> b
$ ((Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
 -> (ConnOrGroupId, ChatMsgEvent 'Json))
-> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
-> NonEmpty (ConnOrGroupId, ChatMsgEvent 'Json)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
-> (ConnOrGroupId, ChatMsgEvent 'Json)
forall a b. (a, b) -> b
snd NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
connsIdsEvts
          let ([ChatError]
errs, [ChatMsgReq]
msgReqs) = [Either ChatError ChatMsgReq] -> ([ChatError], [ChatMsgReq])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ChatError ChatMsgReq] -> ([ChatError], [ChatMsgReq]))
-> (NonEmpty (Either ChatError ChatMsgReq)
    -> [Either ChatError ChatMsgReq])
-> NonEmpty (Either ChatError ChatMsgReq)
-> ([ChatError], [ChatMsgReq])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Either ChatError ChatMsgReq)
-> [Either ChatError ChatMsgReq]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty (Either ChatError ChatMsgReq)
 -> ([ChatError], [ChatMsgReq]))
-> NonEmpty (Either ChatError ChatMsgReq)
-> ([ChatError], [ChatMsgReq])
forall a b. (a -> b) -> a -> b
$ ((Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
 -> Either ChatError SndMessage -> Either ChatError ChatMsgReq)
-> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
-> NonEmpty (Either ChatError SndMessage)
-> NonEmpty (Either ChatError ChatMsgReq)
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
L.zipWith ((SndMessage -> ChatMsgReq)
-> Either ChatError SndMessage -> Either ChatError ChatMsgReq
forall a b. (a -> b) -> Either ChatError a -> Either ChatError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SndMessage -> ChatMsgReq)
 -> Either ChatError SndMessage -> Either ChatError ChatMsgReq)
-> ((Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
    -> SndMessage -> ChatMsgReq)
-> (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
-> Either ChatError SndMessage
-> Either ChatError ChatMsgReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
-> SndMessage -> ChatMsgReq
toMsgReq) NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
connsIdsEvts NonEmpty (Either ChatError SndMessage)
sndMsgs_
          Maybe (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption)))
delivered <- (NonEmpty ChatMsgReq
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))))
-> Maybe (NonEmpty ChatMsgReq)
-> CM
     (Maybe
        (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM NonEmpty ChatMsgReq
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption)))
deliverMessages ([ChatMsgReq] -> Maybe (NonEmpty ChatMsgReq)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [ChatMsgReq]
msgReqs)
          let errs' :: [ChatError]
errs' = [ChatError]
errs [ChatError] -> [ChatError] -> [ChatError]
forall a. Semigroup a => a -> a -> a
<> [ChatError]
-> (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))
    -> [ChatError])
-> Maybe
     (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption)))
-> [ChatError]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([Either ChatError ([GroupMemberId], PQEncryption)] -> [ChatError]
forall a b. [Either a b] -> [a]
lefts ([Either ChatError ([GroupMemberId], PQEncryption)] -> [ChatError])
-> (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))
    -> [Either ChatError ([GroupMemberId], PQEncryption)])
-> NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))
-> [ChatError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))
-> [Either ChatError ([GroupMemberId], PQEncryption)]
forall a. NonEmpty a -> [a]
L.toList) Maybe (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption)))
delivered
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ChatError] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ChatError]
errs') (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ [ChatError] -> ChatEvent
CEvtChatErrors [ChatError]
errs'
          Maybe (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption)))
-> CM
     (Maybe
        (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption))))
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (NonEmpty (Either ChatError ([GroupMemberId], PQEncryption)))
delivered
          where
            connDescrEvents :: Int -> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
            connDescrEvents :: Int -> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
connDescrEvents Int
partSize = [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))]
-> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
forall a. HasCallStack => [a] -> NonEmpty a
L.fromList ([(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))]
 -> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json)))
-> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))]
-> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
forall a b. (a -> b) -> a -> b
$ ((Connection, SndFileTransfer, Text)
 -> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))])
-> [(Connection, SndFileTransfer, Text)]
-> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Connection, SndFileTransfer, Text)
-> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))]
splitText (NonEmpty (Connection, SndFileTransfer, Text)
-> [(Connection, SndFileTransfer, Text)]
forall a. NonEmpty a -> [a]
L.toList NonEmpty (Connection, SndFileTransfer, Text)
connsTransfersDescrs)
              where
                splitText :: (Connection, SndFileTransfer, RcvFileDescrText) -> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))]
                splitText :: (Connection, SndFileTransfer, Text)
-> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))]
splitText (Connection
conn, SndFileTransfer
_, Text
rfdText) =
                  (FileDescr -> (Connection, (ConnOrGroupId, ChatMsgEvent 'Json)))
-> [FileDescr]
-> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))]
forall a b. (a -> b) -> [a] -> [b]
map (\FileDescr
fileDescr -> (Connection
conn, (ConnOrGroupId
connOrGroupId, XMsgFileDescr {msgId :: SharedMsgId
msgId = SharedMsgId
sharedMsgId, FileDescr
fileDescr :: FileDescr
fileDescr :: FileDescr
fileDescr}))) (NonEmpty FileDescr -> [FileDescr]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty FileDescr -> [FileDescr])
-> NonEmpty FileDescr -> [FileDescr]
forall a b. (a -> b) -> a -> b
$ Int -> Text -> NonEmpty FileDescr
splitFileDescr Int
partSize Text
rfdText)
            toMsgReq :: (Connection, (ConnOrGroupId, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq
            toMsgReq :: (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
-> SndMessage -> ChatMsgReq
toMsgReq (Connection
conn, (ConnOrGroupId, ChatMsgEvent 'Json)
_) SndMessage {GroupMemberId
msgId :: GroupMemberId
msgId :: SndMessage -> GroupMemberId
msgId, ByteString
msgBody :: ByteString
msgBody :: SndMessage -> ByteString
msgBody} =
              (Connection
conn, MsgFlags {notification :: Bool
notification = CMEventTag 'Json -> Bool
forall (e :: MsgEncoding). CMEventTag e -> Bool
hasNotification CMEventTag 'Json
XMsgFileDescr_}, (ByteString -> ValueOrRef ByteString
forall a. a -> ValueOrRef a
vrValue ByteString
msgBody, [GroupMemberId
Item [GroupMemberId]
msgId]))
        sendFileError :: FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM ()
        sendFileError :: FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM ()
sendFileError FileError
ferr Text
err VersionRangeChat
vr FileTransferMeta
ft = do
          Text -> CM ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logError (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"Sent file error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
          Maybe AChatItem
ci <- (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe AChatItem))
 -> CM (Maybe AChatItem))
-> (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
            IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> User -> GroupMemberId -> CIFileStatus 'MDSnd -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> GroupMemberId -> CIFileStatus d -> IO ()
updateFileCancelled Connection
db User
user GroupMemberId
fileId (FileError -> CIFileStatus 'MDSnd
CIFSSndError FileError
ferr)
            Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO (Maybe AChatItem)
lookupChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
          ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a. (AgentClient -> IO a) -> CM' a
withAgent' (AgentClient -> ByteString -> IO ()
`xftpDeleteSndFileInternal` ByteString
aFileId)
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Maybe AChatItem -> FileTransferMeta -> Text -> ChatEvent
CEvtSndFileError User
user Maybe AChatItem
ci FileTransferMeta
ft Text
err

agentFileError :: AgentErrorType -> FileError
agentFileError :: AgentErrorType -> FileError
agentFileError = \case
  XFTP String
_ XFTPErrorType
XFTP.AUTH -> FileError
FileErrAuth
  XFTP String
srv (XFTP.BLOCKED BlockingInfo
info) -> String -> BlockingInfo -> FileError
FileErrBlocked String
srv BlockingInfo
info
  FILE FileErrorType
NO_FILE -> FileError
FileErrNoFile
  BROKER String
_ BrokerErrorType
e -> (SrvError -> FileError) -> BrokerErrorType -> FileError
forall {t}. (SrvError -> t) -> BrokerErrorType -> t
brokerError SrvError -> FileError
FileErrRelay BrokerErrorType
e
  AgentErrorType
e -> Text -> FileError
FileErrOther (Text -> FileError) -> Text -> FileError
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> Text
forall a. Show a => a -> Text
tshow AgentErrorType
e
  where
    brokerError :: (SrvError -> t) -> BrokerErrorType -> t
brokerError SrvError -> t
srvErr = \case
      BrokerErrorType
HOST -> SrvError -> t
srvErr SrvError
SrvErrHost
      SMP.TRANSPORT TransportError
TEVersion -> SrvError -> t
srvErr SrvError
SrvErrVersion
      BrokerErrorType
e -> SrvError -> t
srvErr (SrvError -> t) -> (Text -> SrvError) -> Text -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SrvError
SrvErrOther (Text -> t) -> Text -> t
forall a b. (a -> b) -> a -> b
$ BrokerErrorType -> Text
forall a. Show a => a -> Text
tshow BrokerErrorType
e

processAgentMsgRcvFile :: ACorrId -> RcvFileId -> AEvent 'AERcvFile -> CM ()
processAgentMsgRcvFile :: ByteString -> ByteString -> AEvent 'AERcvFile -> CM ()
processAgentMsgRcvFile ByteString
_corrId ByteString
aFileId AEvent 'AERcvFile
msg = do
  (Maybe ChatRef
cRef_, GroupMemberId
fileId) <- (Connection
 -> ExceptT StoreError IO (Maybe ChatRef, GroupMemberId))
-> CM (Maybe ChatRef, GroupMemberId)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (Connection
-> AgentRcvFileId
-> ExceptT StoreError IO (Maybe ChatRef, GroupMemberId)
`getXFTPRcvFileDBIds` ByteString -> AgentRcvFileId
AgentRcvFileId ByteString
aFileId)
  Maybe ChatRef -> CM () -> CM ()
forall a. Maybe ChatRef -> CM a -> CM a
withEntityLock_ Maybe ChatRef
cRef_ (CM () -> CM ()) -> (CM () -> CM ()) -> CM () -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> GroupMemberId -> CM () -> CM ()
forall a. Text -> GroupMemberId -> CM a -> CM a
withFileLock Text
"processAgentMsgRcvFile" GroupMemberId
fileId (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$
    (Connection -> IO (Maybe User)) -> CM (Maybe User)
forall a. (Connection -> IO a) -> CM a
withStore' (Connection -> AgentRcvFileId -> IO (Maybe User)
`getUserByARcvFileId` ByteString -> AgentRcvFileId
AgentRcvFileId ByteString
aFileId) CM (Maybe User) -> (Maybe User -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just User
user -> User -> GroupMemberId -> CM ()
process User
user GroupMemberId
fileId CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> CM ()
eToView
      Maybe User
_ -> do
        ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a. (AgentClient -> IO a) -> CM' a
withAgent' (AgentClient -> ByteString -> IO ()
`xftpDeleteRcvFile` ByteString
aFileId)
        ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentRcvFileId -> ChatErrorType
CENoRcvFileUser (AgentRcvFileId -> ChatErrorType)
-> AgentRcvFileId -> ChatErrorType
forall a b. (a -> b) -> a -> b
$ ByteString -> AgentRcvFileId
AgentRcvFileId ByteString
aFileId
  where
    withEntityLock_ :: Maybe ChatRef -> CM a -> CM a
    withEntityLock_ :: forall a. Maybe ChatRef -> CM a -> CM a
withEntityLock_ = \case
      Just (ChatRef ChatType
CTDirect GroupMemberId
contactId Maybe GroupChatScope
_) -> Text -> GroupMemberId -> CM a -> CM a
forall a. Text -> GroupMemberId -> CM a -> CM a
withContactLock Text
"processAgentMsgRcvFile" GroupMemberId
contactId
      Just (ChatRef ChatType
CTGroup GroupMemberId
groupId Maybe GroupChatScope
_scope) -> Text -> GroupMemberId -> CM a -> CM a
forall a. Text -> GroupMemberId -> CM a -> CM a
withGroupLock Text
"processAgentMsgRcvFile" GroupMemberId
groupId
      Maybe ChatRef
_ -> CM a -> CM a
forall a. a -> a
id
    process :: User -> FileTransferId -> CM ()
    process :: User -> GroupMemberId -> CM ()
process User
user GroupMemberId
fileId = do
      RcvFileTransfer
ft <- (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RcvFileTransfer)
 -> CM RcvFileTransfer)
-> (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User -> GroupMemberId -> ExceptT StoreError IO RcvFileTransfer
getRcvFileTransfer Connection
db User
user GroupMemberId
fileId
      VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RcvFileTransfer -> Bool
rcvFileCompleteOrCancelled RcvFileTransfer
ft) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ case AEvent 'AERcvFile
msg of
        RFPROG GroupMemberId
rcvProgress GroupMemberId
rcvTotal -> do
          let status :: CIFileStatus 'MDRcv
status = CIFSRcvTransfer {GroupMemberId
rcvProgress :: GroupMemberId
rcvProgress :: GroupMemberId
rcvProgress, GroupMemberId
rcvTotal :: GroupMemberId
rcvTotal :: GroupMemberId
rcvTotal}
          Maybe AChatItem
ci <- (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe AChatItem))
 -> CM (Maybe AChatItem))
-> (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
            IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> User -> GroupMemberId -> CIFileStatus 'MDRcv -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> GroupMemberId -> CIFileStatus d -> IO ()
updateCIFileStatus Connection
db User
user GroupMemberId
fileId CIFileStatus 'MDRcv
status
            Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO (Maybe AChatItem)
lookupChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> Maybe AChatItem
-> GroupMemberId
-> GroupMemberId
-> RcvFileTransfer
-> ChatEvent
CEvtRcvFileProgressXFTP User
user Maybe AChatItem
ci GroupMemberId
rcvProgress GroupMemberId
rcvTotal RcvFileTransfer
ft
        RFDONE String
xftpPath ->
          case RcvFileTransfer -> Maybe String
liveRcvFileTransferPath RcvFileTransfer
ft of
            Maybe String
Nothing -> ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError String
"no target path for received XFTP file"
            Just String
targetPath -> do
              String
fsTargetPath <- ReaderT ChatController IO String
-> ExceptT ChatError (ReaderT ChatController IO) String
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO String
 -> ExceptT ChatError (ReaderT ChatController IO) String)
-> ReaderT ChatController IO String
-> ExceptT ChatError (ReaderT ChatController IO) String
forall a b. (a -> b) -> a -> b
$ String -> ReaderT ChatController IO String
toFSFilePath String
targetPath
              String -> String -> CM ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
renameFile String
xftpPath String
fsTargetPath
              Maybe AChatItem
ci_ <- (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe AChatItem))
 -> CM (Maybe AChatItem))
-> (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ do
                  Connection -> GroupMemberId -> FileStatus -> IO ()
updateRcvFileStatus Connection
db GroupMemberId
fileId FileStatus
FSComplete
                  Connection -> User -> GroupMemberId -> CIFileStatus 'MDRcv -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> GroupMemberId -> CIFileStatus d -> IO ()
updateCIFileStatus Connection
db User
user GroupMemberId
fileId CIFileStatus 'MDRcv
CIFSRcvComplete
                Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO (Maybe AChatItem)
lookupChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
              ByteString -> GroupMemberId -> CM ()
agentXFTPDeleteRcvFile ByteString
aFileId GroupMemberId
fileId
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatEvent
-> (AChatItem -> ChatEvent) -> Maybe AChatItem -> ChatEvent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (User -> String -> RcvFileTransfer -> ChatEvent
CEvtRcvStandaloneFileComplete User
user String
fsTargetPath RcvFileTransfer
ft) (User -> AChatItem -> ChatEvent
CEvtRcvFileComplete User
user) Maybe AChatItem
ci_
        RFWARN AgentErrorType
e -> do
          Maybe AChatItem
ci <- (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe AChatItem))
 -> CM (Maybe AChatItem))
-> (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
            IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> User -> GroupMemberId -> CIFileStatus 'MDRcv -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> GroupMemberId -> CIFileStatus d -> IO ()
updateCIFileStatus Connection
db User
user GroupMemberId
fileId (FileError -> CIFileStatus 'MDRcv
CIFSRcvWarning (FileError -> CIFileStatus 'MDRcv)
-> FileError -> CIFileStatus 'MDRcv
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> FileError
agentFileError AgentErrorType
e)
            Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO (Maybe AChatItem)
lookupChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> Maybe AChatItem
-> AgentErrorType
-> RcvFileTransfer
-> ChatEvent
CEvtRcvFileWarning User
user Maybe AChatItem
ci AgentErrorType
e RcvFileTransfer
ft
        RFERR AgentErrorType
e
          | AgentErrorType
e AgentErrorType -> AgentErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== FileErrorType -> AgentErrorType
FILE FileErrorType
NOT_APPROVED -> do
              Maybe AChatItem
aci_ <- User
-> GroupMemberId -> CIFileStatus 'MDRcv -> CM (Maybe AChatItem)
resetRcvCIFileStatus User
user GroupMemberId
fileId CIFileStatus 'MDRcv
CIFSRcvAborted
              Maybe AChatItem -> (AChatItem -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe AChatItem
aci_ AChatItem -> CM ()
cleanupACIFile
              ByteString -> GroupMemberId -> CM ()
agentXFTPDeleteRcvFile ByteString
aFileId GroupMemberId
fileId
              Maybe AChatItem -> (AChatItem -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe AChatItem
aci_ ((AChatItem -> CM ()) -> CM ()) -> (AChatItem -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \AChatItem
aci -> ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemUpdated User
user AChatItem
aci
          | Bool
otherwise -> do
              Maybe AChatItem
aci_ <- (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe AChatItem))
 -> CM (Maybe AChatItem))
-> (Connection -> ExceptT StoreError IO (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> User -> GroupMemberId -> CIFileStatus 'MDRcv -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> GroupMemberId -> CIFileStatus d -> IO ()
updateFileCancelled Connection
db User
user GroupMemberId
fileId (FileError -> CIFileStatus 'MDRcv
CIFSRcvError (FileError -> CIFileStatus 'MDRcv)
-> FileError -> CIFileStatus 'MDRcv
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> FileError
agentFileError AgentErrorType
e)
                Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO (Maybe AChatItem)
lookupChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
              Maybe AChatItem -> (AChatItem -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe AChatItem
aci_ AChatItem -> CM ()
cleanupACIFile
              ByteString -> GroupMemberId -> CM ()
agentXFTPDeleteRcvFile ByteString
aFileId GroupMemberId
fileId
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> Maybe AChatItem
-> AgentErrorType
-> RcvFileTransfer
-> ChatEvent
CEvtRcvFileError User
user Maybe AChatItem
aci_ AgentErrorType
e RcvFileTransfer
ft

type ShouldDeleteGroupConns = Bool

processAgentMessageConn :: VersionRangeChat -> User -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
processAgentMessageConn :: VersionRangeChat
-> User -> ByteString -> ByteString -> AEvent 'AEConn -> CM ()
processAgentMessageConn VersionRangeChat
vr user :: User
user@User {GroupMemberId
userId :: GroupMemberId
userId :: User -> GroupMemberId
userId} ByteString
corrId ByteString
agentConnId AEvent 'AEConn
agentMessage = do
  -- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert,
  -- as in this case no need to ACK message - we can't process messages for this connection anyway.
  -- SEDBException will be re-trown as CRITICAL as it is likely to indicate a temporary database condition
  -- that will be resolved with app restart.
  ConnectionEntity
entity <- ByteString -> CM ConnectionEntity -> CM ConnectionEntity
forall a. ByteString -> CM a -> CM a
critical ByteString
agentConnId (CM ConnectionEntity -> CM ConnectionEntity)
-> CM ConnectionEntity -> CM ConnectionEntity
forall a b. (a -> b) -> a -> b
$ (Connection -> ExceptT StoreError IO ConnectionEntity)
-> CM ConnectionEntity
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> VersionRangeChat
-> User
-> AgentConnId
-> ExceptT StoreError IO ConnectionEntity
getConnectionEntity Connection
db VersionRangeChat
vr User
user (AgentConnId -> ExceptT StoreError IO ConnectionEntity)
-> AgentConnId -> ExceptT StoreError IO ConnectionEntity
forall a b. (a -> b) -> a -> b
$ ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) CM ConnectionEntity
-> (ConnectionEntity -> CM ConnectionEntity) -> CM ConnectionEntity
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConnectionEntity -> CM ConnectionEntity
updateConnStatus
  case AEvent 'AEConn
agentMessage of
    AEvent 'AEConn
END -> case ConnectionEntity
entity of
      RcvDirectMsgConnection Connection
_ (Just Contact
ct) -> ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> ChatEvent
CEvtContactAnotherClient User
user Contact
ct
      ConnectionEntity
_ -> ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> ConnectionEntity -> ChatEvent
CEvtSubscriptionEnd User
user ConnectionEntity
entity
    MSGNTF ByteString
msgId Maybe UTCTime
msgTs_ -> ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> ConnectionEntity -> NtfMsgAckInfo -> ChatEvent
CEvtNtfMessage User
user ConnectionEntity
entity (NtfMsgAckInfo -> ChatEvent) -> NtfMsgAckInfo -> ChatEvent
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe UTCTime -> NtfMsgAckInfo
ntfMsgAckInfo ByteString
msgId Maybe UTCTime
msgTs_
    AEvent 'AEConn
_ -> case ConnectionEntity
entity of
      RcvDirectMsgConnection Connection
conn Maybe Contact
contact_ ->
        AEvent 'AEConn
-> ConnectionEntity -> Connection -> Maybe Contact -> CM ()
forall (e :: AEntity).
AEvent e
-> ConnectionEntity -> Connection -> Maybe Contact -> CM ()
processDirectMessage AEvent 'AEConn
agentMessage ConnectionEntity
entity Connection
conn Maybe Contact
contact_
      RcvGroupMsgConnection Connection
conn GroupInfo
gInfo GroupMember
m ->
        AEvent 'AEConn
-> ConnectionEntity
-> Connection
-> GroupInfo
-> GroupMember
-> CM ()
forall (e :: AEntity).
AEvent e
-> ConnectionEntity
-> Connection
-> GroupInfo
-> GroupMember
-> CM ()
processGroupMessage AEvent 'AEConn
agentMessage ConnectionEntity
entity Connection
conn GroupInfo
gInfo GroupMember
m
      UserContactConnection Connection
conn UserContact
uc ->
        AEvent 'AEConn
-> ConnectionEntity -> Connection -> UserContact -> CM ()
forall (e :: AEntity).
AEvent e -> ConnectionEntity -> Connection -> UserContact -> CM ()
processUserContactRequest AEvent 'AEConn
agentMessage ConnectionEntity
entity Connection
conn UserContact
uc
  where
    updateConnStatus :: ConnectionEntity -> CM ConnectionEntity
    updateConnStatus :: ConnectionEntity -> CM ConnectionEntity
updateConnStatus ConnectionEntity
acEntity = case AEvent 'AEConn -> Maybe ConnStatus
forall (e :: AEntity). AEvent e -> Maybe ConnStatus
agentMsgConnStatus AEvent 'AEConn
agentMessage of
      Just ConnStatus
connStatus -> do
        let conn :: Connection
conn = (ConnectionEntity -> Connection
entityConnection ConnectionEntity
acEntity) {connStatus}
        (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> Connection -> ConnStatus -> IO ()
updateConnectionStatus Connection
db Connection
conn ConnStatus
connStatus
        ConnectionEntity -> CM ConnectionEntity
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionEntity -> CM ConnectionEntity)
-> ConnectionEntity -> CM ConnectionEntity
forall a b. (a -> b) -> a -> b
$ ConnectionEntity -> ConnStatus -> ConnectionEntity
updateEntityConnStatus ConnectionEntity
acEntity ConnStatus
connStatus
      Maybe ConnStatus
Nothing -> ConnectionEntity -> CM ConnectionEntity
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnectionEntity
acEntity

    agentMsgConnStatus :: AEvent e -> Maybe ConnStatus
    agentMsgConnStatus :: forall (e :: AEntity). AEvent e -> Maybe ConnStatus
agentMsgConnStatus = \case
      JOINED Bool
True Maybe ClientServiceId
_ -> ConnStatus -> Maybe ConnStatus
forall a. a -> Maybe a
Just ConnStatus
ConnSndReady
      CONF {} -> ConnStatus -> Maybe ConnStatus
forall a. a -> Maybe a
Just ConnStatus
ConnRequested
      INFO {} -> ConnStatus -> Maybe ConnStatus
forall a. a -> Maybe a
Just ConnStatus
ConnSndReady
      CON PQEncryption
_ -> ConnStatus -> Maybe ConnStatus
forall a. a -> Maybe a
Just ConnStatus
ConnReady
      AEvent e
_ -> Maybe ConnStatus
forall a. Maybe a
Nothing

    processCONFpqSupport :: Connection -> PQSupport -> CM Connection
    processCONFpqSupport :: Connection
-> PQSupport
-> ExceptT ChatError (ReaderT ChatController IO) Connection
processCONFpqSupport conn :: Connection
conn@Connection {GroupMemberId
connId :: Connection -> GroupMemberId
connId :: GroupMemberId
connId, pqSupport :: Connection -> PQSupport
pqSupport = PQSupport
pq} PQSupport
pq'
      | PQSupport
pq PQSupport -> PQSupport -> Bool
forall a. Eq a => a -> a -> Bool
== PQSupport
PQSupportOn Bool -> Bool -> Bool
&& PQSupport
pq' PQSupport -> PQSupport -> Bool
forall a. Eq a => a -> a -> Bool
== PQSupport
PQSupportOff = do
          let pqEnc' :: PQEncryption
pqEnc' = PQSupport -> PQEncryption
CR.pqSupportToEnc PQSupport
pq'
          (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> GroupMemberId -> PQSupport -> PQEncryption -> IO ()
updateConnSupportPQ Connection
db GroupMemberId
connId PQSupport
pq' PQEncryption
pqEnc'
          Connection
-> ExceptT ChatError (ReaderT ChatController IO) Connection
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Connection
conn {pqSupport = pq', pqEncryption = pqEnc'} :: Connection)
      | PQSupport
pq PQSupport -> PQSupport -> Bool
forall a. Eq a => a -> a -> Bool
/= PQSupport
pq' = do
          Text -> CM ()
messageWarning Text
"processCONFpqSupport: unexpected pqSupport change"
          Connection
-> ExceptT ChatError (ReaderT ChatController IO) Connection
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
conn
      | Bool
otherwise = Connection
-> ExceptT ChatError (ReaderT ChatController IO) Connection
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
conn

    processINFOpqSupport :: Connection -> PQSupport -> CM ()
    processINFOpqSupport :: Connection -> PQSupport -> CM ()
processINFOpqSupport Connection {pqSupport :: Connection -> PQSupport
pqSupport = PQSupport
pq} PQSupport
pq' =
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PQSupport
pq PQSupport -> PQSupport -> Bool
forall a. Eq a => a -> a -> Bool
/= PQSupport
pq') (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Text -> CM ()
messageWarning Text
"processINFOpqSupport: unexpected pqSupport change"

    processDirectMessage :: AEvent e -> ConnectionEntity -> Connection -> Maybe Contact -> CM ()
    processDirectMessage :: forall (e :: AEntity).
AEvent e
-> ConnectionEntity -> Connection -> Maybe Contact -> CM ()
processDirectMessage AEvent e
agentMsg ConnectionEntity
connEntity conn :: Connection
conn@Connection {GroupMemberId
connId :: Connection -> GroupMemberId
connId :: GroupMemberId
connId, Version ChatVersion
connChatVersion :: Version ChatVersion
connChatVersion :: Connection -> Version ChatVersion
connChatVersion, VersionRangeChat
peerChatVRange :: VersionRangeChat
peerChatVRange :: Connection -> VersionRangeChat
peerChatVRange, Maybe GroupMemberId
viaUserContactLink :: Maybe GroupMemberId
viaUserContactLink :: Connection -> Maybe GroupMemberId
viaUserContactLink, Maybe GroupMemberId
customUserProfileId :: Maybe GroupMemberId
customUserProfileId :: Connection -> Maybe GroupMemberId
customUserProfileId, Maybe SecurityCode
connectionCode :: Maybe SecurityCode
connectionCode :: Connection -> Maybe SecurityCode
connectionCode} = \case
      Maybe Contact
Nothing -> case AEvent e
agentMsg of
        CONF ByteString
confId PQSupport
pqSupport [SMPServer]
_ ByteString
connInfo -> do
          Connection
conn' <- Connection
-> PQSupport
-> ExceptT ChatError (ReaderT ChatController IO) Connection
processCONFpqSupport Connection
conn PQSupport
pqSupport
          -- [incognito] send saved profile
          (Connection
conn'', Maybe GroupInfo
gInfo_) <- Connection -> ByteString -> CM (Connection, Maybe GroupInfo)
saveConnInfo Connection
conn' ByteString
connInfo
          Maybe LocalProfile
incognitoProfile <- Maybe GroupMemberId
-> (GroupMemberId
    -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe LocalProfile)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe GroupMemberId
customUserProfileId ((GroupMemberId
  -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe LocalProfile))
-> (GroupMemberId
    -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe LocalProfile)
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
profileId -> (Connection -> ExceptT StoreError IO LocalProfile)
-> ExceptT ChatError (ReaderT ChatController IO) LocalProfile
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO LocalProfile
getProfileById Connection
db GroupMemberId
userId GroupMemberId
profileId)
          let profileToSend :: Profile
profileToSend = case Maybe GroupInfo
gInfo_ of
                Just GroupInfo
gInfo -> User -> GroupInfo -> Maybe Profile -> Profile
userProfileInGroup User
user GroupInfo
gInfo (LocalProfile -> Profile
fromLocalProfile (LocalProfile -> Profile) -> Maybe LocalProfile -> Maybe Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LocalProfile
incognitoProfile)
                Maybe GroupInfo
Nothing -> User -> Maybe Profile -> Maybe Contact -> Bool -> Profile
userProfileDirect User
user (LocalProfile -> Profile
fromLocalProfile (LocalProfile -> Profile) -> Maybe LocalProfile -> Maybe Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LocalProfile
incognitoProfile) Maybe Contact
forall a. Maybe a
Nothing Bool
True
          -- [async agent commands] no continuation needed, but command should be asynchronous for stability
          User -> Connection -> ByteString -> ChatMsgEvent 'Json -> CM ()
forall (e :: MsgEncoding).
MsgEncodingI e =>
User -> Connection -> ByteString -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync User
user Connection
conn'' ByteString
confId (ChatMsgEvent 'Json -> CM ()) -> ChatMsgEvent 'Json -> CM ()
forall a b. (a -> b) -> a -> b
$ Profile -> ChatMsgEvent 'Json
XInfo Profile
profileToSend
        INFO PQSupport
pqSupport ByteString
connInfo -> do
          Connection -> PQSupport -> CM ()
processINFOpqSupport Connection
conn PQSupport
pqSupport
          CM (Connection, Maybe GroupInfo) -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM (Connection, Maybe GroupInfo) -> CM ())
-> CM (Connection, Maybe GroupInfo) -> CM ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> CM (Connection, Maybe GroupInfo)
saveConnInfo Connection
conn ByteString
connInfo
        MSG MsgMeta
meta MsgFlags
_msgFlags ByteString
_msgBody ->
          -- We are not saving message (saveDirectRcvMSG) as contact hasn't been created yet,
          -- chat item is also not created here
          Text -> ByteString -> MsgMeta -> CM () -> CM ()
withAckMessage' Text
"new contact msg" ByteString
agentConnId MsgMeta
meta (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        SENT GroupMemberId
msgId Maybe SMPServer
_proxy -> do
          ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ()
forall a b. (a -> b) -> a -> b
$ ConnectionEntity
-> Connection -> ExceptT ChatError (ReaderT ChatController IO) Bool
continueSending ConnectionEntity
connEntity Connection
conn
          Connection -> GroupMemberId -> CM ()
sentMsgDeliveryEvent Connection
conn GroupMemberId
msgId
        AEvent e
OK ->
          -- [async agent commands] continuation on receiving OK
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
corrId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData
_cmdData -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        -- TODO [certs rcv]
        JOINED Bool
_ Maybe ClientServiceId
_serviceId ->
          -- [async agent commands] continuation on receiving JOINED
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
corrId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData
_cmdData -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        AEvent e
QCONT ->
          ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ()
forall a b. (a -> b) -> a -> b
$ ConnectionEntity
-> Connection -> ExceptT ChatError (ReaderT ChatController IO) Bool
continueSending ConnectionEntity
connEntity Connection
conn
        MWARN GroupMemberId
_ AgentErrorType
err ->
          ConnectionEntity -> Connection -> AgentErrorType -> CM ()
processConnMWARN ConnectionEntity
connEntity Connection
conn AgentErrorType
err
        MERR GroupMemberId
_ AgentErrorType
err -> do
          ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
err (ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) (ConnectionEntity -> Maybe ConnectionEntity
forall a. a -> Maybe a
Just ConnectionEntity
connEntity)
          ConnectionEntity -> Connection -> AgentErrorType -> CM ()
processConnMERR ConnectionEntity
connEntity Connection
conn AgentErrorType
err
        MERRS NonEmpty GroupMemberId
_ AgentErrorType
err -> do
          -- error cannot be AUTH error here
          ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
err (ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) (ConnectionEntity -> Maybe ConnectionEntity
forall a. a -> Maybe a
Just ConnectionEntity
connEntity)
        ERR AgentErrorType
err -> do
          ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
err (ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) (ConnectionEntity -> Maybe ConnectionEntity
forall a. a -> Maybe a
Just ConnectionEntity
connEntity)
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
corrId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData
_cmdData -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        -- TODO add debugging output
        AEvent e
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just ct :: Contact
ct@Contact {GroupMemberId
contactId :: GroupMemberId
contactId :: Contact -> GroupMemberId
contactId} -> case AEvent e
agentMsg of
        -- TODO [certs rcv]
        INV (ACR SConnectionMode m
_ ConnectionRequestUri m
cReq) Maybe ClientServiceId
_serviceId ->
          -- [async agent commands] XGrpMemIntro continuation on receiving INV
          Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData
_ ->
            case ConnectionRequestUri m
cReq of
              CRInvitationUri ConnReqUriData
_ RcvE2ERatchetParamsUri 'X448
_ -> (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> ConnReqInvitation -> IO ()
setConnConnReqInv Connection
db User
user GroupMemberId
connId ConnectionRequestUri m
ConnReqInvitation
cReq
              CRContactUri ConnReqUriData
_ -> ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CECommandError String
"unexpected ConnectionRequestUri type"
        MSG MsgMeta
msgMeta MsgFlags
_msgFlags ByteString
msgBody -> do
          TVar [Text]
tags <- [Text]
-> ExceptT ChatError (ReaderT ChatController IO) (TVar [Text])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
          Text
-> ByteString
-> MsgMeta
-> Bool
-> Maybe (TVar [Text])
-> (Text -> CM (Bool, Bool))
-> CM ()
withAckMessage Text
"contact msg" ByteString
agentConnId MsgMeta
msgMeta Bool
True (TVar [Text] -> Maybe (TVar [Text])
forall a. a -> Maybe a
Just TVar [Text]
tags) ((Text -> CM (Bool, Bool)) -> CM ())
-> (Text -> CM (Bool, Bool)) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Text
eInfo -> do
            let MsgMeta {PQEncryption
pqEncryption :: PQEncryption
pqEncryption :: MsgMeta -> PQEncryption
pqEncryption} = MsgMeta
msgMeta
            (Contact
ct', Connection
conn') <- User
-> Contact
-> Connection
-> PQEncryption
-> CM (Contact, Connection)
updateContactPQRcv User
user Contact
ct Connection
conn PQEncryption
pqEncryption
            ChatDirection 'CTDirect 'MDRcv -> MsgMeta -> CM ()
forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv -> MsgMeta -> CM ()
checkIntegrityCreateItem (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct') MsgMeta
msgMeta CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            [Either String AChatMessage]
-> (Either String AChatMessage -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Either String AChatMessage]
aChatMsgs ((Either String AChatMessage -> CM ()) -> CM ())
-> (Either String AChatMessage -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \case
              Right (ACMsg SMsgEncoding e
_ ChatMessage e
chatMsg) ->
                Contact
-> Connection
-> TVar [Text]
-> Text
-> MsgEncodingI e => ChatMessage e -> CM ()
forall (e :: MsgEncoding).
Contact
-> Connection
-> TVar [Text]
-> Text
-> MsgEncodingI e => ChatMessage e -> CM ()
processEvent Contact
ct' Connection
conn' TVar [Text]
tags Text
eInfo ChatMessage e
chatMsg CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
e -> ChatError -> CM ()
eToView ChatError
e
              Left String
e -> do
                STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TVar [Text] -> ([Text] -> [Text]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Text]
tags (Text
"error" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
                Text -> CM ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logInfo (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"contact msg=error " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
eInfo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
tshow String
e
                ChatError -> CM ()
eToView (ChatErrorType -> ChatError
ChatError (ChatErrorType -> ChatError)
-> (String -> ChatErrorType) -> String -> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ChatErrorType
CEException (String -> ChatError) -> String -> ChatError
forall a b. (a -> b) -> a -> b
$ String
"error parsing chat message: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e)
            Bool
withRcpt <- Contact
-> [AChatMessage]
-> ExceptT ChatError (ReaderT ChatController IO) Bool
checkSendRcpt Contact
ct' ([AChatMessage]
 -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> [AChatMessage]
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a b. (a -> b) -> a -> b
$ [Either String AChatMessage] -> [AChatMessage]
forall a b. [Either a b] -> [b]
rights [Either String AChatMessage]
aChatMsgs -- not crucial to use ct'' from processEvent
            (Bool, Bool) -> CM (Bool, Bool)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
withRcpt, Bool
False)
          where
            aChatMsgs :: [Either String AChatMessage]
aChatMsgs = ByteString -> [Either String AChatMessage]
parseChatMessages ByteString
msgBody
            processEvent :: Contact -> Connection -> TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM ()
            processEvent :: forall (e :: MsgEncoding).
Contact
-> Connection
-> TVar [Text]
-> Text
-> MsgEncodingI e => ChatMessage e -> CM ()
processEvent Contact
ct' Connection
conn' TVar [Text]
tags Text
eInfo chatMsg :: ChatMessage e
chatMsg@ChatMessage {ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent} = do
              let tag :: CMEventTag e
tag = ChatMsgEvent e -> CMEventTag e
forall (e :: MsgEncoding). ChatMsgEvent e -> CMEventTag e
toCMEventTag ChatMsgEvent e
chatMsgEvent
              STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TVar [Text] -> ([Text] -> [Text]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Text]
tags (CMEventTag e -> Text
forall a. Show a => a -> Text
tshow CMEventTag e
tag Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
              Text -> CM ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logInfo (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"contact msg=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CMEventTag e -> Text
forall a. Show a => a -> Text
tshow CMEventTag e
tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
eInfo
              let body :: ByteString
body = ChatMessage e -> ByteString
forall (e :: MsgEncoding).
MsgEncodingI e =>
ChatMessage e -> ByteString
chatMsgToBody ChatMessage e
chatMsg
              (Connection
conn'', msg :: RcvMessage
msg@RcvMessage {chatMsgEvent :: RcvMessage -> AChatMsgEvent
chatMsgEvent = ACME SMsgEncoding e
_ ChatMsgEvent e
event}) <- Connection
-> MsgMeta
-> ByteString
-> ChatMessage e
-> CM (Connection, RcvMessage)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> MsgMeta
-> ByteString
-> ChatMessage e
-> CM (Connection, RcvMessage)
saveDirectRcvMSG Connection
conn' MsgMeta
msgMeta ByteString
body ChatMessage e
chatMsg
              let ct'' :: Contact
ct'' = Contact
ct' {activeConn = Just conn''} :: Contact
              case ChatMsgEvent e
event of
                XMsgNew MsgContainer
mc -> Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
newContentMessage Contact
ct'' MsgContainer
mc RcvMessage
msg MsgMeta
msgMeta
                XMsgFileDescr SharedMsgId
sharedMsgId FileDescr
fileDescr -> Contact -> SharedMsgId -> FileDescr -> CM ()
messageFileDescription Contact
ct'' SharedMsgId
sharedMsgId FileDescr
fileDescr
                XMsgUpdate SharedMsgId
sharedMsgId MsgContent
mContent Map Text MsgMention
_ Maybe Int
ttl Maybe Bool
live Maybe MsgScope
_msgScope -> Contact
-> SharedMsgId
-> MsgContent
-> RcvMessage
-> MsgMeta
-> Maybe Int
-> Maybe Bool
-> CM ()
messageUpdate Contact
ct'' SharedMsgId
sharedMsgId MsgContent
mContent RcvMessage
msg MsgMeta
msgMeta Maybe Int
ttl Maybe Bool
live
                XMsgDel SharedMsgId
sharedMsgId Maybe MemberId
_ Maybe MsgScope
_ -> Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> CM ()
messageDelete Contact
ct'' SharedMsgId
sharedMsgId RcvMessage
msg MsgMeta
msgMeta
                XMsgReact SharedMsgId
sharedMsgId Maybe MemberId
_ Maybe MsgScope
_ MsgReaction
reaction Bool
add -> Contact
-> SharedMsgId
-> MsgReaction
-> Bool
-> RcvMessage
-> MsgMeta
-> CM ()
directMsgReaction Contact
ct'' SharedMsgId
sharedMsgId MsgReaction
reaction Bool
add RcvMessage
msg MsgMeta
msgMeta
                -- TODO discontinue XFile
                XFile FileInvitation
fInv -> Contact -> FileInvitation -> RcvMessage -> MsgMeta -> CM ()
processFileInvitation' Contact
ct'' FileInvitation
fInv RcvMessage
msg MsgMeta
msgMeta
                XFileCancel SharedMsgId
sharedMsgId -> Contact -> SharedMsgId -> CM ()
xFileCancel Contact
ct'' SharedMsgId
sharedMsgId
                XFileAcptInv SharedMsgId
sharedMsgId Maybe ConnReqInvitation
fileConnReq_ String
fName -> Contact
-> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM ()
xFileAcptInv Contact
ct'' SharedMsgId
sharedMsgId Maybe ConnReqInvitation
fileConnReq_ String
fName
                XInfo Profile
p -> Contact -> Profile -> CM ()
xInfo Contact
ct'' Profile
p
                ChatMsgEvent e
XDirectDel -> Contact -> RcvMessage -> MsgMeta -> CM ()
xDirectDel Contact
ct'' RcvMessage
msg MsgMeta
msgMeta
                XGrpInv GroupInvitation
gInv -> Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> CM ()
processGroupInvitation Contact
ct'' GroupInvitation
gInv RcvMessage
msg MsgMeta
msgMeta
                XInfoProbe Probe
probe -> ContactOrMember -> Probe -> CM ()
xInfoProbe (Contact -> ContactOrMember
COMContact Contact
ct'') Probe
probe
                XInfoProbeCheck ProbeHash
probeHash -> ContactOrMember -> ProbeHash -> CM ()
xInfoProbeCheck (Contact -> ContactOrMember
COMContact Contact
ct'') ProbeHash
probeHash
                XInfoProbeOk Probe
probe -> ContactOrMember -> Probe -> CM ()
xInfoProbeOk (Contact -> ContactOrMember
COMContact Contact
ct'') Probe
probe
                XCallInv CallId
callId CallInvitation
invitation -> Contact
-> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> CM ()
xCallInv Contact
ct'' CallId
callId CallInvitation
invitation RcvMessage
msg MsgMeta
msgMeta
                XCallOffer CallId
callId CallOffer
offer -> Contact -> CallId -> CallOffer -> RcvMessage -> CM ()
xCallOffer Contact
ct'' CallId
callId CallOffer
offer RcvMessage
msg
                XCallAnswer CallId
callId CallAnswer
answer -> Contact -> CallId -> CallAnswer -> RcvMessage -> CM ()
xCallAnswer Contact
ct'' CallId
callId CallAnswer
answer RcvMessage
msg
                XCallExtra CallId
callId CallExtraInfo
extraInfo -> Contact -> CallId -> CallExtraInfo -> RcvMessage -> CM ()
xCallExtra Contact
ct'' CallId
callId CallExtraInfo
extraInfo RcvMessage
msg
                XCallEnd CallId
callId -> Contact -> CallId -> RcvMessage -> CM ()
xCallEnd Contact
ct'' CallId
callId RcvMessage
msg
                BFileChunk SharedMsgId
sharedMsgId FileChunk
chunk -> Contact -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
bFileChunk Contact
ct'' SharedMsgId
sharedMsgId FileChunk
chunk MsgMeta
msgMeta
                ChatMsgEvent e
_ -> Text -> CM ()
messageError (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"unsupported message: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ChatMsgEvent e -> String
forall a. Show a => a -> String
show ChatMsgEvent e
event)
            checkSendRcpt :: Contact -> [AChatMessage] -> CM Bool
            checkSendRcpt :: Contact
-> [AChatMessage]
-> ExceptT ChatError (ReaderT ChatController IO) Bool
checkSendRcpt Contact
ct' [AChatMessage]
aMsgs = do
              let Contact {chatSettings :: Contact -> ChatSettings
chatSettings = ChatSettings {Maybe Bool
sendRcpts :: Maybe Bool
sendRcpts :: ChatSettings -> Maybe Bool
sendRcpts}} = Contact
ct'
              Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (User -> Bool
sendRcptsContacts User
user) Maybe Bool
sendRcpts Bool -> Bool -> Bool
&& (AChatMessage -> Bool) -> [AChatMessage] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any AChatMessage -> Bool
aChatMsgHasReceipt [AChatMessage]
aMsgs
              where
                aChatMsgHasReceipt :: AChatMessage -> Bool
aChatMsgHasReceipt (ACMsg SMsgEncoding e
_ ChatMessage {ChatMsgEvent e
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent}) =
                  CMEventTag e -> Bool
forall (e :: MsgEncoding). CMEventTag e -> Bool
hasDeliveryReceipt (ChatMsgEvent e -> CMEventTag e
forall (e :: MsgEncoding). ChatMsgEvent e -> CMEventTag e
toCMEventTag ChatMsgEvent e
chatMsgEvent)
        RCVD MsgMeta
msgMeta NonEmpty MsgReceipt
msgRcpt ->
          Text -> ByteString -> MsgMeta -> CM () -> CM ()
withAckMessage' Text
"contact rcvd" ByteString
agentConnId MsgMeta
msgMeta (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$
            Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
directMsgReceived Contact
ct Connection
conn MsgMeta
msgMeta NonEmpty MsgReceipt
msgRcpt
        CONF ByteString
confId PQSupport
pqSupport [SMPServer]
_ ByteString
connInfo -> do
          Connection
conn' <- Connection
-> PQSupport
-> ExceptT ChatError (ReaderT ChatController IO) Connection
processCONFpqSupport Connection
conn PQSupport
pqSupport
          ChatMessage {VersionRangeChat
chatVRange :: VersionRangeChat
chatVRange :: forall (e :: MsgEncoding). ChatMessage e -> VersionRangeChat
chatVRange, ChatMsgEvent 'Json
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent 'Json
chatMsgEvent} <- Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage Connection
conn' ByteString
connInfo
          Connection
conn'' <- Connection
-> VersionRangeChat
-> ExceptT ChatError (ReaderT ChatController IO) Connection
updatePeerChatVRange Connection
conn' VersionRangeChat
chatVRange
          case ChatMsgEvent 'Json
chatMsgEvent of
            -- confirming direct connection with a member
            XGrpMemInfo MemberId
_memId Profile
_memProfile -> do
              -- TODO check member ID
              -- TODO update member profile
              -- [async agent commands] no continuation needed, but command should be asynchronous for stability
              User -> Connection -> ByteString -> ChatMsgEvent 'Json -> CM ()
forall (e :: MsgEncoding).
MsgEncodingI e =>
User -> Connection -> ByteString -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync User
user Connection
conn'' ByteString
confId ChatMsgEvent 'Json
XOk
            XInfo Profile
profile -> do
              Contact
ct' <- Contact -> Profile -> Bool -> CM Contact
processContactProfileUpdate Contact
ct Profile
profile Bool
False CM Contact -> (ChatError -> CM Contact) -> CM Contact
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` CM Contact -> ChatError -> CM Contact
forall a b. a -> b -> a
const (Contact -> CM Contact
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Contact
ct)
              -- [incognito] send incognito profile
              Maybe LocalProfile
incognitoProfile <- Maybe GroupMemberId
-> (GroupMemberId
    -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe LocalProfile)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe GroupMemberId
customUserProfileId ((GroupMemberId
  -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe LocalProfile))
-> (GroupMemberId
    -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe LocalProfile)
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
profileId -> (Connection -> ExceptT StoreError IO LocalProfile)
-> ExceptT ChatError (ReaderT ChatController IO) LocalProfile
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO LocalProfile)
 -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> (Connection -> ExceptT StoreError IO LocalProfile)
-> ExceptT ChatError (ReaderT ChatController IO) LocalProfile
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO LocalProfile
getProfileById Connection
db GroupMemberId
userId GroupMemberId
profileId
              let p :: Profile
p = User -> Maybe Profile -> Maybe Contact -> Bool -> Profile
userProfileDirect User
user (LocalProfile -> Profile
fromLocalProfile (LocalProfile -> Profile) -> Maybe LocalProfile -> Maybe Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LocalProfile
incognitoProfile) (Contact -> Maybe Contact
forall a. a -> Maybe a
Just Contact
ct') Bool
True
              User -> Connection -> ByteString -> ChatMsgEvent 'Json -> CM ()
forall (e :: MsgEncoding).
MsgEncodingI e =>
User -> Connection -> ByteString -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync User
user Connection
conn'' ByteString
confId (ChatMsgEvent 'Json -> CM ()) -> ChatMsgEvent 'Json -> CM ()
forall a b. (a -> b) -> a -> b
$ Profile -> ChatMsgEvent 'Json
XInfo Profile
p
              CM Contact -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM Contact -> CM ()) -> CM Contact -> CM ()
forall a b. (a -> b) -> a -> b
$ (Connection -> IO Contact) -> CM Contact
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO Contact) -> CM Contact)
-> (Connection -> IO Contact) -> CM Contact
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> Contact -> IO Contact
resetMemberContactFields Connection
db Contact
ct'
            XGrpLinkInv GroupLinkInvitation
glInv -> do
              -- XGrpLinkInv here means we are connecting via business contact card, so we replace contact with group
              (GroupInfo
gInfo, GroupMember
host) <- (Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
-> CM (GroupInfo, GroupMember)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
 -> CM (GroupInfo, GroupMember))
-> (Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
-> CM (GroupInfo, GroupMember)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> GroupMemberId -> Contact -> IO ()
deleteContactCardKeepConn Connection
db GroupMemberId
connId Contact
ct
                Connection
-> VersionRangeChat
-> User
-> Connection
-> GroupLinkInvitation
-> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupInvitedViaLink Connection
db VersionRangeChat
vr User
user Connection
conn'' GroupLinkInvitation
glInv
              CM AChatItem -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM AChatItem -> CM ()) -> CM AChatItem -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> ChatDirection 'CTGroup 'MDSnd
-> Bool
-> CIContent 'MDSnd
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
createChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDSnd
CDGroupSnd GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing) Bool
False CIContent 'MDSnd
CIChatBanner Maybe SharedMsgId
forall a. Maybe a
Nothing (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
epochStart)
              -- [incognito] send saved profile
              Maybe LocalProfile
incognitoProfile <- Maybe GroupMemberId
-> (GroupMemberId
    -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe LocalProfile)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe GroupMemberId
customUserProfileId ((GroupMemberId
  -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe LocalProfile))
-> (GroupMemberId
    -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe LocalProfile)
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
pId -> (Connection -> ExceptT StoreError IO LocalProfile)
-> ExceptT ChatError (ReaderT ChatController IO) LocalProfile
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO LocalProfile
getProfileById Connection
db GroupMemberId
userId GroupMemberId
pId)
              let profileToSend :: Profile
profileToSend = User -> GroupInfo -> Maybe Profile -> Profile
userProfileInGroup User
user GroupInfo
gInfo (LocalProfile -> Profile
fromLocalProfile (LocalProfile -> Profile) -> Maybe LocalProfile -> Maybe Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LocalProfile
incognitoProfile)
              User -> Connection -> ByteString -> ChatMsgEvent 'Json -> CM ()
forall (e :: MsgEncoding).
MsgEncodingI e =>
User -> Connection -> ByteString -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync User
user Connection
conn'' ByteString
confId (ChatMsgEvent 'Json -> CM ()) -> ChatMsgEvent 'Json -> CM ()
forall a b. (a -> b) -> a -> b
$ Profile -> ChatMsgEvent 'Json
XInfo Profile
profileToSend
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> Contact -> ChatEvent
CEvtBusinessLinkConnecting User
user GroupInfo
gInfo GroupMember
host Contact
ct
            ChatMsgEvent 'Json
_ -> Text -> CM ()
messageError Text
"CONF for existing contact must have x.grp.mem.info or x.info"
        INFO PQSupport
pqSupport ByteString
connInfo -> do
          Connection -> PQSupport -> CM ()
processINFOpqSupport Connection
conn PQSupport
pqSupport
          ChatMessage {VersionRangeChat
chatVRange :: forall (e :: MsgEncoding). ChatMessage e -> VersionRangeChat
chatVRange :: VersionRangeChat
chatVRange, ChatMsgEvent 'Json
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent 'Json
chatMsgEvent} <- Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage Connection
conn ByteString
connInfo
          Connection
_conn' <- Connection
-> VersionRangeChat
-> ExceptT ChatError (ReaderT ChatController IO) Connection
updatePeerChatVRange Connection
conn VersionRangeChat
chatVRange
          case ChatMsgEvent 'Json
chatMsgEvent of
            XGrpMemInfo MemberId
_memId Profile
_memProfile -> do
              -- TODO check member ID
              -- TODO update member profile
              () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            XInfo Profile
profile -> do
              let prepared :: Bool
prepared = Maybe PreparedContact -> Bool
forall a. Maybe a -> Bool
isJust (Contact -> Maybe PreparedContact
preparedContact Contact
ct) Bool -> Bool -> Bool
|| Maybe GroupMemberId -> Bool
forall a. Maybe a -> Bool
isJust (Contact -> Maybe GroupMemberId
contactRequestId' Contact
ct)
              CM Contact -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM Contact -> CM ()) -> CM Contact -> CM ()
forall a b. (a -> b) -> a -> b
$ Contact -> Profile -> Bool -> CM Contact
processContactProfileUpdate Contact
ct Profile
profile Bool
prepared
            ChatMsgEvent 'Json
XOk -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ChatMsgEvent 'Json
_ -> Text -> CM ()
messageError Text
"INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
        CON PQEncryption
pqEnc -> do
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PQEncryption
pqEnc PQEncryption -> PQEncryption -> Bool
forall a. Eq a => a -> a -> Bool
== PQEncryption
PQEncOn) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> GroupMemberId -> PQEncryption -> IO ()
updateConnPQEnabledCON Connection
db GroupMemberId
connId PQEncryption
pqEnc
          let conn' :: Connection
conn' = Connection
conn {pqSndEnabled = Just pqEnc, pqRcvEnabled = Just pqEnc} :: Connection
              ct' :: Contact
ct' = Contact
ct {activeConn = Just conn'} :: Contact
          -- [incognito] print incognito profile used for this contact
          Maybe LocalProfile
incognitoProfile <- Maybe GroupMemberId
-> (GroupMemberId
    -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe LocalProfile)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe GroupMemberId
customUserProfileId ((GroupMemberId
  -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe LocalProfile))
-> (GroupMemberId
    -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe LocalProfile)
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
profileId -> (Connection -> ExceptT StoreError IO LocalProfile)
-> ExceptT ChatError (ReaderT ChatController IO) LocalProfile
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO LocalProfile
getProfileById Connection
db GroupMemberId
userId GroupMemberId
profileId)
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> Maybe Profile -> ChatEvent
CEvtContactConnected User
user Contact
ct' ((LocalProfile -> Profile) -> Maybe LocalProfile -> Maybe Profile
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalProfile -> Profile
fromLocalProfile Maybe LocalProfile
incognitoProfile)
          let createE2EItem :: CM ()
createE2EItem = User
-> ChatDirection 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct') (E2EInfo -> CIContent 'MDRcv
CIRcvDirectE2EEInfo (E2EInfo -> CIContent 'MDRcv) -> E2EInfo -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ Maybe PQEncryption -> E2EInfo
E2EInfo (Maybe PQEncryption -> E2EInfo) -> Maybe PQEncryption -> E2EInfo
forall a b. (a -> b) -> a -> b
$ PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just PQEncryption
pqEnc) Maybe UTCTime
forall a. Maybe a
Nothing
          -- TODO [short links] get contact request by contactRequestId, check encryption (UserContactRequest.pqSupport)?
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Contact -> Bool
directOrUsed Contact
ct') (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ case (Contact -> Maybe PreparedContact
preparedContact Contact
ct', Contact -> Maybe GroupMemberId
contactRequestId' Contact
ct') of
            (Maybe PreparedContact
Nothing, Maybe GroupMemberId
Nothing) -> do
              ExceptT ChatError (ReaderT ChatController IO) Bool
-> CM () -> CM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((Connection -> IO Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO Bool)
 -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> (Connection -> IO Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Contact -> IO Bool
checkContactHasItems Connection
db User
user Contact
ct') (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$
                User
-> ChatDirection 'CTDirect 'MDSnd
-> CIContent 'MDSnd
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectSnd Contact
ct') CIContent 'MDSnd
CIChatBanner (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
epochStart)
              CM ()
createE2EItem
              User -> Contact -> CM ()
createFeatureEnabledItems User
user Contact
ct'
            (Just PreparedContact {connLinkToConnect :: PreparedContact -> ACreatedConnLink
connLinkToConnect = ACCL SConnectionMode m
_ (CCLink ConnectionRequestUri m
cReq Maybe (ConnShortLink m)
_)}, Maybe GroupMemberId
_) ->
              Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just PQEncryption
pqEnc Maybe PQEncryption -> Maybe PQEncryption -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectionRequestUri m -> Maybe PQEncryption
forall (c :: ConnectionMode).
ConnectionRequestUri c -> Maybe PQEncryption
connRequestPQEncryption ConnectionRequestUri m
cReq) CM ()
createE2EItem
            (Maybe PreparedContact
_, Just GroupMemberId
connReqId) ->
              (Connection -> IO (Maybe UserContactRequest))
-> CM (Maybe UserContactRequest)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> Connection
-> User -> GroupMemberId -> IO (Maybe UserContactRequest)
getContactRequest' Connection
db User
user GroupMemberId
connReqId) CM (Maybe UserContactRequest)
-> (Maybe UserContactRequest -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just UserContactRequest {PQSupport
pqSupport :: PQSupport
pqSupport :: UserContactRequest -> PQSupport
pqSupport} | PQSupport -> PQEncryption
CR.pqSupportToEnc PQSupport
pqSupport PQEncryption -> PQEncryption -> Bool
forall a. Eq a => a -> a -> Bool
== PQEncryption
pqEnc -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                Maybe UserContactRequest
_ -> CM ()
createE2EItem
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Connection -> Bool
contactConnInitiated Connection
conn') (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
            Contact -> Bool -> CM ()
probeMatchingMembers Contact
ct' (Contact -> Bool
contactConnIncognito Contact
ct')
            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Connection -> IO ()
resetContactConnInitiated Connection
db User
user Connection
conn'
          Maybe GroupMemberId -> (GroupMemberId -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GroupMemberId
viaUserContactLink ((GroupMemberId -> CM ()) -> CM ())
-> (GroupMemberId -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
userContactLinkId -> do
            (UserContactLink
ucl, Maybe GroupLinkInfo
gli_) <- (Connection
 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo))
-> CM (UserContactLink, Maybe GroupLinkInfo)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection
  -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo))
 -> CM (UserContactLink, Maybe GroupLinkInfo))
-> (Connection
    -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo))
-> CM (UserContactLink, Maybe GroupLinkInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
getUserContactLinkById Connection
db GroupMemberId
userId GroupMemberId
userContactLinkId
            -- let UserContactLink {addressSettings = AddressSettings {autoReply}} = ucl
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version ChatVersion
connChatVersion Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
< Version ChatVersion
batchSend2Version) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Maybe MsgContent -> (MsgContent -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (AddressSettings -> Maybe MsgContent
autoReply (AddressSettings -> Maybe MsgContent)
-> AddressSettings -> Maybe MsgContent
forall a b. (a -> b) -> a -> b
$ UserContactLink -> AddressSettings
addressSettings UserContactLink
ucl) ((MsgContent -> CM ()) -> CM ()) -> (MsgContent -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \MsgContent
mc -> Contact -> MsgContent -> Maybe UserContactRequest -> CM ()
sendAutoReply Contact
ct' MsgContent
mc Maybe UserContactRequest
forall a. Maybe a
Nothing -- old versions only
            -- TODO REMOVE LEGACY vvv
            Maybe GroupLinkInfo -> (GroupLinkInfo -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GroupLinkInfo
gli_ ((GroupLinkInfo -> CM ()) -> CM ())
-> (GroupLinkInfo -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \GroupLinkInfo {GroupMemberId
groupId :: GroupMemberId
groupId :: GroupLinkInfo -> GroupMemberId
groupId, memberRole :: GroupLinkInfo -> GroupMemberRole
memberRole = GroupMemberRole
gLinkMemRole} -> do
              GroupInfo
groupInfo <- (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo)
-> (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO GroupInfo
getGroupInfo Connection
db VersionRangeChat
vr User
user GroupMemberId
groupId
              SubscriptionMode
subMode <- (ChatController -> TVar SubscriptionMode) -> CM SubscriptionMode
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar SubscriptionMode
subscriptionMode
              (GroupMemberId, ByteString)
groupConnIds <- User
-> CommandFunction
-> Bool
-> SConnectionMode 'CMInvitation
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
forall (c :: ConnectionMode).
ConnectionModeI c =>
User
-> CommandFunction
-> Bool
-> SConnectionMode c
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
createAgentConnectionAsync User
user CommandFunction
CFCreateConnGrpInv Bool
True SConnectionMode 'CMInvitation
SCMInvitation SubscriptionMode
subMode
              TVar ChaChaDRG
gVar <- (ChatController -> TVar ChaChaDRG)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar ChaChaDRG
random
              (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO ()) -> CM ())
-> (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> TVar ChaChaDRG
-> User
-> GroupInfo
-> Contact
-> GroupMemberRole
-> (GroupMemberId, ByteString)
-> Version ChatVersion
-> VersionRangeChat
-> SubscriptionMode
-> ExceptT StoreError IO ()
createNewContactMemberAsync Connection
db TVar ChaChaDRG
gVar User
user GroupInfo
groupInfo Contact
ct' GroupMemberRole
gLinkMemRole (GroupMemberId, ByteString)
groupConnIds Version ChatVersion
connChatVersion VersionRangeChat
peerChatVRange SubscriptionMode
subMode
            -- TODO REMOVE LEGACY ^^^
        SENT GroupMemberId
msgId Maybe SMPServer
proxy -> do
          ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ()
forall a b. (a -> b) -> a -> b
$ ConnectionEntity
-> Connection -> ExceptT ChatError (ReaderT ChatController IO) Bool
continueSending ConnectionEntity
connEntity Connection
conn
          Connection -> GroupMemberId -> CM ()
sentMsgDeliveryEvent Connection
conn GroupMemberId
msgId
          Connection -> GroupMemberId -> CM ()
checkSndInlineFTComplete Connection
conn GroupMemberId
msgId
          [ChatItem 'CTDirect 'MDSnd]
cis <- (Connection -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd])
-> CM [ChatItem 'CTDirect 'MDSnd]
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd])
 -> CM [ChatItem 'CTDirect 'MDSnd])
-> (Connection
    -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd])
-> CM [ChatItem 'CTDirect 'MDSnd]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
            [ChatItem 'CTDirect 'MDSnd]
cis <- Connection
-> Contact
-> Connection
-> GroupMemberId
-> CIStatus 'MDSnd
-> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
updateDirectItemsStatus' Connection
db Contact
ct Connection
conn GroupMemberId
msgId (SndCIStatusProgress -> CIStatus 'MDSnd
CISSndSent SndCIStatusProgress
SSPComplete)
            IO [ChatItem 'CTDirect 'MDSnd]
-> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ChatItem 'CTDirect 'MDSnd]
 -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd])
-> IO [ChatItem 'CTDirect 'MDSnd]
-> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
forall a b. (a -> b) -> a -> b
$ [ChatItem 'CTDirect 'MDSnd]
-> (ChatItem 'CTDirect 'MDSnd -> IO (ChatItem 'CTDirect 'MDSnd))
-> IO [ChatItem 'CTDirect 'MDSnd]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ChatItem 'CTDirect 'MDSnd]
cis ((ChatItem 'CTDirect 'MDSnd -> IO (ChatItem 'CTDirect 'MDSnd))
 -> IO [ChatItem 'CTDirect 'MDSnd])
-> (ChatItem 'CTDirect 'MDSnd -> IO (ChatItem 'CTDirect 'MDSnd))
-> IO [ChatItem 'CTDirect 'MDSnd]
forall a b. (a -> b) -> a -> b
$ \ChatItem 'CTDirect 'MDSnd
ci -> Connection
-> User
-> Contact
-> ChatItem 'CTDirect 'MDSnd
-> Bool
-> IO (ChatItem 'CTDirect 'MDSnd)
setDirectSndChatItemViaProxy Connection
db User
user Contact
ct ChatItem 'CTDirect 'MDSnd
ci (Maybe SMPServer -> Bool
forall a. Maybe a -> Bool
isJust Maybe SMPServer
proxy)
          let acis :: [AChatItem]
acis = (ChatItem 'CTDirect 'MDSnd -> AChatItem)
-> [ChatItem 'CTDirect 'MDSnd] -> [AChatItem]
forall a b. (a -> b) -> [a] -> [b]
map ChatItem 'CTDirect 'MDSnd -> AChatItem
ctItem [ChatItem 'CTDirect 'MDSnd]
cis
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([AChatItem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AChatItem]
acis) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtChatItemsStatusesUpdated User
user [AChatItem]
acis
          where
            ctItem :: ChatItem 'CTDirect 'MDSnd -> AChatItem
ctItem = SChatType 'CTDirect
-> SMsgDirection 'MDSnd
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDSnd
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDSnd
SMDSnd (Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct)
        SWITCH QueueDirection
qd SwitchPhase
phase ConnectionStats
cStats -> do
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> SwitchProgress -> ChatEvent
CEvtContactSwitch User
user Contact
ct (QueueDirection -> SwitchPhase -> ConnectionStats -> SwitchProgress
SwitchProgress QueueDirection
qd SwitchPhase
phase ConnectionStats
cStats)
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SwitchPhase
phase SwitchPhase -> SwitchPhase -> Bool
forall a. Eq a => a -> a -> Bool
== SwitchPhase
SPStarted Bool -> Bool -> Bool
|| SwitchPhase
phase SwitchPhase -> SwitchPhase -> Bool
forall a. Eq a => a -> a -> Bool
== SwitchPhase
SPCompleted) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ case QueueDirection
qd of
            QueueDirection
QDRcv -> User
-> ChatDirection 'CTDirect 'MDSnd
-> CIContent 'MDSnd
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectSnd Contact
ct) (SndConnEvent -> CIContent 'MDSnd
CISndConnEvent (SndConnEvent -> CIContent 'MDSnd)
-> SndConnEvent -> CIContent 'MDSnd
forall a b. (a -> b) -> a -> b
$ SwitchPhase -> Maybe GroupMemberRef -> SndConnEvent
SCESwitchQueue SwitchPhase
phase Maybe GroupMemberRef
forall a. Maybe a
Nothing) Maybe UTCTime
forall a. Maybe a
Nothing
            QueueDirection
QDSnd -> User
-> ChatDirection 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct) (RcvConnEvent -> CIContent 'MDRcv
CIRcvConnEvent (RcvConnEvent -> CIContent 'MDRcv)
-> RcvConnEvent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ SwitchPhase -> RcvConnEvent
RCESwitchQueue SwitchPhase
phase) Maybe UTCTime
forall a. Maybe a
Nothing
        RSYNC RatchetSyncState
rss Maybe AgentCryptoError
cryptoErr_ ConnectionStats
cStats ->
          case (RatchetSyncState
rss, Maybe SecurityCode
connectionCode, Maybe AgentCryptoError
cryptoErr_) of
            (RatchetSyncState
RSRequired, Maybe SecurityCode
_, Just AgentCryptoError
cryptoErr) -> AgentCryptoError -> CM ()
processErr AgentCryptoError
cryptoErr
            (RatchetSyncState
RSAllowed, Maybe SecurityCode
_, Just AgentCryptoError
cryptoErr) -> AgentCryptoError -> CM ()
processErr AgentCryptoError
cryptoErr
            (RatchetSyncState
RSAgreed, Just SecurityCode
_, Maybe AgentCryptoError
_) -> do
              (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> Maybe Text -> IO ()
setConnectionVerified Connection
db User
user GroupMemberId
connId Maybe Text
forall a. Maybe a
Nothing
              let ct' :: Contact
ct' = Contact
ct {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} :: Contact
              Contact -> CM ()
ratchetSyncEventItem Contact
ct'
              Contact -> CM ()
securityCodeChanged Contact
ct'
            (RatchetSyncState, Maybe SecurityCode, Maybe AgentCryptoError)
_ -> Contact -> CM ()
ratchetSyncEventItem Contact
ct
          where
            processErr :: AgentCryptoError -> CM ()
processErr AgentCryptoError
cryptoErr = do
              let e :: (MsgDecryptError, Word32)
e@(MsgDecryptError
mde, Word32
n) = AgentCryptoError -> (MsgDecryptError, Word32)
agentMsgDecryptError AgentCryptoError
cryptoErr
              Maybe (ChatItem 'CTDirect 'MDRcv)
ci_ <- (Connection
 -> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDRcv)))
-> CM (Maybe (ChatItem 'CTDirect 'MDRcv))
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection
  -> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDRcv)))
 -> CM (Maybe (ChatItem 'CTDirect 'MDRcv)))
-> (Connection
    -> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDRcv)))
-> CM (Maybe (ChatItem 'CTDirect 'MDRcv))
forall a b. (a -> b) -> a -> b
$ \Connection
db ->
                Connection
-> User
-> GroupMemberId
-> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItemLast Connection
db User
user GroupMemberId
contactId
                  ExceptT StoreError IO (CChatItem 'CTDirect)
-> (CChatItem 'CTDirect
    -> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDRcv)))
-> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDRcv))
forall a b.
ExceptT StoreError IO a
-> (a -> ExceptT StoreError IO b) -> ExceptT StoreError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe (ChatItem 'CTDirect 'MDRcv))
-> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDRcv))
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                    (IO (Maybe (ChatItem 'CTDirect 'MDRcv))
 -> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDRcv)))
-> (CChatItem 'CTDirect -> IO (Maybe (ChatItem 'CTDirect 'MDRcv)))
-> CChatItem 'CTDirect
-> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDRcv))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ChatItem 'CTDirect 'MDRcv, CIContent 'MDRcv)
 -> IO (ChatItem 'CTDirect 'MDRcv))
-> Maybe (ChatItem 'CTDirect 'MDRcv, CIContent 'MDRcv)
-> IO (Maybe (ChatItem 'CTDirect 'MDRcv))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (\(ChatItem 'CTDirect 'MDRcv
ci, CIContent 'MDRcv
content') -> Connection
-> User
-> GroupMemberId
-> ChatItem 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe GroupMemberId
-> IO (ChatItem 'CTDirect 'MDRcv)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupMemberId
-> ChatItem 'CTDirect d
-> CIContent d
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe GroupMemberId
-> IO (ChatItem 'CTDirect d)
updateDirectChatItem' Connection
db User
user GroupMemberId
contactId ChatItem 'CTDirect 'MDRcv
ci CIContent 'MDRcv
content' Bool
False Bool
False Maybe CITimed
forall a. Maybe a
Nothing Maybe GroupMemberId
forall a. Maybe a
Nothing)
                    (Maybe (ChatItem 'CTDirect 'MDRcv, CIContent 'MDRcv)
 -> IO (Maybe (ChatItem 'CTDirect 'MDRcv)))
-> (CChatItem 'CTDirect
    -> Maybe (ChatItem 'CTDirect 'MDRcv, CIContent 'MDRcv))
-> CChatItem 'CTDirect
-> IO (Maybe (ChatItem 'CTDirect 'MDRcv))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgDecryptError, Word32)
-> CChatItem 'CTDirect
-> Maybe (ChatItem 'CTDirect 'MDRcv, CIContent 'MDRcv)
forall (c :: ChatType).
(MsgDecryptError, Word32)
-> CChatItem c -> Maybe (ChatItem c 'MDRcv, CIContent 'MDRcv)
mdeUpdatedCI (MsgDecryptError, Word32)
e
              case Maybe (ChatItem 'CTDirect 'MDRcv)
ci_ of
                Just ChatItem 'CTDirect 'MDRcv
ci -> ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemUpdated User
user (SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv (Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct) ChatItem 'CTDirect 'MDRcv
ci)
                Maybe (ChatItem 'CTDirect 'MDRcv)
_ -> do
                  ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> RatchetSyncProgress -> ChatEvent
CEvtContactRatchetSync User
user Contact
ct (RatchetSyncState -> ConnectionStats -> RatchetSyncProgress
RatchetSyncProgress RatchetSyncState
rss ConnectionStats
cStats)
                  User
-> ChatDirection 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct) (MsgDecryptError -> Word32 -> CIContent 'MDRcv
CIRcvDecryptionError MsgDecryptError
mde Word32
n) Maybe UTCTime
forall a. Maybe a
Nothing
            ratchetSyncEventItem :: Contact -> CM ()
ratchetSyncEventItem Contact
ct' = do
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> RatchetSyncProgress -> ChatEvent
CEvtContactRatchetSync User
user Contact
ct' (RatchetSyncState -> ConnectionStats -> RatchetSyncProgress
RatchetSyncProgress RatchetSyncState
rss ConnectionStats
cStats)
              User
-> ChatDirection 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct') (RcvConnEvent -> CIContent 'MDRcv
CIRcvConnEvent (RcvConnEvent -> CIContent 'MDRcv)
-> RcvConnEvent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ RatchetSyncState -> RcvConnEvent
RCERatchetSync RatchetSyncState
rss) Maybe UTCTime
forall a. Maybe a
Nothing
        AEvent e
OK ->
          -- [async agent commands] continuation on receiving OK
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
corrId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData
_cmdData -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        -- TODO [certs rcv]
        JOINED Bool
sqSecured Maybe ClientServiceId
_serviceId ->
          -- [async agent commands] continuation on receiving JOINED
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
corrId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData
_cmdData ->
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Contact -> Bool
directOrUsed Contact
ct Bool -> Bool -> Bool
&& Bool
sqSecured) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> ChatEvent
CEvtContactSndReady User
user Contact
ct
              Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version ChatVersion
connChatVersion Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
batchSend2Version) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Maybe GroupMemberId -> (GroupMemberId -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe GroupMemberId
viaUserContactLink ((GroupMemberId -> CM ()) -> CM ())
-> (GroupMemberId -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
userContactLinkId -> do
                (UserContactLink
ucl, Maybe GroupLinkInfo
_) <- (Connection
 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo))
-> CM (UserContactLink, Maybe GroupLinkInfo)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection
  -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo))
 -> CM (UserContactLink, Maybe GroupLinkInfo))
-> (Connection
    -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo))
-> CM (UserContactLink, Maybe GroupLinkInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
getUserContactLinkById Connection
db GroupMemberId
userId GroupMemberId
userContactLinkId
                Maybe MsgContent -> (MsgContent -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (AddressSettings -> Maybe MsgContent
autoReply (AddressSettings -> Maybe MsgContent)
-> AddressSettings -> Maybe MsgContent
forall a b. (a -> b) -> a -> b
$ UserContactLink -> AddressSettings
addressSettings UserContactLink
ucl) ((MsgContent -> CM ()) -> CM ()) -> (MsgContent -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \MsgContent
mc -> do
                  Maybe UserContactRequest
connReq_ <- Maybe GroupMemberId
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe GroupMemberId)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact -> Maybe GroupMemberId
contactRequestId' Contact
ct) ExceptT ChatError (ReaderT ChatController IO) (Maybe GroupMemberId)
-> (GroupMemberId -> CM (Maybe UserContactRequest))
-> CM (Maybe UserContactRequest)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= \GroupMemberId
connReqId -> (Connection -> IO (Maybe UserContactRequest))
-> CM (Maybe UserContactRequest)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> Connection
-> User -> GroupMemberId -> IO (Maybe UserContactRequest)
getContactRequest' Connection
db User
user GroupMemberId
connReqId)
                  Contact -> MsgContent -> Maybe UserContactRequest -> CM ()
sendAutoReply Contact
ct MsgContent
mc Maybe UserContactRequest
connReq_
        AEvent e
QCONT ->
          ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) Bool -> CM ()
forall a b. (a -> b) -> a -> b
$ ConnectionEntity
-> Connection -> ExceptT ChatError (ReaderT ChatController IO) Bool
continueSending ConnectionEntity
connEntity Connection
conn
        MWARN GroupMemberId
msgId AgentErrorType
err -> do
          Contact -> Connection -> GroupMemberId -> CIStatus 'MDSnd -> CM ()
updateDirectItemStatus Contact
ct Connection
conn GroupMemberId
msgId (SndError -> CIStatus 'MDSnd
CISSndWarning (SndError -> CIStatus 'MDSnd) -> SndError -> CIStatus 'MDSnd
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> SndError
agentSndError AgentErrorType
err)
          ConnectionEntity -> Connection -> AgentErrorType -> CM ()
processConnMWARN ConnectionEntity
connEntity Connection
conn AgentErrorType
err
        MERR GroupMemberId
msgId AgentErrorType
err -> do
          Contact -> Connection -> GroupMemberId -> CIStatus 'MDSnd -> CM ()
updateDirectItemStatus Contact
ct Connection
conn GroupMemberId
msgId (SndError -> CIStatus 'MDSnd
CISSndError (SndError -> CIStatus 'MDSnd) -> SndError -> CIStatus 'MDSnd
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> SndError
agentSndError AgentErrorType
err)
          ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
err (ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) (ConnectionEntity -> Maybe ConnectionEntity
forall a. a -> Maybe a
Just ConnectionEntity
connEntity)
          ConnectionEntity -> Connection -> AgentErrorType -> CM ()
processConnMERR ConnectionEntity
connEntity Connection
conn AgentErrorType
err
        MERRS NonEmpty GroupMemberId
msgIds AgentErrorType
err -> do
          -- error cannot be AUTH error here
          Contact
-> Connection -> [GroupMemberId] -> CIStatus 'MDSnd -> CM ()
updateDirectItemsStatusMsgs Contact
ct Connection
conn (NonEmpty GroupMemberId -> [GroupMemberId]
forall a. NonEmpty a -> [a]
L.toList NonEmpty GroupMemberId
msgIds) (SndError -> CIStatus 'MDSnd
CISSndError (SndError -> CIStatus 'MDSnd) -> SndError -> CIStatus 'MDSnd
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> SndError
agentSndError AgentErrorType
err)
          ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
err (ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) (ConnectionEntity -> Maybe ConnectionEntity
forall a. a -> Maybe a
Just ConnectionEntity
connEntity)
        ERR AgentErrorType
err -> do
          ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
err (ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) (ConnectionEntity -> Maybe ConnectionEntity
forall a. a -> Maybe a
Just ConnectionEntity
connEntity)
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
corrId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData
_cmdData -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        -- TODO add debugging output
        AEvent e
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        sendAutoReply :: Contact -> MsgContent -> Maybe UserContactRequest -> CM ()
sendAutoReply Contact
ct MsgContent
mc = \case
          Just UserContactRequest {welcomeSharedMsgId :: UserContactRequest -> Maybe SharedMsgId
welcomeSharedMsgId = Just SharedMsgId
smId} ->
            ExceptT
  ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
-> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> Contact
-> ChatMsgEvent 'Json
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> ChatMsgEvent e
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
sendDirectContactMessage User
user Contact
ct (ChatMsgEvent 'Json
 -> ExceptT
      ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId))
-> ChatMsgEvent 'Json
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
forall a b. (a -> b) -> a -> b
$ SharedMsgId
-> MsgContent
-> Map Text MsgMention
-> Maybe Int
-> Maybe Bool
-> Maybe MsgScope
-> ChatMsgEvent 'Json
XMsgUpdate SharedMsgId
smId MsgContent
mc Map Text MsgMention
forall k a. Map k a
M.empty Maybe Int
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe MsgScope
forall a. Maybe a
Nothing
          Maybe UserContactRequest
_ -> do
            (SndMessage
msg, GroupMemberId
_) <- User
-> Contact
-> ChatMsgEvent 'Json
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> ChatMsgEvent e
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
sendDirectContactMessage User
user Contact
ct (ChatMsgEvent 'Json
 -> ExceptT
      ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId))
-> ChatMsgEvent 'Json
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
forall a b. (a -> b) -> a -> b
$ MsgContainer -> ChatMsgEvent 'Json
XMsgNew (MsgContainer -> ChatMsgEvent 'Json)
-> MsgContainer -> ChatMsgEvent 'Json
forall a b. (a -> b) -> a -> b
$ ExtMsgContent -> MsgContainer
MCSimple (ExtMsgContent -> MsgContainer) -> ExtMsgContent -> MsgContainer
forall a b. (a -> b) -> a -> b
$ MsgContent -> Maybe FileInvitation -> ExtMsgContent
extMsgContent MsgContent
mc Maybe FileInvitation
forall a. Maybe a
Nothing
            ChatItem 'CTDirect 'MDSnd
ci <- User
-> ChatDirection 'CTDirect 'MDSnd
-> SndMessage
-> CIContent 'MDSnd
-> CM (ChatItem 'CTDirect 'MDSnd)
forall (c :: ChatType).
ChatTypeI c =>
User
-> ChatDirection c 'MDSnd
-> SndMessage
-> CIContent 'MDSnd
-> CM (ChatItem c 'MDSnd)
saveSndChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectSnd Contact
ct) SndMessage
msg (MsgContent -> CIContent 'MDSnd
CISndMsgContent MsgContent
mc)
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [SChatType 'CTDirect
-> SMsgDirection 'MDSnd
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDSnd
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDSnd
SMDSnd (Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct) ChatItem 'CTDirect 'MDSnd
ci]

    processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> CM ()
    processGroupMessage :: forall (e :: AEntity).
AEvent e
-> ConnectionEntity
-> Connection
-> GroupInfo
-> GroupMember
-> CM ()
processGroupMessage AEvent e
agentMsg ConnectionEntity
connEntity conn :: Connection
conn@Connection {GroupMemberId
connId :: Connection -> GroupMemberId
connId :: GroupMemberId
connId, Version ChatVersion
connChatVersion :: Connection -> Version ChatVersion
connChatVersion :: Version ChatVersion
connChatVersion, Maybe GroupMemberId
customUserProfileId :: Connection -> Maybe GroupMemberId
customUserProfileId :: Maybe GroupMemberId
customUserProfileId, Maybe SecurityCode
connectionCode :: Connection -> Maybe SecurityCode
connectionCode :: Maybe SecurityCode
connectionCode} gInfo :: GroupInfo
gInfo@GroupInfo {GroupMemberId
groupId :: GroupInfo -> GroupMemberId
groupId :: GroupMemberId
groupId, GroupProfile
groupProfile :: GroupProfile
groupProfile :: GroupInfo -> GroupProfile
groupProfile, GroupMember
membership :: GroupMember
membership :: GroupInfo -> GroupMember
membership, ChatSettings
chatSettings :: ChatSettings
chatSettings :: GroupInfo -> ChatSettings
chatSettings} GroupMember
m = case AEvent e
agentMsg of
      -- TODO [certs rcv]
      INV (ACR SConnectionMode m
_ ConnectionRequestUri m
cReq) Maybe ClientServiceId
_serviceId ->
        Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData {CommandFunction
cmdFunction :: CommandFunction
cmdFunction :: CommandData -> CommandFunction
cmdFunction} ->
          case ConnectionRequestUri m
cReq of
            groupConnReq :: ConnectionRequestUri m
groupConnReq@(CRInvitationUri ConnReqUriData
_ RcvE2ERatchetParamsUri 'X448
_) -> case CommandFunction
cmdFunction of
              -- [async agent commands] XGrpMemIntro continuation on receiving INV
              CommandFunction
CFCreateConnGrpMemInv
                | VersionRangeChat -> Version ChatVersion
forall v. VersionRange v -> Version v
maxVersion (Connection -> VersionRangeChat
peerChatVRange Connection
conn) Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
groupDirectInvVersion -> CM ()
sendWithoutDirectCReq
                | Bool
otherwise -> Text -> CM ()
messageError Text
"processGroupMessage INV: member chat version range incompatible"
                where
                  sendWithoutDirectCReq :: CM ()
sendWithoutDirectCReq = do
                    let GroupMember {GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId :: GroupMember -> GroupMemberId
groupMemberId, MemberId
memberId :: MemberId
memberId :: GroupMember -> MemberId
memberId} = GroupMember
m
                    GroupMemberId
hostConnId <- (Connection -> ExceptT StoreError IO GroupMemberId)
-> CM GroupMemberId
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMemberId)
 -> CM GroupMemberId)
-> (Connection -> ExceptT StoreError IO GroupMemberId)
-> CM GroupMemberId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                      IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> User -> GroupMemberId -> ConnReqInvitation -> IO ()
setConnConnReqInv Connection
db User
user GroupMemberId
connId ConnectionRequestUri m
ConnReqInvitation
cReq
                      Connection
-> User -> GroupMemberId -> ExceptT StoreError IO GroupMemberId
getHostConnId Connection
db User
user GroupMemberId
groupId
                    GroupMemberId
-> Maybe ConnReqInvitation -> XGrpMemIntroCont -> CM ()
sendXGrpMemInv GroupMemberId
hostConnId Maybe ConnReqInvitation
forall a. Maybe a
Nothing XGrpMemIntroCont {GroupMemberId
groupId :: GroupMemberId
groupId :: GroupMemberId
groupId, GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId, MemberId
memberId :: MemberId
memberId :: MemberId
memberId, ConnectionRequestUri m
ConnReqInvitation
groupConnReq :: ConnectionRequestUri m
groupConnReq :: ConnReqInvitation
groupConnReq}
              -- TODO REMOVE LEGACY vvv
              -- [async agent commands] group link auto-accept continuation on receiving INV
              CommandFunction
CFCreateConnGrpInv -> do
                Contact
ct <- (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO Contact) -> CM Contact)
-> (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMember
-> ExceptT StoreError IO Contact
getContactViaMember Connection
db VersionRangeChat
vr User
user GroupMember
m
                (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMember -> ConnReqInvitation -> IO ()
setNewContactMemberConnRequest Connection
db User
user GroupMember
m ConnectionRequestUri m
ConnReqInvitation
cReq
                Maybe GroupLinkId
groupLinkId <- (Connection -> IO (Maybe GroupLinkId)) -> CM (Maybe GroupLinkId)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (Maybe GroupLinkId)) -> CM (Maybe GroupLinkId))
-> (Connection -> IO (Maybe GroupLinkId)) -> CM (Maybe GroupLinkId)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupInfo -> IO (Maybe GroupLinkId)
getGroupLinkId Connection
db User
user GroupInfo
gInfo
                Contact -> GroupMember -> Maybe GroupLinkId -> CM ()
sendGrpInvitation Contact
ct GroupMember
m Maybe GroupLinkId
groupLinkId
                ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> Contact -> GroupMember -> ChatEvent
CEvtSentGroupInvitation User
user GroupInfo
gInfo Contact
ct GroupMember
m
                where
                  sendGrpInvitation :: Contact -> GroupMember -> Maybe GroupLinkId -> CM ()
                  sendGrpInvitation :: Contact -> GroupMember -> Maybe GroupLinkId -> CM ()
sendGrpInvitation Contact
ct GroupMember {MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId, memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
memRole} Maybe GroupLinkId
groupLinkId = do
                    Int
currentMemCount <- (Connection -> IO Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO Int)
 -> ExceptT ChatError (ReaderT ChatController IO) Int)
-> (Connection -> IO Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupInfo -> IO Int
getGroupCurrentMembersCount Connection
db User
user GroupInfo
gInfo
                    let GroupMember {memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
userRole, memberId :: GroupMember -> MemberId
memberId = MemberId
userMemberId} = GroupMember
membership
                        groupInv :: GroupInvitation
groupInv =
                          GroupInvitation
                            { fromMember :: MemberIdRole
fromMember = MemberId -> GroupMemberRole -> MemberIdRole
MemberIdRole MemberId
userMemberId GroupMemberRole
userRole,
                              invitedMember :: MemberIdRole
invitedMember = MemberId -> GroupMemberRole -> MemberIdRole
MemberIdRole MemberId
memberId GroupMemberRole
memRole,
                              connRequest :: ConnReqInvitation
connRequest = ConnectionRequestUri m
ConnReqInvitation
cReq,
                              GroupProfile
groupProfile :: GroupProfile
groupProfile :: GroupProfile
groupProfile,
                              business :: Maybe BusinessChatInfo
business = Maybe BusinessChatInfo
forall a. Maybe a
Nothing,
                              groupLinkId :: Maybe GroupLinkId
groupLinkId = Maybe GroupLinkId
groupLinkId,
                              groupSize :: Maybe Int
groupSize = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
currentMemCount
                            }
                    (SndMessage
_msg, GroupMemberId
_) <- User
-> Contact
-> ChatMsgEvent 'Json
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> ChatMsgEvent e
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
sendDirectContactMessage User
user Contact
ct (ChatMsgEvent 'Json
 -> ExceptT
      ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId))
-> ChatMsgEvent 'Json
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
forall a b. (a -> b) -> a -> b
$ GroupInvitation -> ChatMsgEvent 'Json
XGrpInv GroupInvitation
groupInv
                    -- we could link chat item with sent group invitation message (_msg)
                    User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing GroupMember
m) (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
RGEInvitedViaGroupLink) Maybe UTCTime
forall a. Maybe a
Nothing
              -- TODO REMOVE LEGACY ^^^
              CommandFunction
_ -> ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CECommandError String
"unexpected cmdFunction"
            CRContactUri ConnReqUriData
_ -> ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CECommandError String
"unexpected ConnectionRequestUri type"
      CONF ByteString
confId PQSupport
_pqSupport [SMPServer]
_ ByteString
connInfo -> do
        ChatMessage {VersionRangeChat
chatVRange :: forall (e :: MsgEncoding). ChatMessage e -> VersionRangeChat
chatVRange :: VersionRangeChat
chatVRange, ChatMsgEvent 'Json
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent 'Json
chatMsgEvent} <- Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage Connection
conn ByteString
connInfo
        Connection
conn' <- Connection
-> VersionRangeChat
-> ExceptT ChatError (ReaderT ChatController IO) Connection
updatePeerChatVRange Connection
conn VersionRangeChat
chatVRange
        case GroupMember -> GroupMemberCategory
memberCategory GroupMember
m of
          GroupMemberCategory
GCInviteeMember ->
            case ChatMsgEvent 'Json
chatMsgEvent of
              XGrpAcpt MemberId
memId
                | MemberId -> GroupMember -> Bool
sameMemberId MemberId
memId GroupMember
m -> do
                    (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO ()) -> CM ())
-> (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection
-> GroupMemberId -> GroupMember -> GroupMemberStatus -> IO ()
updateGroupMemberStatus Connection
db GroupMemberId
userId GroupMember
m GroupMemberStatus
GSMemAccepted
                    -- [async agent commands] no continuation needed, but command should be asynchronous for stability
                    User -> Connection -> ByteString -> ChatMsgEvent 'Json -> CM ()
forall (e :: MsgEncoding).
MsgEncodingI e =>
User -> Connection -> ByteString -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync User
user Connection
conn' ByteString
confId ChatMsgEvent 'Json
XOk
                | Bool
otherwise -> Text -> CM ()
messageError Text
"x.grp.acpt: memberId is different from expected"
              ChatMsgEvent 'Json
_ -> Text -> CM ()
messageError Text
"CONF from invited member must have x.grp.acpt"
          GroupMemberCategory
GCHostMember ->
            case ChatMsgEvent 'Json
chatMsgEvent of
              XGrpLinkInv GroupLinkInvitation
glInv -> do
                -- XGrpLinkInv here means we are connecting via prepared group, and we have to update user and host member records
                (GroupInfo
gInfo', GroupMember
m') <- (Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
-> CM (GroupInfo, GroupMember)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
 -> CM (GroupInfo, GroupMember))
-> (Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
-> CM (GroupInfo, GroupMember)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> GroupMember
-> GroupLinkInvitation
-> ExceptT StoreError IO (GroupInfo, GroupMember)
updatePreparedUserAndHostMembersInvited Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo GroupMember
m GroupLinkInvitation
glInv
                -- [incognito] send saved profile
                Maybe LocalProfile
incognitoProfile <- Maybe GroupMemberId
-> (GroupMemberId
    -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe LocalProfile)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe GroupMemberId
customUserProfileId ((GroupMemberId
  -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe LocalProfile))
-> (GroupMemberId
    -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe LocalProfile)
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
pId -> (Connection -> ExceptT StoreError IO LocalProfile)
-> ExceptT ChatError (ReaderT ChatController IO) LocalProfile
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO LocalProfile
getProfileById Connection
db GroupMemberId
userId GroupMemberId
pId)
                let profileToSend :: Profile
profileToSend = User -> GroupInfo -> Maybe Profile -> Profile
userProfileInGroup User
user GroupInfo
gInfo (LocalProfile -> Profile
fromLocalProfile (LocalProfile -> Profile) -> Maybe LocalProfile -> Maybe Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LocalProfile
incognitoProfile)
                User -> Connection -> ByteString -> ChatMsgEvent 'Json -> CM ()
forall (e :: MsgEncoding).
MsgEncodingI e =>
User -> Connection -> ByteString -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync User
user Connection
conn' ByteString
confId (ChatMsgEvent 'Json -> CM ()) -> ChatMsgEvent 'Json -> CM ()
forall a b. (a -> b) -> a -> b
$ Profile -> ChatMsgEvent 'Json
XInfo Profile
profileToSend
                ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> ChatEvent
CEvtGroupLinkConnecting User
user GroupInfo
gInfo' GroupMember
m'
              XGrpLinkReject glRjct :: GroupLinkRejection
glRjct@GroupLinkRejection {GroupRejectionReason
rejectionReason :: GroupRejectionReason
rejectionReason :: GroupLinkRejection -> GroupRejectionReason
rejectionReason} -> do
                (GroupInfo
gInfo', GroupMember
m') <- (Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
-> CM (GroupInfo, GroupMember)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
 -> CM (GroupInfo, GroupMember))
-> (Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
-> CM (GroupInfo, GroupMember)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> GroupMember
-> GroupLinkRejection
-> ExceptT StoreError IO (GroupInfo, GroupMember)
updatePreparedUserAndHostMembersRejected Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo GroupMember
m GroupLinkRejection
glRjct
                ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> ChatEvent
CEvtGroupLinkConnecting User
user GroupInfo
gInfo' GroupMember
m'
                TerminalEvent -> CM ()
toViewTE (TerminalEvent -> CM ()) -> TerminalEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupRejectionReason -> TerminalEvent
TEGroupLinkRejected User
user GroupInfo
gInfo' GroupRejectionReason
rejectionReason
              ChatMsgEvent 'Json
_ -> Text -> CM ()
messageError Text
"CONF from host member in prepared group must have x.grp.link.inv or x.grp.link.reject"
          GroupMemberCategory
_ ->
            case ChatMsgEvent 'Json
chatMsgEvent of
              XGrpMemInfo MemberId
memId Profile
_memProfile
                | MemberId -> GroupMember -> Bool
sameMemberId MemberId
memId GroupMember
m -> do
                    let GroupMember {memberId :: GroupMember -> MemberId
memberId = MemberId
membershipMemId} = GroupMember
membership
                        allowSimplexLinks :: Bool
allowSimplexLinks = SGroupFeature 'GFSimplexLinks -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupInfo -> Bool
groupFeatureUserAllowed SGroupFeature 'GFSimplexLinks
SGFSimplexLinks GroupInfo
gInfo
                        membershipProfile :: Profile
membershipProfile = Bool -> Profile -> Profile
redactedMemberProfile Bool
allowSimplexLinks (Profile -> Profile) -> Profile -> Profile
forall a b. (a -> b) -> a -> b
$ LocalProfile -> Profile
fromLocalProfile (LocalProfile -> Profile) -> LocalProfile -> Profile
forall a b. (a -> b) -> a -> b
$ GroupMember -> LocalProfile
memberProfile GroupMember
membership
                    -- TODO update member profile
                    -- [async agent commands] no continuation needed, but command should be asynchronous for stability
                    User -> Connection -> ByteString -> ChatMsgEvent 'Json -> CM ()
forall (e :: MsgEncoding).
MsgEncodingI e =>
User -> Connection -> ByteString -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync User
user Connection
conn' ByteString
confId (ChatMsgEvent 'Json -> CM ()) -> ChatMsgEvent 'Json -> CM ()
forall a b. (a -> b) -> a -> b
$ MemberId -> Profile -> ChatMsgEvent 'Json
XGrpMemInfo MemberId
membershipMemId Profile
membershipProfile
                | Bool
otherwise -> Text -> CM ()
messageError Text
"x.grp.mem.info: memberId is different from expected"
              ChatMsgEvent 'Json
_ -> Text -> CM ()
messageError Text
"CONF from member must have x.grp.mem.info"
      INFO PQSupport
_pqSupport ByteString
connInfo -> do
        ChatMessage {VersionRangeChat
chatVRange :: forall (e :: MsgEncoding). ChatMessage e -> VersionRangeChat
chatVRange :: VersionRangeChat
chatVRange, ChatMsgEvent 'Json
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent 'Json
chatMsgEvent} <- Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage Connection
conn ByteString
connInfo
        Connection
_conn' <- Connection
-> VersionRangeChat
-> ExceptT ChatError (ReaderT ChatController IO) Connection
updatePeerChatVRange Connection
conn VersionRangeChat
chatVRange
        case ChatMsgEvent 'Json
chatMsgEvent of
          XGrpMemInfo MemberId
memId Profile
_memProfile
            | MemberId -> GroupMember -> Bool
sameMemberId MemberId
memId GroupMember
m -> do
                -- TODO update member profile
                () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            | Bool
otherwise -> Text -> CM ()
messageError Text
"x.grp.mem.info: memberId is different from expected"
          -- sent when connecting via group link
          XInfo Profile
_ ->
            -- TODO Keep rejected member to allow them to appeal against rejection.
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupMember -> GroupMemberStatus
memberStatus GroupMember
m GroupMemberStatus -> GroupMemberStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberStatus
GSMemRejected) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
              GroupMember -> Bool -> CM ()
deleteMemberConnection' GroupMember
m Bool
True
              (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMember -> IO ()
deleteGroupMember Connection
db User
user GroupMember
m
          ChatMsgEvent 'Json
XOk -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ChatMsgEvent 'Json
_ -> Text -> CM ()
messageError Text
"INFO from member must have x.grp.mem.info, x.info or x.ok"
        () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      CON PQEncryption
_pqEnc -> Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupMember -> GroupMemberStatus
memberStatus GroupMember
m GroupMemberStatus -> GroupMemberStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberStatus
GSMemRejected Bool -> Bool -> Bool
|| GroupMember -> GroupMemberStatus
memberStatus GroupMember
membership GroupMemberStatus -> GroupMemberStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberStatus
GSMemRejected) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
        -- TODO [knocking] send pending messages after accepting?
        -- possible improvement: check for each pending message, requires keeping track of connection state
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Connection -> Bool
connDisabled Connection
conn) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupMember -> Connection -> CM ()
sendPendingGroupMessages User
user GroupMember
m Connection
conn
        (AgentClient -> ExceptT AgentErrorType IO ()) -> CM ()
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ()) -> CM ())
-> (AgentClient -> ExceptT AgentErrorType IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient -> ByteString -> Bool -> ExceptT AgentErrorType IO ()
toggleConnectionNtfs AgentClient
a (Connection -> ByteString
aConnId Connection
conn) (Bool -> ExceptT AgentErrorType IO ())
-> Bool -> ExceptT AgentErrorType IO ()
forall a b. (a -> b) -> a -> b
$ ChatSettings -> Bool
chatHasNtfs ChatSettings
chatSettings
        case GroupMember -> GroupMemberCategory
memberCategory GroupMember
m of
          GroupMemberCategory
GCHostMember -> do
            (GroupMember
m', GroupInfo
gInfo') <- (Connection -> IO (GroupMember, GroupInfo))
-> CM (GroupMember, GroupInfo)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (GroupMember, GroupInfo))
 -> CM (GroupMember, GroupInfo))
-> (Connection -> IO (GroupMember, GroupInfo))
-> CM (GroupMember, GroupInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
              Connection
-> GroupMemberId -> GroupMember -> GroupMemberStatus -> IO ()
updateGroupMemberStatus Connection
db GroupMemberId
userId GroupMember
m GroupMemberStatus
GSMemConnected
              GroupInfo
gInfo' <-
                if Bool -> Bool
not (GroupMember -> Bool
memberPending GroupMember
membership)
                  then do
                    Connection
-> GroupMemberId -> GroupMember -> GroupMemberStatus -> IO ()
updateGroupMemberStatus Connection
db GroupMemberId
userId GroupMember
membership GroupMemberStatus
GSMemConnected
                    GroupInfo -> IO GroupInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupInfo
gInfo {membership = membership {memberStatus = GSMemConnected}}
                  else GroupInfo -> IO GroupInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupInfo
gInfo
              (GroupMember, GroupInfo) -> IO (GroupMember, GroupInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMember
m {memberStatus = GSMemConnected}, GroupInfo
gInfo')
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> ChatEvent
CEvtUserJoinedGroup User
user GroupInfo
gInfo' GroupMember
m'
            (GroupInfo
gInfo'', GroupMember
m'', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo' GroupMember
m'
            let cd :: ChatDirection 'CTGroup 'MDRcv
cd = GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo'' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m''
            User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user ChatDirection 'CTGroup 'MDRcv
cd (E2EInfo -> CIContent 'MDRcv
CIRcvGroupE2EEInfo E2EInfo {pqEnabled :: Maybe PQEncryption
pqEnabled = PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just PQEncryption
PQEncOff}) Maybe UTCTime
forall a. Maybe a
Nothing
            let prepared :: Maybe PreparedGroup
prepared = GroupInfo -> Maybe PreparedGroup
preparedGroup GroupInfo
gInfo''
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe PreparedGroup -> Bool
forall a. Maybe a -> Bool
isJust Maybe PreparedGroup
prepared) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> ChatDirection 'CTGroup 'MDRcv
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent 'MDRcv)
-> GroupInfo
-> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> ChatDirection 'CTGroup d
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent d)
-> GroupInfo
-> CM ()
createGroupFeatureItems User
user ChatDirection 'CTGroup 'MDRcv
cd GroupFeature
-> GroupPreference
-> Maybe Int
-> Maybe GroupMemberRole
-> CIContent 'MDRcv
CIRcvGroupFeature GroupInfo
gInfo''
            GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM ()
memberConnectedChatItem GroupInfo
gInfo'' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m''
            let welcomeMsgId_ :: Maybe (Maybe SharedMsgId)
welcomeMsgId_ = (\PreparedGroup {welcomeSharedMsgId :: PreparedGroup -> Maybe SharedMsgId
welcomeSharedMsgId = Maybe SharedMsgId
mId} -> Maybe SharedMsgId
mId) (PreparedGroup -> Maybe SharedMsgId)
-> Maybe PreparedGroup -> Maybe (Maybe SharedMsgId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PreparedGroup
prepared
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupMember -> Bool
memberPending GroupMember
membership Bool -> Bool -> Bool
|| Maybe (Maybe SharedMsgId) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Maybe SharedMsgId)
welcomeMsgId_) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo -> GroupMember -> CM ()
maybeCreateGroupDescrLocal GroupInfo
gInfo'' GroupMember
m''
          GroupMemberCategory
GCInviteeMember -> do
            (GroupInfo
gInfo', GroupMemberStatus
mStatus) <-
              if Bool -> Bool
not (GroupMember -> Bool
memberPending GroupMember
m)
                then do
                  GroupMemberStatus
mStatus <- (Connection -> IO GroupMemberStatus) -> CM GroupMemberStatus
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO GroupMemberStatus) -> CM GroupMemberStatus)
-> (Connection -> IO GroupMemberStatus) -> CM GroupMemberStatus
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> GroupMember -> GroupMemberStatus -> IO ()
updateGroupMemberStatus Connection
db GroupMemberId
userId GroupMember
m GroupMemberStatus
GSMemConnected IO () -> GroupMemberStatus -> IO GroupMemberStatus
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> GroupMemberStatus
GSMemConnected
                  (GroupInfo, GroupMemberStatus)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (GroupInfo, GroupMemberStatus)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo, GroupMemberStatus
mStatus)
                else do
                  GroupInfo
gInfo' <- (Connection -> IO GroupInfo) -> CM GroupInfo
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO GroupInfo) -> CM GroupInfo)
-> (Connection -> IO GroupInfo) -> CM GroupInfo
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupInfo -> IO GroupInfo
increaseGroupMembersRequireAttention Connection
db User
user GroupInfo
gInfo
                  (GroupInfo, GroupMemberStatus)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (GroupInfo, GroupMemberStatus)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo', GroupMember -> GroupMemberStatus
memberStatus GroupMember
m)
            (GroupInfo
gInfo'', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo' GroupMember
m
            GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM ()
memberConnectedChatItem GroupInfo
gInfo'' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m'
            case Maybe GroupChatScopeInfo
scopeInfo of
              Just (GCSIMemberSupport Maybe GroupMember
_) -> do
                User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo'' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
RGENewMemberPendingReview) Maybe UTCTime
forall a. Maybe a
Nothing
              Maybe GroupChatScopeInfo
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> ChatEvent
CEvtJoinedGroupMember User
user GroupInfo
gInfo'' GroupMember
m' {memberStatus = mStatus}
            let Connection {Maybe GroupMemberId
viaUserContactLink :: Connection -> Maybe GroupMemberId
viaUserContactLink :: Maybe GroupMemberId
viaUserContactLink} = Connection
conn
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe GroupMemberId -> Bool
forall a. Maybe a -> Bool
isJust Maybe GroupMemberId
viaUserContactLink Bool -> Bool -> Bool
&& Maybe GroupMemberId -> Bool
forall a. Maybe a -> Bool
isNothing (GroupMember -> Maybe GroupMemberId
memberContactId GroupMember
m')) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo -> CM ()
sendXGrpLinkMem GroupInfo
gInfo''
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version ChatVersion
connChatVersion Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
< Version ChatVersion
batchSend2Version) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ExceptT ChatError (ReaderT ChatController IO) (Maybe MsgContent)
getAutoReplyMsg ExceptT ChatError (ReaderT ChatController IO) (Maybe MsgContent)
-> (Maybe MsgContent -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (MsgContent -> CM ()) -> Maybe MsgContent -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\MsgContent
mc -> MsgContent -> Maybe UserContactRequest -> CM ()
sendGroupAutoReply MsgContent
mc Maybe UserContactRequest
forall a. Maybe a
Nothing)
            case GroupMemberStatus
mStatus of
              GroupMemberStatus
GSMemPendingApproval -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              GroupMemberStatus
GSMemPendingReview -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
introduceToModerators VersionRangeChat
vr User
user GroupInfo
gInfo'' GroupMember
m'
              GroupMemberStatus
_ -> do
                VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
introduceToAll VersionRangeChat
vr User
user GroupInfo
gInfo'' GroupMember
m'
                let memberIsCustomer :: Bool
memberIsCustomer = case GroupInfo -> Maybe BusinessChatInfo
businessChat GroupInfo
gInfo'' of
                      Just BusinessChatInfo {chatType :: BusinessChatInfo -> BusinessChatType
chatType = BusinessChatType
BCCustomer, MemberId
customerId :: MemberId
customerId :: BusinessChatInfo -> MemberId
customerId} -> GroupMember -> MemberId
memberId' GroupMember
m' MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== MemberId
customerId
                      Maybe BusinessChatInfo
_ -> Bool
False
                Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SGroupFeature 'GFHistory -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureNoRoleI f =>
SGroupFeature f -> GroupInfo -> Bool
groupFeatureAllowed SGroupFeature 'GFHistory
SGFHistory GroupInfo
gInfo'' Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
memberIsCustomer) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> CM ()
sendHistory User
user GroupInfo
gInfo'' GroupMember
m'
            where
              sendXGrpLinkMem :: GroupInfo -> CM ()
sendXGrpLinkMem GroupInfo
gInfo'' = do
                let incognitoProfile :: Maybe IncognitoProfile
incognitoProfile = LocalProfile -> IncognitoProfile
ExistingIncognito (LocalProfile -> IncognitoProfile)
-> Maybe LocalProfile -> Maybe IncognitoProfile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GroupInfo -> Maybe LocalProfile
incognitoMembershipProfile GroupInfo
gInfo''
                    profileToSend :: Profile
profileToSend = User -> GroupInfo -> Maybe Profile -> Profile
userProfileInGroup User
user GroupInfo
gInfo (IncognitoProfile -> Profile
fromIncognitoProfile (IncognitoProfile -> Profile)
-> Maybe IncognitoProfile -> Maybe Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe IncognitoProfile
incognitoProfile)
                ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, GroupMemberId, PQEncryption)
 -> CM ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
sendDirectMemberMessage Connection
conn (Profile -> ChatMsgEvent 'Json
XGrpLinkMem Profile
profileToSend) GroupMemberId
groupId
          GroupMemberCategory
_ -> do
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupMember -> Bool
memberPending GroupMember
m) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> GroupMember -> GroupMemberStatus -> IO ()
updateGroupMemberStatus Connection
db GroupMemberId
userId GroupMember
m GroupMemberStatus
GSMemConnected
            GroupInfo -> GroupMember -> Maybe Contact -> CM ()
notifyMemberConnected GroupInfo
gInfo GroupMember
m Maybe Contact
forall a. Maybe a
Nothing
            let memCategory :: GroupMemberCategory
memCategory = GroupMember -> GroupMemberCategory
memberCategory GroupMember
m
                connectedIncognito :: Bool
connectedIncognito = GroupMember -> Bool
memberIncognito GroupMember
membership
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupMemberCategory
memCategory GroupMemberCategory -> GroupMemberCategory -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberCategory
GCPreMember) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$
              GroupMember -> Bool -> CM ()
probeMatchingMemberContact GroupMember
m Bool
connectedIncognito
            GroupMemberCategory -> CM ()
sendXGrpMemCon GroupMemberCategory
memCategory
            where
              GroupMember {MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId} = GroupMember
m
              sendXGrpMemCon :: GroupMemberCategory -> CM ()
sendXGrpMemCon = \case
                GroupMemberCategory
GCPreMember ->
                  Maybe GroupMemberId -> (GroupMemberId -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GroupMember -> Maybe GroupMemberId
invitedByGroupMemberId GroupMember
membership) ((GroupMemberId -> CM ()) -> CM ())
-> (GroupMemberId -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
hostId -> do
                    GroupMember
host <- (Connection -> ExceptT StoreError IO GroupMember) -> CM GroupMember
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMember)
 -> CM GroupMember)
-> (Connection -> ExceptT StoreError IO GroupMember)
-> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO GroupMember
getGroupMember Connection
db VersionRangeChat
vr User
user GroupMemberId
groupId GroupMemberId
hostId
                    Maybe Connection -> (Connection -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GroupMember -> Maybe Connection
memberConn GroupMember
host) ((Connection -> CM ()) -> CM ()) -> (Connection -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
hostConn ->
                      ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, GroupMemberId, PQEncryption)
 -> CM ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
sendDirectMemberMessage Connection
hostConn (MemberId -> ChatMsgEvent 'Json
XGrpMemCon MemberId
memberId) GroupMemberId
groupId
                GroupMemberCategory
GCPostMember ->
                  Maybe GroupMemberId -> (GroupMemberId -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GroupMember -> Maybe GroupMemberId
invitedByGroupMemberId GroupMember
m) ((GroupMemberId -> CM ()) -> CM ())
-> (GroupMemberId -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
invitingMemberId -> do
                    GroupMember
im <- (Connection -> ExceptT StoreError IO GroupMember) -> CM GroupMember
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMember)
 -> CM GroupMember)
-> (Connection -> ExceptT StoreError IO GroupMember)
-> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO GroupMember
getGroupMember Connection
db VersionRangeChat
vr User
user GroupMemberId
groupId GroupMemberId
invitingMemberId
                    Maybe Connection -> (Connection -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GroupMember -> Maybe Connection
memberConn GroupMember
im) ((Connection -> CM ()) -> CM ()) -> (Connection -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
imConn ->
                      ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, GroupMemberId, PQEncryption)
 -> CM ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
sendDirectMemberMessage Connection
imConn (MemberId -> ChatMsgEvent 'Json
XGrpMemCon MemberId
memberId) GroupMemberId
groupId
                GroupMemberCategory
_ -> Text -> CM ()
messageWarning Text
"sendXGrpMemCon: member category GCPreMember or GCPostMember is expected"
      MSG MsgMeta
msgMeta MsgFlags
_msgFlags ByteString
msgBody -> do
        TVar [Text]
tags <- [Text]
-> ExceptT ChatError (ReaderT ChatController IO) (TVar [Text])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
        Text
-> ByteString
-> MsgMeta
-> Bool
-> Maybe (TVar [Text])
-> (Text -> CM (Bool, Bool))
-> CM ()
withAckMessage Text
"group msg" ByteString
agentConnId MsgMeta
msgMeta Bool
True (TVar [Text] -> Maybe (TVar [Text])
forall a. a -> Maybe a
Just TVar [Text]
tags) ((Text -> CM (Bool, Bool)) -> CM ())
-> (Text -> CM (Bool, Bool)) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Text
eInfo -> do
          -- possible improvement is to choose scope based on event (some events specify scope)
          (GroupInfo
gInfo', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo GroupMember
m
          ChatDirection 'CTGroup 'MDRcv -> MsgMeta -> CM ()
forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv -> MsgMeta -> CM ()
checkIntegrityCreateItem (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') MsgMeta
msgMeta CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          [NewMessageDeliveryTask]
newDeliveryTasks <- [NewMessageDeliveryTask] -> [NewMessageDeliveryTask]
forall a. [a] -> [a]
reverse ([NewMessageDeliveryTask] -> [NewMessageDeliveryTask])
-> ExceptT
     ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask]
-> ExceptT
     ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([NewMessageDeliveryTask]
 -> Either String AChatMessage
 -> ExceptT
      ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask])
-> [NewMessageDeliveryTask]
-> [Either String AChatMessage]
-> ExceptT
     ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (GroupInfo
-> GroupMember
-> TVar [Text]
-> Text
-> [NewMessageDeliveryTask]
-> Either String AChatMessage
-> ExceptT
     ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask]
processAChatMsg GroupInfo
gInfo' GroupMember
m' TVar [Text]
tags Text
eInfo) [] [Either String AChatMessage]
aChatMsgs
          Bool
shouldDelConns <-
            if GroupInfo -> Bool
isUserGrpFwdRelay GroupInfo
gInfo' Bool -> Bool -> Bool
&& Bool -> Bool
not (GroupMember -> Bool
blockedByAdmin GroupMember
m)
              then GroupInfo
-> GroupMember
-> [NewMessageDeliveryTask]
-> ExceptT ChatError (ReaderT ChatController IO) Bool
createDeliveryTasks GroupInfo
gInfo' GroupMember
m' [NewMessageDeliveryTask]
newDeliveryTasks
              else Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          Bool
withRcpt <- [AChatMessage]
-> ExceptT ChatError (ReaderT ChatController IO) Bool
checkSendRcpt ([AChatMessage]
 -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> [AChatMessage]
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a b. (a -> b) -> a -> b
$ [Either String AChatMessage] -> [AChatMessage]
forall a b. [Either a b] -> [b]
rights [Either String AChatMessage]
aChatMsgs
          (Bool, Bool) -> CM (Bool, Bool)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
withRcpt, Bool
shouldDelConns)
        where
          aChatMsgs :: [Either String AChatMessage]
aChatMsgs = ByteString -> [Either String AChatMessage]
parseChatMessages ByteString
msgBody
          brokerTs :: UTCTime
brokerTs = MsgMeta -> UTCTime
metaBrokerTs MsgMeta
msgMeta
          processAChatMsg ::
            GroupInfo
            -> GroupMember
            -> TVar [Text]
            -> Text
            -> [NewMessageDeliveryTask]
            -> Either String AChatMessage
            -> CM [NewMessageDeliveryTask]
          processAChatMsg :: GroupInfo
-> GroupMember
-> TVar [Text]
-> Text
-> [NewMessageDeliveryTask]
-> Either String AChatMessage
-> ExceptT
     ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask]
processAChatMsg GroupInfo
gInfo' GroupMember
m' TVar [Text]
tags Text
eInfo [NewMessageDeliveryTask]
newDeliveryTasks = \case
            Right (ACMsg SMsgEncoding e
SJson ChatMessage e
chatMsg) -> do
              Maybe NewMessageDeliveryTask
newTask_ <- GroupInfo
-> GroupMember
-> TVar [Text]
-> Text
-> ChatMessage e
-> CM (Maybe NewMessageDeliveryTask)
forall (e :: MsgEncoding).
MsgEncodingI e =>
GroupInfo
-> GroupMember
-> TVar [Text]
-> Text
-> ChatMessage e
-> CM (Maybe NewMessageDeliveryTask)
processEvent GroupInfo
gInfo' GroupMember
m' TVar [Text]
tags Text
eInfo ChatMessage e
chatMsg CM (Maybe NewMessageDeliveryTask)
-> (ChatError -> CM (Maybe NewMessageDeliveryTask))
-> CM (Maybe NewMessageDeliveryTask)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
e -> ChatError -> CM ()
eToView ChatError
e CM ()
-> Maybe NewMessageDeliveryTask
-> CM (Maybe NewMessageDeliveryTask)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe NewMessageDeliveryTask
forall a. Maybe a
Nothing
              [NewMessageDeliveryTask]
-> ExceptT
     ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([NewMessageDeliveryTask]
 -> ExceptT
      ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask])
-> [NewMessageDeliveryTask]
-> ExceptT
     ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask]
forall a b. (a -> b) -> a -> b
$ [NewMessageDeliveryTask]
-> (NewMessageDeliveryTask -> [NewMessageDeliveryTask])
-> Maybe NewMessageDeliveryTask
-> [NewMessageDeliveryTask]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [NewMessageDeliveryTask]
newDeliveryTasks (NewMessageDeliveryTask
-> [NewMessageDeliveryTask] -> [NewMessageDeliveryTask]
forall a. a -> [a] -> [a]
: [NewMessageDeliveryTask]
newDeliveryTasks) Maybe NewMessageDeliveryTask
newTask_
            Right (ACMsg SMsgEncoding e
SBinary ChatMessage e
chatMsg) -> do
              CM (Maybe NewMessageDeliveryTask) -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (GroupInfo
-> GroupMember
-> TVar [Text]
-> Text
-> ChatMessage e
-> CM (Maybe NewMessageDeliveryTask)
forall (e :: MsgEncoding).
MsgEncodingI e =>
GroupInfo
-> GroupMember
-> TVar [Text]
-> Text
-> ChatMessage e
-> CM (Maybe NewMessageDeliveryTask)
processEvent GroupInfo
gInfo' GroupMember
m' TVar [Text]
tags Text
eInfo ChatMessage e
chatMsg) CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
e -> ChatError -> CM ()
eToView ChatError
e
              [NewMessageDeliveryTask]
-> ExceptT
     ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NewMessageDeliveryTask]
newDeliveryTasks
            Left String
e -> do
              STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TVar [Text] -> ([Text] -> [Text]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Text]
tags (Text
"error" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
              Text -> CM ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logInfo (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"group msg=error " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
eInfo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
tshow String
e
              ChatError -> CM ()
eToView (ChatErrorType -> ChatError
ChatError (ChatErrorType -> ChatError)
-> (String -> ChatErrorType) -> String -> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ChatErrorType
CEException (String -> ChatError) -> String -> ChatError
forall a b. (a -> b) -> a -> b
$ String
"error parsing chat message: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e)
              [NewMessageDeliveryTask]
-> ExceptT
     ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NewMessageDeliveryTask]
newDeliveryTasks
          processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> TVar [Text] -> Text -> ChatMessage e -> CM (Maybe NewMessageDeliveryTask)
          processEvent :: forall (e :: MsgEncoding).
MsgEncodingI e =>
GroupInfo
-> GroupMember
-> TVar [Text]
-> Text
-> ChatMessage e
-> CM (Maybe NewMessageDeliveryTask)
processEvent GroupInfo
gInfo' GroupMember
m' TVar [Text]
tags Text
eInfo chatMsg :: ChatMessage e
chatMsg@ChatMessage {ChatMsgEvent e
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent} = do
            let tag :: CMEventTag e
tag = ChatMsgEvent e -> CMEventTag e
forall (e :: MsgEncoding). ChatMsgEvent e -> CMEventTag e
toCMEventTag ChatMsgEvent e
chatMsgEvent
            STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ TVar [Text] -> ([Text] -> [Text]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [Text]
tags (CMEventTag e -> Text
forall a. Show a => a -> Text
tshow CMEventTag e
tag Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
            Text -> CM ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logInfo (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"group msg=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CMEventTag e -> Text
forall a. Show a => a -> Text
tshow CMEventTag e
tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
eInfo
            let body :: ByteString
body = ChatMessage e -> ByteString
forall (e :: MsgEncoding).
MsgEncodingI e =>
ChatMessage e -> ByteString
chatMsgToBody ChatMessage e
chatMsg
            (GroupMember
m'', Connection
conn', msg :: RcvMessage
msg@RcvMessage {GroupMemberId
msgId :: GroupMemberId
msgId :: RcvMessage -> GroupMemberId
msgId, chatMsgEvent :: RcvMessage -> AChatMsgEvent
chatMsgEvent = ACME SMsgEncoding e
_ ChatMsgEvent e
event}) <- User
-> GroupMemberId
-> GroupMember
-> Connection
-> MsgMeta
-> ByteString
-> ChatMessage e
-> CM (GroupMember, Connection, RcvMessage)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupMemberId
-> GroupMember
-> Connection
-> MsgMeta
-> ByteString
-> ChatMessage e
-> CM (GroupMember, Connection, RcvMessage)
saveGroupRcvMsg User
user GroupMemberId
groupId GroupMember
m' Connection
conn MsgMeta
msgMeta ByteString
body ChatMessage e
chatMsg
            -- ! see isForwardedGroupMsg: processing functions should return DeliveryJobScope for same events
            Maybe DeliveryJobScope
deliveryJobScope_ <- case ChatMsgEvent e
event of
              XMsgNew MsgContainer
mc -> GroupMember
-> Maybe MsgScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
memberCanSend GroupMember
m'' Maybe MsgScope
scope (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> MsgContainer
-> RcvMessage
-> UTCTime
-> Bool
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
newGroupContentMessage GroupInfo
gInfo' GroupMember
m'' MsgContainer
mc RcvMessage
msg UTCTime
brokerTs Bool
False
                where ExtMsgContent {Maybe MsgScope
scope :: Maybe MsgScope
scope :: ExtMsgContent -> Maybe MsgScope
scope} = MsgContainer -> ExtMsgContent
mcExtMsgContent MsgContainer
mc
              -- file description is always allowed, to allow sending files to support scope
              XMsgFileDescr SharedMsgId
sharedMsgId FileDescr
fileDescr -> GroupInfo
-> GroupMember
-> SharedMsgId
-> FileDescr
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMessageFileDescription GroupInfo
gInfo' GroupMember
m'' SharedMsgId
sharedMsgId FileDescr
fileDescr
              XMsgUpdate SharedMsgId
sharedMsgId MsgContent
mContent Map Text MsgMention
mentions Maybe Int
ttl Maybe Bool
live Maybe MsgScope
msgScope -> GroupMember
-> Maybe MsgScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
memberCanSend GroupMember
m'' Maybe MsgScope
msgScope (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> SharedMsgId
-> MsgContent
-> Map Text MsgMention
-> Maybe MsgScope
-> RcvMessage
-> UTCTime
-> Maybe Int
-> Maybe Bool
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMessageUpdate GroupInfo
gInfo' GroupMember
m'' SharedMsgId
sharedMsgId MsgContent
mContent Map Text MsgMention
mentions Maybe MsgScope
msgScope RcvMessage
msg UTCTime
brokerTs Maybe Int
ttl Maybe Bool
live
              XMsgDel SharedMsgId
sharedMsgId Maybe MemberId
memberId Maybe MsgScope
scope_ -> GroupInfo
-> GroupMember
-> SharedMsgId
-> Maybe MemberId
-> Maybe MsgScope
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMessageDelete GroupInfo
gInfo' GroupMember
m'' SharedMsgId
sharedMsgId Maybe MemberId
memberId Maybe MsgScope
scope_ RcvMessage
msg UTCTime
brokerTs
              XMsgReact SharedMsgId
sharedMsgId (Just MemberId
memberId) Maybe MsgScope
scope_ MsgReaction
reaction Bool
add -> GroupInfo
-> GroupMember
-> SharedMsgId
-> MemberId
-> Maybe MsgScope
-> MsgReaction
-> Bool
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMsgReaction GroupInfo
gInfo' GroupMember
m'' SharedMsgId
sharedMsgId MemberId
memberId Maybe MsgScope
scope_ MsgReaction
reaction Bool
add RcvMessage
msg UTCTime
brokerTs
              -- TODO discontinue XFile
              XFile FileInvitation
fInv -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo
-> GroupMember -> FileInvitation -> RcvMessage -> UTCTime -> CM ()
processGroupFileInvitation' GroupInfo
gInfo' GroupMember
m'' FileInvitation
fInv RcvMessage
msg UTCTime
brokerTs
              XFileCancel SharedMsgId
sharedMsgId -> GroupInfo
-> GroupMember
-> SharedMsgId
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xFileCancelGroup GroupInfo
gInfo' GroupMember
m'' SharedMsgId
sharedMsgId
              XFileAcptInv SharedMsgId
sharedMsgId Maybe ConnReqInvitation
fileConnReq_ String
fName -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo
-> GroupMember
-> SharedMsgId
-> Maybe ConnReqInvitation
-> String
-> CM ()
xFileAcptInvGroup GroupInfo
gInfo' GroupMember
m'' SharedMsgId
sharedMsgId Maybe ConnReqInvitation
fileConnReq_ String
fName
              XInfo Profile
p -> GroupInfo
-> GroupMember
-> Profile
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xInfoMember GroupInfo
gInfo' GroupMember
m'' Profile
p UTCTime
brokerTs
              XGrpLinkMem Profile
p -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo -> GroupMember -> Connection -> Profile -> CM ()
xGrpLinkMem GroupInfo
gInfo' GroupMember
m'' Connection
conn' Profile
p
              XGrpLinkAcpt GroupAcceptance
acceptance GroupMemberRole
role MemberId
memberId -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo
-> GroupMember
-> GroupAcceptance
-> GroupMemberRole
-> MemberId
-> RcvMessage
-> UTCTime
-> CM ()
xGrpLinkAcpt GroupInfo
gInfo' GroupMember
m'' GroupAcceptance
acceptance GroupMemberRole
role MemberId
memberId RcvMessage
msg UTCTime
brokerTs
              XGrpMemNew MemberInfo
memInfo Maybe MsgScope
msgScope -> GroupInfo
-> GroupMember
-> MemberInfo
-> Maybe MsgScope
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpMemNew GroupInfo
gInfo' GroupMember
m'' MemberInfo
memInfo Maybe MsgScope
msgScope RcvMessage
msg UTCTime
brokerTs
              XGrpMemIntro MemberInfo
memInfo Maybe MemberRestrictions
memRestrictions_ -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo
-> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> CM ()
xGrpMemIntro GroupInfo
gInfo' GroupMember
m'' MemberInfo
memInfo Maybe MemberRestrictions
memRestrictions_
              XGrpMemInv MemberId
memId IntroInvitation
introInv -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo -> GroupMember -> MemberId -> IntroInvitation -> CM ()
xGrpMemInv GroupInfo
gInfo' GroupMember
m'' MemberId
memId IntroInvitation
introInv
              XGrpMemFwd MemberInfo
memInfo IntroInvitation
introInv -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> CM ()
xGrpMemFwd GroupInfo
gInfo' GroupMember
m'' MemberInfo
memInfo IntroInvitation
introInv
              XGrpMemRole MemberId
memId GroupMemberRole
memRole -> GroupInfo
-> GroupMember
-> MemberId
-> GroupMemberRole
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpMemRole GroupInfo
gInfo' GroupMember
m'' MemberId
memId GroupMemberRole
memRole RcvMessage
msg UTCTime
brokerTs
              XGrpMemRestrict MemberId
memId MemberRestrictions
memRestrictions -> GroupInfo
-> GroupMember
-> MemberId
-> MemberRestrictions
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpMemRestrict GroupInfo
gInfo' GroupMember
m'' MemberId
memId MemberRestrictions
memRestrictions RcvMessage
msg UTCTime
brokerTs
              XGrpMemCon MemberId
memId -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo -> GroupMember -> MemberId -> CM ()
xGrpMemCon GroupInfo
gInfo' GroupMember
m'' MemberId
memId
              XGrpMemDel MemberId
memId Bool
withMessages -> case forall (e :: MsgEncoding). MsgEncodingI e => SMsgEncoding e
encoding @e of
                SMsgEncoding e
SJson -> GroupInfo
-> GroupMember
-> MemberId
-> Bool
-> ChatMessage 'Json
-> RcvMessage
-> UTCTime
-> Bool
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpMemDel GroupInfo
gInfo' GroupMember
m'' MemberId
memId Bool
withMessages ChatMessage e
ChatMessage 'Json
chatMsg RcvMessage
msg UTCTime
brokerTs Bool
False
                SMsgEncoding e
SBinary -> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
forall a. Maybe a
Nothing -- impossible
              ChatMsgEvent e
XGrpLeave -> GroupInfo
-> GroupMember
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpLeave GroupInfo
gInfo' GroupMember
m'' RcvMessage
msg UTCTime
brokerTs
              ChatMsgEvent e
XGrpDel -> DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DJSGroup {jobSpec :: DeliveryJobSpec
jobSpec = DeliveryJobSpec
DJRelayRemoved}) Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
xGrpDel GroupInfo
gInfo' GroupMember
m'' RcvMessage
msg UTCTime
brokerTs
              XGrpInfo GroupProfile
p' -> GroupInfo
-> GroupMember
-> GroupProfile
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpInfo GroupInfo
gInfo' GroupMember
m'' GroupProfile
p' RcvMessage
msg UTCTime
brokerTs
              XGrpPrefs GroupPreferences
ps' -> GroupInfo
-> GroupMember
-> GroupPreferences
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpPrefs GroupInfo
gInfo' GroupMember
m'' GroupPreferences
ps'
              -- TODO [knocking] why don't we forward these messages?
              XGrpDirectInv ConnReqInvitation
connReq Maybe MsgContent
mContent_ Maybe MsgScope
msgScope -> GroupMember
-> Maybe MsgScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
memberCanSend GroupMember
m'' Maybe MsgScope
msgScope (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo
-> GroupMember
-> Connection
-> ConnReqInvitation
-> Maybe MsgContent
-> RcvMessage
-> UTCTime
-> CM ()
xGrpDirectInv GroupInfo
gInfo' GroupMember
m'' Connection
conn' ConnReqInvitation
connReq Maybe MsgContent
mContent_ RcvMessage
msg UTCTime
brokerTs
              XGrpMsgForward MemberId
memberId Maybe Text
memberName ChatMessage 'Json
msg' UTCTime
msgTs -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo
-> GroupMember
-> MemberId
-> Maybe Text
-> ChatMessage 'Json
-> UTCTime
-> UTCTime
-> CM ()
xGrpMsgForward GroupInfo
gInfo' GroupMember
m'' MemberId
memberId Maybe Text
memberName ChatMessage 'Json
msg' UTCTime
msgTs UTCTime
brokerTs
              XInfoProbe Probe
probe -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ContactOrMember -> Probe -> CM ()
xInfoProbe (GroupMember -> ContactOrMember
COMGroupMember GroupMember
m'') Probe
probe
              XInfoProbeCheck ProbeHash
probeHash -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ContactOrMember -> ProbeHash -> CM ()
xInfoProbeCheck (GroupMember -> ContactOrMember
COMGroupMember GroupMember
m'') ProbeHash
probeHash
              XInfoProbeOk Probe
probe -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ContactOrMember -> Probe -> CM ()
xInfoProbeOk (GroupMember -> ContactOrMember
COMGroupMember GroupMember
m'') Probe
probe
              BFileChunk SharedMsgId
sharedMsgId FileChunk
chunk -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ GroupInfo -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
bFileChunkGroup GroupInfo
gInfo' SharedMsgId
sharedMsgId FileChunk
chunk MsgMeta
msgMeta
              ChatMsgEvent e
_ -> Maybe DeliveryJobScope
forall a. Maybe a
Nothing Maybe DeliveryJobScope
-> CM ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> CM ()
messageError (Text
"unsupported message: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChatMsgEvent e -> Text
forall a. Show a => a -> Text
tshow ChatMsgEvent e
event)
            Maybe DeliveryJobScope
-> (DeliveryJobScope
    -> ExceptT
         ChatError (ReaderT ChatController IO) NewMessageDeliveryTask)
-> CM (Maybe NewMessageDeliveryTask)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe DeliveryJobScope
deliveryJobScope_ ((DeliveryJobScope
  -> ExceptT
       ChatError (ReaderT ChatController IO) NewMessageDeliveryTask)
 -> CM (Maybe NewMessageDeliveryTask))
-> (DeliveryJobScope
    -> ExceptT
         ChatError (ReaderT ChatController IO) NewMessageDeliveryTask)
-> CM (Maybe NewMessageDeliveryTask)
forall a b. (a -> b) -> a -> b
$ \DeliveryJobScope
jobScope ->
              -- TODO [channels fwd] XMsgNew to return messageFromChannel
              NewMessageDeliveryTask
-> ExceptT
     ChatError (ReaderT ChatController IO) NewMessageDeliveryTask
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewMessageDeliveryTask
 -> ExceptT
      ChatError (ReaderT ChatController IO) NewMessageDeliveryTask)
-> NewMessageDeliveryTask
-> ExceptT
     ChatError (ReaderT ChatController IO) NewMessageDeliveryTask
forall a b. (a -> b) -> a -> b
$ NewMessageDeliveryTask {messageId :: GroupMemberId
messageId = GroupMemberId
msgId, DeliveryJobScope
jobScope :: DeliveryJobScope
jobScope :: DeliveryJobScope
jobScope, messageFromChannel :: Bool
messageFromChannel = Bool
False}
          checkSendRcpt :: [AChatMessage] -> CM Bool
          checkSendRcpt :: [AChatMessage]
-> ExceptT ChatError (ReaderT ChatController IO) Bool
checkSendRcpt [AChatMessage]
aMsgs = do
            Int
currentMemCount <- (Connection -> IO Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO Int)
 -> ExceptT ChatError (ReaderT ChatController IO) Int)
-> (Connection -> IO Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupInfo -> IO Int
getGroupCurrentMembersCount Connection
db User
user GroupInfo
gInfo
            let GroupInfo {chatSettings :: GroupInfo -> ChatSettings
chatSettings = ChatSettings {Maybe Bool
sendRcpts :: ChatSettings -> Maybe Bool
sendRcpts :: Maybe Bool
sendRcpts}} = GroupInfo
gInfo
            Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a b. (a -> b) -> a -> b
$
              Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (User -> Bool
sendRcptsSmallGroups User
user) Maybe Bool
sendRcpts
                Bool -> Bool -> Bool
&& (AChatMessage -> Bool) -> [AChatMessage] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any AChatMessage -> Bool
aChatMsgHasReceipt [AChatMessage]
aMsgs
                Bool -> Bool -> Bool
&& Int
currentMemCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
smallGroupsRcptsMemLimit
            where
              aChatMsgHasReceipt :: AChatMessage -> Bool
aChatMsgHasReceipt (ACMsg SMsgEncoding e
_ ChatMessage {ChatMsgEvent e
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent}) =
                CMEventTag e -> Bool
forall (e :: MsgEncoding). CMEventTag e -> Bool
hasDeliveryReceipt (ChatMsgEvent e -> CMEventTag e
forall (e :: MsgEncoding). ChatMsgEvent e -> CMEventTag e
toCMEventTag ChatMsgEvent e
chatMsgEvent)
          createDeliveryTasks :: GroupInfo -> GroupMember -> [NewMessageDeliveryTask] -> CM ShouldDeleteGroupConns
          createDeliveryTasks :: GroupInfo
-> GroupMember
-> [NewMessageDeliveryTask]
-> ExceptT ChatError (ReaderT ChatController IO) Bool
createDeliveryTasks gInfo' :: GroupInfo
gInfo'@GroupInfo {groupId :: GroupInfo -> GroupMemberId
groupId = GroupMemberId
gId} GroupMember
m' [NewMessageDeliveryTask]
newDeliveryTasks = do
            let relayRemovedTask_ :: Maybe NewMessageDeliveryTask
relayRemovedTask_ = (NewMessageDeliveryTask -> Bool)
-> [NewMessageDeliveryTask] -> Maybe NewMessageDeliveryTask
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\NewMessageDeliveryTask {DeliveryJobScope
jobScope :: NewMessageDeliveryTask -> DeliveryJobScope
jobScope :: DeliveryJobScope
jobScope} -> DeliveryJobScope -> Bool
isRelayRemoved DeliveryJobScope
jobScope) [NewMessageDeliveryTask]
newDeliveryTasks
            [NewMessageDeliveryTask]
createdDeliveryTasks <- case Maybe NewMessageDeliveryTask
relayRemovedTask_ of
              Maybe NewMessageDeliveryTask
Nothing -> do
                (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db ->
                  [NewMessageDeliveryTask]
-> (NewMessageDeliveryTask -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [NewMessageDeliveryTask]
newDeliveryTasks ((NewMessageDeliveryTask -> IO ()) -> IO ())
-> (NewMessageDeliveryTask -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NewMessageDeliveryTask
newTask ->
                    Connection
-> GroupInfo -> GroupMember -> NewMessageDeliveryTask -> IO ()
createMsgDeliveryTask Connection
db GroupInfo
gInfo' GroupMember
m' NewMessageDeliveryTask
newTask
                [NewMessageDeliveryTask]
-> ExceptT
     ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NewMessageDeliveryTask]
newDeliveryTasks
              Just NewMessageDeliveryTask
relayRemovedTask -> do
                -- if relay is removed, delete all other tasks and jobs
                (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                  Connection -> GroupInfo -> IO ()
deleteGroupDeliveryTasks Connection
db GroupInfo
gInfo'
                  Connection -> GroupInfo -> IO ()
deleteGroupDeliveryJobs Connection
db GroupInfo
gInfo'
                  Connection
-> GroupInfo -> GroupMember -> NewMessageDeliveryTask -> IO ()
createMsgDeliveryTask Connection
db GroupInfo
gInfo' GroupMember
m' NewMessageDeliveryTask
relayRemovedTask
                [NewMessageDeliveryTask]
-> ExceptT
     ChatError (ReaderT ChatController IO) [NewMessageDeliveryTask]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Item [NewMessageDeliveryTask]
NewMessageDeliveryTask
relayRemovedTask]
            ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ [DeliveryWorkerScope]
-> (DeliveryWorkerScope -> ReaderT ChatController IO Worker)
-> ReaderT ChatController IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([NewMessageDeliveryTask] -> [DeliveryWorkerScope]
uniqueWorkerScopes [NewMessageDeliveryTask]
createdDeliveryTasks) ((DeliveryWorkerScope -> ReaderT ChatController IO Worker)
 -> ReaderT ChatController IO ())
-> (DeliveryWorkerScope -> ReaderT ChatController IO Worker)
-> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ \DeliveryWorkerScope
workerScope ->
              Bool -> DeliveryWorkerKey -> ReaderT ChatController IO Worker
getDeliveryTaskWorker Bool
True (GroupMemberId
gId, DeliveryWorkerScope
workerScope)
            Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a b. (a -> b) -> a -> b
$ Maybe NewMessageDeliveryTask -> Bool
forall a. Maybe a -> Bool
isJust Maybe NewMessageDeliveryTask
relayRemovedTask_
            where
              uniqueWorkerScopes :: [NewMessageDeliveryTask] -> [DeliveryWorkerScope]
              uniqueWorkerScopes :: [NewMessageDeliveryTask] -> [DeliveryWorkerScope]
uniqueWorkerScopes [NewMessageDeliveryTask]
createdDeliveryTasks =
                let workerScopes :: [DeliveryWorkerScope]
workerScopes = (NewMessageDeliveryTask -> DeliveryWorkerScope)
-> [NewMessageDeliveryTask] -> [DeliveryWorkerScope]
forall a b. (a -> b) -> [a] -> [b]
map (\NewMessageDeliveryTask {DeliveryJobScope
jobScope :: NewMessageDeliveryTask -> DeliveryJobScope
jobScope :: DeliveryJobScope
jobScope} -> DeliveryJobScope -> DeliveryWorkerScope
toWorkerScope DeliveryJobScope
jobScope) [NewMessageDeliveryTask]
createdDeliveryTasks
                 in (DeliveryWorkerScope
 -> [DeliveryWorkerScope] -> [DeliveryWorkerScope])
-> [DeliveryWorkerScope]
-> [DeliveryWorkerScope]
-> [DeliveryWorkerScope]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' DeliveryWorkerScope
-> [DeliveryWorkerScope] -> [DeliveryWorkerScope]
forall {a}. Eq a => a -> [a] -> [a]
addWorkerScope [] [DeliveryWorkerScope]
workerScopes
                where
                  addWorkerScope :: a -> [a] -> [a]
addWorkerScope a
workerScope [a]
acc
                    | a
workerScope a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
acc = [a]
acc
                    | Bool
otherwise = a
workerScope a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc
      RCVD MsgMeta
msgMeta NonEmpty MsgReceipt
msgRcpt ->
        Text -> ByteString -> MsgMeta -> CM () -> CM ()
withAckMessage' Text
"group rcvd" ByteString
agentConnId MsgMeta
msgMeta (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$
          GroupInfo
-> GroupMember
-> Connection
-> MsgMeta
-> NonEmpty MsgReceipt
-> CM ()
groupMsgReceived GroupInfo
gInfo GroupMember
m Connection
conn MsgMeta
msgMeta NonEmpty MsgReceipt
msgRcpt
      SENT GroupMemberId
msgId Maybe SMPServer
proxy -> do
        Bool
continued <- ConnectionEntity
-> Connection -> ExceptT ChatError (ReaderT ChatController IO) Bool
continueSending ConnectionEntity
connEntity Connection
conn
        Connection -> GroupMemberId -> CM ()
sentMsgDeliveryEvent Connection
conn GroupMemberId
msgId
        Connection -> GroupMemberId -> CM ()
checkSndInlineFTComplete Connection
conn GroupMemberId
msgId
        GroupInfo
-> GroupMember
-> Connection
-> GroupMemberId
-> GroupSndStatus
-> Maybe Bool
-> CM ()
updateGroupItemsStatus GroupInfo
gInfo GroupMember
m Connection
conn GroupMemberId
msgId GroupSndStatus
GSSSent (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Maybe SMPServer -> Bool
forall a. Maybe a -> Bool
isJust Maybe SMPServer
proxy)
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
continued (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupMember -> Connection -> CM ()
sendPendingGroupMessages User
user GroupMember
m Connection
conn
      SWITCH QueueDirection
qd SwitchPhase
phase ConnectionStats
cStats -> do
        ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> SwitchProgress -> ChatEvent
CEvtGroupMemberSwitch User
user GroupInfo
gInfo GroupMember
m (QueueDirection -> SwitchPhase -> ConnectionStats -> SwitchProgress
SwitchProgress QueueDirection
qd SwitchPhase
phase ConnectionStats
cStats)
        (GroupInfo
gInfo', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo GroupMember
m
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SwitchPhase
phase SwitchPhase -> SwitchPhase -> Bool
forall a. Eq a => a -> a -> Bool
== SwitchPhase
SPStarted Bool -> Bool -> Bool
|| SwitchPhase
phase SwitchPhase -> SwitchPhase -> Bool
forall a. Eq a => a -> a -> Bool
== SwitchPhase
SPCompleted) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ case QueueDirection
qd of
          QueueDirection
QDRcv -> User
-> ChatDirection 'CTGroup 'MDSnd
-> CIContent 'MDSnd
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDSnd
CDGroupSnd GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo) (SndConnEvent -> CIContent 'MDSnd
CISndConnEvent (SndConnEvent -> CIContent 'MDSnd)
-> (GroupMemberRef -> SndConnEvent)
-> GroupMemberRef
-> CIContent 'MDSnd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwitchPhase -> Maybe GroupMemberRef -> SndConnEvent
SCESwitchQueue SwitchPhase
phase (Maybe GroupMemberRef -> SndConnEvent)
-> (GroupMemberRef -> Maybe GroupMemberRef)
-> GroupMemberRef
-> SndConnEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupMemberRef -> Maybe GroupMemberRef
forall a. a -> Maybe a
Just (GroupMemberRef -> CIContent 'MDSnd)
-> GroupMemberRef -> CIContent 'MDSnd
forall a b. (a -> b) -> a -> b
$ GroupMember -> GroupMemberRef
groupMemberRef GroupMember
m') Maybe UTCTime
forall a. Maybe a
Nothing
          QueueDirection
QDSnd -> User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') (RcvConnEvent -> CIContent 'MDRcv
CIRcvConnEvent (RcvConnEvent -> CIContent 'MDRcv)
-> RcvConnEvent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ SwitchPhase -> RcvConnEvent
RCESwitchQueue SwitchPhase
phase) Maybe UTCTime
forall a. Maybe a
Nothing
      RSYNC RatchetSyncState
rss Maybe AgentCryptoError
cryptoErr_ ConnectionStats
cStats -> do
        (GroupInfo
gInfo', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo GroupMember
m
        case (RatchetSyncState
rss, Maybe SecurityCode
connectionCode, Maybe AgentCryptoError
cryptoErr_) of
          (RatchetSyncState
RSRequired, Maybe SecurityCode
_, Just AgentCryptoError
cryptoErr) -> GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> AgentCryptoError
-> CM ()
processErr GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m' AgentCryptoError
cryptoErr
          (RatchetSyncState
RSAllowed, Maybe SecurityCode
_, Just AgentCryptoError
cryptoErr) -> GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> AgentCryptoError
-> CM ()
processErr GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m' AgentCryptoError
cryptoErr
          (RatchetSyncState
RSAgreed, Just SecurityCode
_, Maybe AgentCryptoError
_) -> do
            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> Maybe Text -> IO ()
setConnectionVerified Connection
db User
user GroupMemberId
connId Maybe Text
forall a. Maybe a
Nothing
            let m'' :: GroupMember
m'' = GroupMember
m' {activeConn = Just (conn {connectionCode = Nothing} :: Connection)} :: GroupMember
            GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM ()
ratchetSyncEventItem GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m''
            TerminalEvent -> CM ()
toViewTE (TerminalEvent -> CM ()) -> TerminalEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> TerminalEvent
TEGroupMemberVerificationReset User
user GroupInfo
gInfo' GroupMember
m''
            User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m'') (RcvConnEvent -> CIContent 'MDRcv
CIRcvConnEvent RcvConnEvent
RCEVerificationCodeReset) Maybe UTCTime
forall a. Maybe a
Nothing
          (RatchetSyncState, Maybe SecurityCode, Maybe AgentCryptoError)
_ -> GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM ()
ratchetSyncEventItem GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m'
        where
          processErr :: GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> AgentCryptoError
-> CM ()
processErr GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m' AgentCryptoError
cryptoErr = do
            let e :: (MsgDecryptError, Word32)
e@(MsgDecryptError
mde, Word32
n) = AgentCryptoError -> (MsgDecryptError, Word32)
agentMsgDecryptError AgentCryptoError
cryptoErr
            Maybe (ChatItem 'CTGroup 'MDRcv)
ci_ <- (Connection
 -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDRcv)))
-> CM (Maybe (ChatItem 'CTGroup 'MDRcv))
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection
  -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDRcv)))
 -> CM (Maybe (ChatItem 'CTGroup 'MDRcv)))
-> (Connection
    -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDRcv)))
-> CM (Maybe (ChatItem 'CTGroup 'MDRcv))
forall a b. (a -> b) -> a -> b
$ \Connection
db ->
              Connection
-> User
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupMemberChatItemLast Connection
db User
user GroupMemberId
groupId (GroupMember -> GroupMemberId
groupMemberId' GroupMember
m')
                ExceptT StoreError IO (CChatItem 'CTGroup)
-> (CChatItem 'CTGroup
    -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDRcv)))
-> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDRcv))
forall a b.
ExceptT StoreError IO a
-> (a -> ExceptT StoreError IO b) -> ExceptT StoreError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe (ChatItem 'CTGroup 'MDRcv))
-> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDRcv))
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                  (IO (Maybe (ChatItem 'CTGroup 'MDRcv))
 -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDRcv)))
-> (CChatItem 'CTGroup -> IO (Maybe (ChatItem 'CTGroup 'MDRcv)))
-> CChatItem 'CTGroup
-> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDRcv))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ChatItem 'CTGroup 'MDRcv, CIContent 'MDRcv)
 -> IO (ChatItem 'CTGroup 'MDRcv))
-> Maybe (ChatItem 'CTGroup 'MDRcv, CIContent 'MDRcv)
-> IO (Maybe (ChatItem 'CTGroup 'MDRcv))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (\(ChatItem 'CTGroup 'MDRcv
ci, CIContent 'MDRcv
content') -> Connection
-> User
-> GroupMemberId
-> ChatItem 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Bool
-> Bool
-> Maybe GroupMemberId
-> IO (ChatItem 'CTGroup 'MDRcv)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupMemberId
-> ChatItem 'CTGroup d
-> CIContent d
-> Bool
-> Bool
-> Maybe GroupMemberId
-> IO (ChatItem 'CTGroup d)
updateGroupChatItem Connection
db User
user GroupMemberId
groupId ChatItem 'CTGroup 'MDRcv
ci CIContent 'MDRcv
content' Bool
False Bool
False Maybe GroupMemberId
forall a. Maybe a
Nothing)
                  (Maybe (ChatItem 'CTGroup 'MDRcv, CIContent 'MDRcv)
 -> IO (Maybe (ChatItem 'CTGroup 'MDRcv)))
-> (CChatItem 'CTGroup
    -> Maybe (ChatItem 'CTGroup 'MDRcv, CIContent 'MDRcv))
-> CChatItem 'CTGroup
-> IO (Maybe (ChatItem 'CTGroup 'MDRcv))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgDecryptError, Word32)
-> CChatItem 'CTGroup
-> Maybe (ChatItem 'CTGroup 'MDRcv, CIContent 'MDRcv)
forall (c :: ChatType).
(MsgDecryptError, Word32)
-> CChatItem c -> Maybe (ChatItem c 'MDRcv, CIContent 'MDRcv)
mdeUpdatedCI (MsgDecryptError, Word32)
e
            case Maybe (ChatItem 'CTGroup 'MDRcv)
ci_ of
              Just ChatItem 'CTGroup 'MDRcv
ci -> ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemUpdated User
user (SChatType 'CTGroup
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTGroup
-> ChatItem 'CTGroup 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTGroup
SCTGroup SMsgDirection 'MDRcv
SMDRcv (GroupInfo -> Maybe GroupChatScopeInfo -> ChatInfo 'CTGroup
GroupChat GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo) ChatItem 'CTGroup 'MDRcv
ci)
              Maybe (ChatItem 'CTGroup 'MDRcv)
_ -> do
                ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> GroupInfo -> GroupMember -> RatchetSyncProgress -> ChatEvent
CEvtGroupMemberRatchetSync User
user GroupInfo
gInfo' GroupMember
m' (RatchetSyncState -> ConnectionStats -> RatchetSyncProgress
RatchetSyncProgress RatchetSyncState
rss ConnectionStats
cStats)
                User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') (MsgDecryptError -> Word32 -> CIContent 'MDRcv
CIRcvDecryptionError MsgDecryptError
mde Word32
n) Maybe UTCTime
forall a. Maybe a
Nothing
          ratchetSyncEventItem :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM ()
ratchetSyncEventItem GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m' = do
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> GroupInfo -> GroupMember -> RatchetSyncProgress -> ChatEvent
CEvtGroupMemberRatchetSync User
user GroupInfo
gInfo' GroupMember
m' (RatchetSyncState -> ConnectionStats -> RatchetSyncProgress
RatchetSyncProgress RatchetSyncState
rss ConnectionStats
cStats)
            User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') (RcvConnEvent -> CIContent 'MDRcv
CIRcvConnEvent (RcvConnEvent -> CIContent 'MDRcv)
-> RcvConnEvent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ RatchetSyncState -> RcvConnEvent
RCERatchetSync RatchetSyncState
rss) Maybe UTCTime
forall a. Maybe a
Nothing
      AEvent e
OK ->
        -- [async agent commands] continuation on receiving OK
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
corrId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData
_cmdData -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      -- TODO [certs rcv]
      JOINED Bool
sqSecured Maybe ClientServiceId
_serviceId ->
        -- [async agent commands] continuation on receiving JOINED
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
corrId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData
_cmdData ->
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
sqSecured Bool -> Bool -> Bool
&& Version ChatVersion
connChatVersion Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
batchSend2Version) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
            Maybe MsgContent
mc_ <- ExceptT ChatError (ReaderT ChatController IO) (Maybe MsgContent)
getAutoReplyMsg
            Maybe MsgContent -> (MsgContent -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe MsgContent
mc_ ((MsgContent -> CM ()) -> CM ()) -> (MsgContent -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \MsgContent
mc -> do
              Maybe UserContactRequest
connReq_ <- (Connection -> IO (Maybe UserContactRequest))
-> CM (Maybe UserContactRequest)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (Maybe UserContactRequest))
 -> CM (Maybe UserContactRequest))
-> (Connection -> IO (Maybe UserContactRequest))
-> CM (Maybe UserContactRequest)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User -> GroupMemberId -> IO (Maybe UserContactRequest)
getBusinessContactRequest Connection
db User
user GroupMemberId
groupId
              MsgContent -> Maybe UserContactRequest -> CM ()
sendGroupAutoReply MsgContent
mc Maybe UserContactRequest
connReq_
      AEvent e
QCONT -> do
        Bool
continued <- ConnectionEntity
-> Connection -> ExceptT ChatError (ReaderT ChatController IO) Bool
continueSending ConnectionEntity
connEntity Connection
conn
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
continued (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupMember -> Connection -> CM ()
sendPendingGroupMessages User
user GroupMember
m Connection
conn
      MWARN GroupMemberId
msgId AgentErrorType
err -> do
        (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> GroupMemberId -> GroupSndStatus -> IO ()
updateGroupItemsErrorStatus Connection
db GroupMemberId
msgId (GroupMember -> GroupMemberId
groupMemberId' GroupMember
m) (SndError -> GroupSndStatus
GSSWarning (SndError -> GroupSndStatus) -> SndError -> GroupSndStatus
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> SndError
agentSndError AgentErrorType
err)
        ConnectionEntity -> Connection -> AgentErrorType -> CM ()
processConnMWARN ConnectionEntity
connEntity Connection
conn AgentErrorType
err
      MERR GroupMemberId
msgId AgentErrorType
err -> do
        (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> GroupMemberId -> GroupSndStatus -> IO ()
updateGroupItemsErrorStatus Connection
db GroupMemberId
msgId (GroupMember -> GroupMemberId
groupMemberId' GroupMember
m) (SndError -> GroupSndStatus
GSSError (SndError -> GroupSndStatus) -> SndError -> GroupSndStatus
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> SndError
agentSndError AgentErrorType
err)
        -- group errors are silenced to reduce load on UI event log
        -- eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity)
        ConnectionEntity -> Connection -> AgentErrorType -> CM ()
processConnMERR ConnectionEntity
connEntity Connection
conn AgentErrorType
err
      MERRS NonEmpty GroupMemberId
msgIds AgentErrorType
err -> do
        let newStatus :: GroupSndStatus
newStatus = SndError -> GroupSndStatus
GSSError (SndError -> GroupSndStatus) -> SndError -> GroupSndStatus
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> SndError
agentSndError AgentErrorType
err
        -- error cannot be AUTH error here
        (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> NonEmpty GroupMemberId -> (GroupMemberId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty GroupMemberId
msgIds ((GroupMemberId -> IO ()) -> IO ())
-> (GroupMemberId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
msgId ->
          Connection
-> GroupMemberId -> GroupMemberId -> GroupSndStatus -> IO ()
updateGroupItemsErrorStatus Connection
db GroupMemberId
msgId (GroupMember -> GroupMemberId
groupMemberId' GroupMember
m) GroupSndStatus
newStatus IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchAll_` () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
err (ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) (ConnectionEntity -> Maybe ConnectionEntity
forall a. a -> Maybe a
Just ConnectionEntity
connEntity)
      ERR AgentErrorType
err -> do
        ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
err (ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) (ConnectionEntity -> Maybe ConnectionEntity
forall a. a -> Maybe a
Just ConnectionEntity
connEntity)
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
corrId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData
_cmdData -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      -- TODO add debugging output
      AEvent e
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        updateGroupItemsErrorStatus :: DB.Connection -> AgentMsgId -> GroupMemberId -> GroupSndStatus -> IO ()
        updateGroupItemsErrorStatus :: Connection
-> GroupMemberId -> GroupMemberId -> GroupSndStatus -> IO ()
updateGroupItemsErrorStatus Connection
db GroupMemberId
msgId GroupMemberId
groupMemberId GroupSndStatus
newStatus = do
          [GroupMemberId]
itemIds <- Connection -> GroupMemberId -> GroupMemberId -> IO [GroupMemberId]
getChatItemIdsByAgentMsgId Connection
db GroupMemberId
connId GroupMemberId
msgId
          [GroupMemberId] -> (GroupMemberId -> IO Bool) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GroupMemberId]
itemIds ((GroupMemberId -> IO Bool) -> IO ())
-> (GroupMemberId -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
itemId -> Connection
-> GroupMemberId -> GroupMemberId -> GroupSndStatus -> IO Bool
updateGroupMemSndStatus' Connection
db GroupMemberId
itemId GroupMemberId
groupMemberId GroupSndStatus
newStatus
        getAutoReplyMsg :: ExceptT ChatError (ReaderT ChatController IO) (Maybe MsgContent)
getAutoReplyMsg = do
          let GroupInfo {Maybe BusinessChatInfo
businessChat :: GroupInfo -> Maybe BusinessChatInfo
businessChat :: Maybe BusinessChatInfo
businessChat} = GroupInfo
gInfo
              GroupMember {memberId :: GroupMember -> MemberId
memberId = MemberId
joiningMemberId} = GroupMember
m
          case Maybe BusinessChatInfo
businessChat of
            Just BusinessChatInfo {MemberId
customerId :: BusinessChatInfo -> MemberId
customerId :: MemberId
customerId, chatType :: BusinessChatInfo -> BusinessChatType
chatType = BusinessChatType
BCCustomer}
              | MemberId
joiningMemberId MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== MemberId
customerId -> UserContactLink -> Maybe MsgContent
useReply (UserContactLink -> Maybe MsgContent)
-> ExceptT ChatError (ReaderT ChatController IO) UserContactLink
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe MsgContent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> ExceptT StoreError IO UserContactLink)
-> ExceptT ChatError (ReaderT ChatController IO) UserContactLink
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (Connection -> User -> ExceptT StoreError IO UserContactLink
`getUserAddress` User
user)
              where
                useReply :: UserContactLink -> Maybe MsgContent
useReply UserContactLink {addressSettings :: UserContactLink -> AddressSettings
addressSettings = AddressSettings {Maybe MsgContent
autoReply :: AddressSettings -> Maybe MsgContent
autoReply :: Maybe MsgContent
autoReply}} = Maybe MsgContent
autoReply
            Maybe BusinessChatInfo
_ -> Maybe MsgContent
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe MsgContent)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MsgContent
forall a. Maybe a
Nothing
        sendGroupAutoReply :: MsgContent -> Maybe UserContactRequest -> CM ()
sendGroupAutoReply MsgContent
mc = \case
          Just UserContactRequest {welcomeSharedMsgId :: UserContactRequest -> Maybe SharedMsgId
welcomeSharedMsgId = Just SharedMsgId
smId} ->
            ExceptT ChatError (ReaderT ChatController IO) SndMessage -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) SndMessage -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
-> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> GroupInfo
-> [GroupMember]
-> ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupInfo
-> [GroupMember]
-> ChatMsgEvent e
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
sendGroupMessage' User
user GroupInfo
gInfo [Item [GroupMember]
GroupMember
m] (ChatMsgEvent 'Json
 -> ExceptT ChatError (ReaderT ChatController IO) SndMessage)
-> ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall a b. (a -> b) -> a -> b
$ SharedMsgId
-> MsgContent
-> Map Text MsgMention
-> Maybe Int
-> Maybe Bool
-> Maybe MsgScope
-> ChatMsgEvent 'Json
XMsgUpdate SharedMsgId
smId MsgContent
mc Map Text MsgMention
forall k a. Map k a
M.empty Maybe Int
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe MsgScope
forall a. Maybe a
Nothing
          Maybe UserContactRequest
_ -> do
            SndMessage
msg <- User
-> GroupInfo
-> [GroupMember]
-> ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupInfo
-> [GroupMember]
-> ChatMsgEvent e
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
sendGroupMessage' User
user GroupInfo
gInfo [Item [GroupMember]
GroupMember
m] (ChatMsgEvent 'Json
 -> ExceptT ChatError (ReaderT ChatController IO) SndMessage)
-> ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall a b. (a -> b) -> a -> b
$ MsgContainer -> ChatMsgEvent 'Json
XMsgNew (MsgContainer -> ChatMsgEvent 'Json)
-> MsgContainer -> ChatMsgEvent 'Json
forall a b. (a -> b) -> a -> b
$ ExtMsgContent -> MsgContainer
MCSimple (ExtMsgContent -> MsgContainer) -> ExtMsgContent -> MsgContainer
forall a b. (a -> b) -> a -> b
$ MsgContent -> Maybe FileInvitation -> ExtMsgContent
extMsgContent MsgContent
mc Maybe FileInvitation
forall a. Maybe a
Nothing
            ChatItem 'CTGroup 'MDSnd
ci <- User
-> ChatDirection 'CTGroup 'MDSnd
-> SndMessage
-> CIContent 'MDSnd
-> CM (ChatItem 'CTGroup 'MDSnd)
forall (c :: ChatType).
ChatTypeI c =>
User
-> ChatDirection c 'MDSnd
-> SndMessage
-> CIContent 'MDSnd
-> CM (ChatItem c 'MDSnd)
saveSndChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDSnd
CDGroupSnd GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing) SndMessage
msg (MsgContent -> CIContent 'MDSnd
CISndMsgContent MsgContent
mc)
            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> GroupMemberId -> GroupSndStatus -> IO ()
createGroupSndStatus Connection
db (ChatItem 'CTGroup 'MDSnd -> GroupMemberId
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> GroupMemberId
chatItemId' ChatItem 'CTGroup 'MDSnd
ci) (GroupMember -> GroupMemberId
groupMemberId' GroupMember
m) GroupSndStatus
GSSNew
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [SChatType 'CTGroup
-> SMsgDirection 'MDSnd
-> ChatInfo 'CTGroup
-> ChatItem 'CTGroup 'MDSnd
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTGroup
SCTGroup SMsgDirection 'MDSnd
SMDSnd (GroupInfo -> Maybe GroupChatScopeInfo -> ChatInfo 'CTGroup
GroupChat GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing) ChatItem 'CTGroup 'MDSnd
ci]

    agentMsgDecryptError :: AgentCryptoError -> (MsgDecryptError, Word32)
    agentMsgDecryptError :: AgentCryptoError -> (MsgDecryptError, Word32)
agentMsgDecryptError = \case
      AgentCryptoError
DECRYPT_AES -> (MsgDecryptError
MDEOther, Word32
1)
      AgentCryptoError
DECRYPT_CB -> (MsgDecryptError
MDEOther, Word32
1)
      AgentCryptoError
RATCHET_HEADER -> (MsgDecryptError
MDERatchetHeader, Word32
1)
      RATCHET_EARLIER Word32
_ -> (MsgDecryptError
MDERatchetEarlier, Word32
1)
      RATCHET_SKIPPED Word32
n -> (MsgDecryptError
MDETooManySkipped, Word32
n)
      AgentCryptoError
RATCHET_SYNC -> (MsgDecryptError
MDERatchetSync, Word32
0)

    mdeUpdatedCI :: (MsgDecryptError, Word32) -> CChatItem c -> Maybe (ChatItem c 'MDRcv, CIContent 'MDRcv)
    mdeUpdatedCI :: forall (c :: ChatType).
(MsgDecryptError, Word32)
-> CChatItem c -> Maybe (ChatItem c 'MDRcv, CIContent 'MDRcv)
mdeUpdatedCI (MsgDecryptError
mde', Word32
n') (CChatItem SMsgDirection d
_ ci :: ChatItem c d
ci@ChatItem {content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content = CIRcvDecryptionError MsgDecryptError
mde Word32
n})
      | MsgDecryptError
mde MsgDecryptError -> MsgDecryptError -> Bool
forall a. Eq a => a -> a -> Bool
== MsgDecryptError
mde' = case MsgDecryptError
mde of
          MsgDecryptError
MDERatchetHeader -> Word32 -> Maybe (ChatItem c d, CIContent 'MDRcv)
r (Word32
n Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
n')
          MsgDecryptError
MDETooManySkipped -> Word32 -> Maybe (ChatItem c d, CIContent 'MDRcv)
r Word32
n' -- the numbers are not added as sequential MDETooManySkipped will have it incremented by 1
          MsgDecryptError
MDERatchetEarlier -> Word32 -> Maybe (ChatItem c d, CIContent 'MDRcv)
r (Word32
n Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
n')
          MsgDecryptError
MDEOther -> Word32 -> Maybe (ChatItem c d, CIContent 'MDRcv)
r (Word32
n Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
n')
          MsgDecryptError
MDERatchetSync -> Word32 -> Maybe (ChatItem c d, CIContent 'MDRcv)
r Word32
0
      | Bool
otherwise = Maybe (ChatItem c 'MDRcv, CIContent 'MDRcv)
forall a. Maybe a
Nothing
      where
        r :: Word32 -> Maybe (ChatItem c d, CIContent 'MDRcv)
r Word32
n'' = (ChatItem c d, CIContent 'MDRcv)
-> Maybe (ChatItem c d, CIContent 'MDRcv)
forall a. a -> Maybe a
Just (ChatItem c d
ci, MsgDecryptError -> Word32 -> CIContent 'MDRcv
CIRcvDecryptionError MsgDecryptError
mde Word32
n'')
    mdeUpdatedCI (MsgDecryptError, Word32)
_ CChatItem c
_ = Maybe (ChatItem c 'MDRcv, CIContent 'MDRcv)
forall a. Maybe a
Nothing

    receiveFileChunk :: RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> CM ()
    receiveFileChunk :: RcvFileTransfer
-> Maybe Connection -> MsgMeta -> FileChunk -> CM ()
receiveFileChunk ft :: RcvFileTransfer
ft@RcvFileTransfer {GroupMemberId
fileId :: GroupMemberId
fileId :: RcvFileTransfer -> GroupMemberId
fileId, Integer
chunkSize :: Integer
chunkSize :: RcvFileTransfer -> Integer
chunkSize} Maybe Connection
conn_ meta :: MsgMeta
meta@MsgMeta {recipient :: MsgMeta -> (GroupMemberId, UTCTime)
recipient = (GroupMemberId
msgId, UTCTime
_), MsgIntegrity
integrity :: MsgIntegrity
integrity :: MsgMeta -> MsgIntegrity
integrity} = \case
      FileChunk
FileChunkCancel ->
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RcvFileTransfer -> Bool
rcvFileCompleteOrCancelled RcvFileTransfer
ft) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
          User -> RcvFileTransfer -> CM ()
cancelRcvFileTransfer User
user RcvFileTransfer
ft
          AChatItem
ci <- (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem)
-> (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO AChatItem
getChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> RcvFileTransfer -> ChatEvent
CEvtRcvFileSndCancelled User
user AChatItem
ci RcvFileTransfer
ft
      FileChunk {Integer
chunkNo :: Integer
chunkNo :: FileChunk -> Integer
chunkNo, chunkBytes :: FileChunk -> ByteString
chunkBytes = ByteString
chunk} -> do
        case MsgIntegrity
integrity of
          MsgIntegrity
MsgOk -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          MsgError MsgErrorType
MsgDuplicate -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- TODO remove once agent removes duplicates
          MsgError MsgErrorType
e ->
            RcvFileTransfer -> String -> CM ()
badRcvFileChunk RcvFileTransfer
ft (String -> CM ()) -> String -> CM ()
forall a b. (a -> b) -> a -> b
$ String
"invalid file chunk number " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
chunkNo String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> MsgErrorType -> String
forall a. Show a => a -> String
show MsgErrorType
e
        (Connection -> IO RcvChunkStatus) -> CM RcvChunkStatus
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> Connection
-> RcvFileTransfer -> Integer -> GroupMemberId -> IO RcvChunkStatus
createRcvFileChunk Connection
db RcvFileTransfer
ft Integer
chunkNo GroupMemberId
msgId) CM RcvChunkStatus -> (RcvChunkStatus -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          RcvChunkStatus
RcvChunkOk ->
            if ByteString -> Int
B.length ByteString
chunk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
chunkSize
              then RcvFileTransfer -> String -> CM ()
badRcvFileChunk RcvFileTransfer
ft String
"incorrect chunk size"
              else Text -> ByteString -> MsgMeta -> CM () -> CM ()
withAckMessage' Text
"file msg" ByteString
agentConnId MsgMeta
meta (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ RcvFileTransfer -> Integer -> ByteString -> Bool -> CM ()
appendFileChunk RcvFileTransfer
ft Integer
chunkNo ByteString
chunk Bool
False
          RcvChunkStatus
RcvChunkFinal ->
            if ByteString -> Int
B.length ByteString
chunk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
chunkSize
              then RcvFileTransfer -> String -> CM ()
badRcvFileChunk RcvFileTransfer
ft String
"incorrect chunk size"
              else do
                RcvFileTransfer -> Integer -> ByteString -> Bool -> CM ()
appendFileChunk RcvFileTransfer
ft Integer
chunkNo ByteString
chunk Bool
True
                AChatItem
ci <- (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem)
-> (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                  IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Connection -> GroupMemberId -> FileStatus -> IO ()
updateRcvFileStatus Connection
db GroupMemberId
fileId FileStatus
FSComplete
                    Connection -> User -> GroupMemberId -> CIFileStatus 'MDRcv -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> GroupMemberId -> CIFileStatus d -> IO ()
updateCIFileStatus Connection
db User
user GroupMemberId
fileId CIFileStatus 'MDRcv
CIFSRcvComplete
                    Connection -> RcvFileTransfer -> IO ()
deleteRcvFileChunks Connection
db RcvFileTransfer
ft
                  Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO AChatItem
getChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
                ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtRcvFileComplete User
user AChatItem
ci
                (Connection -> CM ()) -> Maybe Connection -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ByteString -> CM ()
deleteAgentConnectionAsync (ByteString -> CM ())
-> (Connection -> ByteString) -> Connection -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> ByteString
aConnId) Maybe Connection
conn_
          RcvChunkStatus
RcvChunkDuplicate -> Text -> ByteString -> MsgMeta -> CM () -> CM ()
withAckMessage' Text
"file msg" ByteString
agentConnId MsgMeta
meta (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          RcvChunkStatus
RcvChunkError -> RcvFileTransfer -> String -> CM ()
badRcvFileChunk RcvFileTransfer
ft (String -> CM ()) -> String -> CM ()
forall a b. (a -> b) -> a -> b
$ String
"incorrect chunk number " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
chunkNo

    processUserContactRequest :: AEvent e -> ConnectionEntity -> Connection -> UserContact -> CM ()
    processUserContactRequest :: forall (e :: AEntity).
AEvent e -> ConnectionEntity -> Connection -> UserContact -> CM ()
processUserContactRequest AEvent e
agentMsg ConnectionEntity
connEntity Connection
conn UserContact {userContactLinkId :: UserContact -> GroupMemberId
userContactLinkId = GroupMemberId
uclId} = case AEvent e
agentMsg of
      REQ ByteString
invId PQSupport
pqSupport NonEmpty SMPServer
_ ByteString
connInfo -> do
        ChatMessage {VersionRangeChat
chatVRange :: forall (e :: MsgEncoding). ChatMessage e -> VersionRangeChat
chatVRange :: VersionRangeChat
chatVRange, ChatMsgEvent 'Json
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent 'Json
chatMsgEvent} <- Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage Connection
conn ByteString
connInfo
        case ChatMsgEvent 'Json
chatMsgEvent of
          XContact Profile
p Maybe XContactId
xContactId_ Maybe SharedMsgId
welcomeMsgId_ Maybe (SharedMsgId, MsgContent)
requestMsg_ -> ByteString
-> VersionRangeChat
-> Profile
-> Maybe XContactId
-> Maybe SharedMsgId
-> Maybe (SharedMsgId, MsgContent)
-> PQSupport
-> CM ()
profileContactRequest ByteString
invId VersionRangeChat
chatVRange Profile
p Maybe XContactId
xContactId_ Maybe SharedMsgId
welcomeMsgId_ Maybe (SharedMsgId, MsgContent)
requestMsg_ PQSupport
pqSupport
          XInfo Profile
p -> ByteString
-> VersionRangeChat
-> Profile
-> Maybe XContactId
-> Maybe SharedMsgId
-> Maybe (SharedMsgId, MsgContent)
-> PQSupport
-> CM ()
profileContactRequest ByteString
invId VersionRangeChat
chatVRange Profile
p Maybe XContactId
forall a. Maybe a
Nothing Maybe SharedMsgId
forall a. Maybe a
Nothing Maybe (SharedMsgId, MsgContent)
forall a. Maybe a
Nothing PQSupport
pqSupport
          -- TODO show/log error, other events in contact request
          ChatMsgEvent 'Json
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      MERR GroupMemberId
_ AgentErrorType
err -> do
        ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
err (ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) (ConnectionEntity -> Maybe ConnectionEntity
forall a. a -> Maybe a
Just ConnectionEntity
connEntity)
        ConnectionEntity -> Connection -> AgentErrorType -> CM ()
processConnMERR ConnectionEntity
connEntity Connection
conn AgentErrorType
err
      ERR AgentErrorType
err -> do
        ChatError -> CM ()
eToView (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
err (ByteString -> AgentConnId
AgentConnId ByteString
agentConnId) (ConnectionEntity -> Maybe ConnectionEntity
forall a. a -> Maybe a
Just ConnectionEntity
connEntity)
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
corrId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection
conn AEvent e
agentMsg ((CommandData -> CM ()) -> CM ())
-> (CommandData -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \CommandData
_cmdData -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      -- TODO add debugging output
      AEvent e
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> PQSupport -> CM ()
        profileContactRequest :: ByteString
-> VersionRangeChat
-> Profile
-> Maybe XContactId
-> Maybe SharedMsgId
-> Maybe (SharedMsgId, MsgContent)
-> PQSupport
-> CM ()
profileContactRequest ByteString
invId VersionRangeChat
chatVRange p :: Profile
p@Profile {Text
displayName :: Text
displayName :: Profile -> Text
displayName} Maybe XContactId
xContactId_ Maybe SharedMsgId
welcomeMsgId_ Maybe (SharedMsgId, MsgContent)
requestMsg_ PQSupport
reqPQSup = do
          (UserContactLink
ucl, Maybe GroupLinkInfo
gLinkInfo_) <- (Connection
 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo))
-> CM (UserContactLink, Maybe GroupLinkInfo)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection
  -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo))
 -> CM (UserContactLink, Maybe GroupLinkInfo))
-> (Connection
    -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo))
-> CM (UserContactLink, Maybe GroupLinkInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
getUserContactLinkById Connection
db GroupMemberId
userId GroupMemberId
uclId
          let v :: Version ChatVersion
v = VersionRangeChat -> Version ChatVersion
forall v. VersionRange v -> Version v
maxVersion VersionRangeChat
chatVRange
          case Maybe GroupLinkInfo
gLinkInfo_ of
            -- ##### Contact requests (regular and business contacts) #####
            Maybe GroupLinkInfo
Nothing -> do
              let UserContactLink {connLinkContact :: UserContactLink -> CreatedLinkContact
connLinkContact = CCLink ConnectionRequestUri 'CMContact
connReq Maybe (ConnShortLink 'CMContact)
_, Bool
shortLinkDataSet :: Bool
shortLinkDataSet :: UserContactLink -> Bool
shortLinkDataSet, AddressSettings
addressSettings :: UserContactLink -> AddressSettings
addressSettings :: AddressSettings
addressSettings} = UserContactLink
ucl
                  AddressSettings {Maybe AutoAccept
autoAccept :: Maybe AutoAccept
autoAccept :: AddressSettings -> Maybe AutoAccept
autoAccept} = AddressSettings
addressSettings
                  isSimplexTeam :: Bool
isSimplexTeam = ConnectionRequestUri 'CMContact
-> ConnectionRequestUri 'CMContact -> Bool
sameConnReqContact ConnectionRequestUri 'CMContact
connReq ConnectionRequestUri 'CMContact
adminContactReq
              TVar ChaChaDRG
gVar <- (ChatController -> TVar ChaChaDRG)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar ChaChaDRG
random
              (Connection -> ExceptT StoreError IO RequestStage)
-> CM RequestStage
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> TVar ChaChaDRG
-> VersionRangeChat
-> User
-> GroupMemberId
-> UserContactLink
-> Bool
-> ByteString
-> VersionRangeChat
-> Profile
-> Maybe XContactId
-> Maybe SharedMsgId
-> Maybe (SharedMsgId, MsgContent)
-> PQSupport
-> ExceptT StoreError IO RequestStage
createOrUpdateContactRequest Connection
db TVar ChaChaDRG
gVar VersionRangeChat
vr User
user GroupMemberId
uclId UserContactLink
ucl Bool
isSimplexTeam ByteString
invId VersionRangeChat
chatVRange Profile
p Maybe XContactId
xContactId_ Maybe SharedMsgId
welcomeMsgId_ Maybe (SharedMsgId, MsgContent)
requestMsg_ PQSupport
reqPQSup) CM RequestStage -> (RequestStage -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                RSAcceptedRequest Maybe UserContactRequest
_ucr RequestEntity
re -> case RequestEntity
re of
                  REContact Contact
ct ->
                    -- TODO [short links] update request msg
                    ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> ChatEvent
CEvtContactRequestAlreadyAccepted User
user Contact
ct
                  REBusinessChat GroupInfo
gInfo GroupMember
_clientMember ->
                    -- TODO [short links] update request msg
                    ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> ChatEvent
CEvtBusinessRequestAlreadyAccepted User
user GroupInfo
gInfo
                RSCurrentRequest Maybe UserContactRequest
prevUcr_ ucr :: UserContactRequest
ucr@UserContactRequest {Maybe SharedMsgId
welcomeSharedMsgId :: UserContactRequest -> Maybe SharedMsgId
welcomeSharedMsgId :: Maybe SharedMsgId
welcomeSharedMsgId} Maybe RequestEntity
re_ -> case Maybe RequestEntity
re_ of
                  Maybe RequestEntity
Nothing -> ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> UserContactRequest -> Maybe AChat -> ChatEvent
CEvtReceivedContactRequest User
user UserContactRequest
ucr Maybe AChat
forall a. Maybe a
Nothing
                  Just (REContact Contact
ct) -> do
                    let cd :: ChatDirection 'CTDirect 'MDRcv
cd = Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct
                    Maybe AChatItem
aci_ <- case Maybe UserContactRequest
prevUcr_ of
                      Just UserContactRequest {requestSharedMsgId :: UserContactRequest -> Maybe SharedMsgId
requestSharedMsgId = Maybe SharedMsgId
prevSharedMsgId_} ->
                        -- TODO [short links] this branch does not update feature items and e2e items, as they are highly unlikely to change
                        -- they will be updated after connection is accepted.
                        ChatDirection 'CTDirect 'MDRcv
-> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId)
-> CM (Maybe AChatItem)
upsertDirectRequestItem ChatDirection 'CTDirect 'MDRcv
cd (Maybe (SharedMsgId, MsgContent)
requestMsg_, Maybe SharedMsgId
prevSharedMsgId_)
                      Maybe UserContactRequest
Nothing -> do
                        CM AChatItem -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM AChatItem -> CM ()) -> CM AChatItem -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> ChatDirection 'CTDirect 'MDSnd
-> Bool
-> CIContent 'MDSnd
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
createChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectSnd Contact
ct) Bool
False CIContent 'MDSnd
CIChatBanner Maybe SharedMsgId
forall a. Maybe a
Nothing (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
epochStart)
                        let e2eContent :: CIContent 'MDRcv
e2eContent = E2EInfo -> CIContent 'MDRcv
CIRcvDirectE2EEInfo (E2EInfo -> CIContent 'MDRcv) -> E2EInfo -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ Maybe PQEncryption -> E2EInfo
E2EInfo (Maybe PQEncryption -> E2EInfo) -> Maybe PQEncryption -> E2EInfo
forall a b. (a -> b) -> a -> b
$ PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just (PQEncryption -> Maybe PQEncryption)
-> PQEncryption -> Maybe PQEncryption
forall a b. (a -> b) -> a -> b
$ PQSupport -> PQEncryption
CR.pqSupportToEnc (PQSupport -> PQEncryption) -> PQSupport -> PQEncryption
forall a b. (a -> b) -> a -> b
$ PQSupport
reqPQSup
                        CM AChatItem -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM AChatItem -> CM ()) -> CM AChatItem -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> ChatDirection 'CTDirect 'MDRcv
-> Bool
-> CIContent 'MDRcv
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
createChatItem User
user ChatDirection 'CTDirect 'MDRcv
cd Bool
False CIContent 'MDRcv
e2eContent Maybe SharedMsgId
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing
                        ExceptT ChatError (ReaderT ChatController IO) [AChatItem] -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) [AChatItem]
 -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) [AChatItem]
-> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> Contact
-> ExceptT ChatError (ReaderT ChatController IO) [AChatItem]
createFeatureEnabledItems_ User
user Contact
ct
                        Maybe MsgContent -> (MsgContent -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (AddressSettings -> Maybe MsgContent
autoReply AddressSettings
addressSettings) ((MsgContent -> CM ()) -> CM ()) -> (MsgContent -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \MsgContent
mc -> Maybe SharedMsgId -> (SharedMsgId -> CM AChatItem) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe SharedMsgId
welcomeSharedMsgId ((SharedMsgId -> CM AChatItem) -> CM ())
-> (SharedMsgId -> CM AChatItem) -> CM ()
forall a b. (a -> b) -> a -> b
$ \SharedMsgId
sharedMsgId ->
                          User
-> ChatDirection 'CTDirect 'MDSnd
-> Bool
-> CIContent 'MDSnd
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
createChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectSnd Contact
ct) Bool
False (MsgContent -> CIContent 'MDSnd
CISndMsgContent MsgContent
mc) (SharedMsgId -> Maybe SharedMsgId
forall a. a -> Maybe a
Just SharedMsgId
sharedMsgId) Maybe UTCTime
forall a. Maybe a
Nothing
                        ((SharedMsgId, MsgContent) -> CM AChatItem)
-> Maybe (SharedMsgId, MsgContent) -> CM (Maybe AChatItem)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (ChatDirection 'CTDirect 'MDRcv
-> (SharedMsgId, MsgContent) -> CM AChatItem
forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem
createRequestItem ChatDirection 'CTDirect 'MDRcv
cd) Maybe (SharedMsgId, MsgContent)
requestMsg_
                    case Maybe AutoAccept
autoAccept of
                      Maybe AutoAccept
Nothing -> do
                        let cInfo :: ChatInfo 'CTDirect
cInfo = Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct
                            chat :: AChat
chat = SChatType 'CTDirect -> Chat 'CTDirect -> AChat
forall (c :: ChatType).
ChatTypeI c =>
SChatType c -> Chat c -> AChat
AChat SChatType 'CTDirect
SCTDirect (Chat 'CTDirect -> AChat) -> Chat 'CTDirect -> AChat
forall a b. (a -> b) -> a -> b
$ case Maybe AChatItem
aci_ of
                              Just (AChatItem SChatType c
SCTDirect SMsgDirection d
dir ChatInfo c
_ ChatItem c d
ci) -> ChatInfo 'CTDirect
-> [CChatItem 'CTDirect] -> ChatStats -> Chat 'CTDirect
forall (c :: ChatType).
ChatInfo c -> [CChatItem c] -> ChatStats -> Chat c
Chat ChatInfo 'CTDirect
cInfo [SMsgDirection d -> ChatItem c d -> CChatItem c
forall (c :: ChatType) (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d -> ChatItem c d -> CChatItem c
CChatItem SMsgDirection d
dir ChatItem c d
ci] ChatStats
emptyChatStats {unreadCount = 1, minUnreadItemId = chatItemId' ci}
                              Maybe AChatItem
_ -> ChatInfo 'CTDirect
-> [CChatItem 'CTDirect] -> ChatStats -> Chat 'CTDirect
forall (c :: ChatType).
ChatInfo c -> [CChatItem c] -> ChatStats -> Chat c
Chat ChatInfo 'CTDirect
cInfo [] ChatStats
emptyChatStats
                        ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> UserContactRequest -> Maybe AChat -> ChatEvent
CEvtReceivedContactRequest User
user UserContactRequest
ucr (Maybe AChat -> ChatEvent) -> Maybe AChat -> ChatEvent
forall a b. (a -> b) -> a -> b
$ AChat -> Maybe AChat
forall a. a -> Maybe a
Just AChat
chat
                      Just AutoAccept {Bool
acceptIncognito :: Bool
acceptIncognito :: AutoAccept -> Bool
acceptIncognito} -> do
                        Maybe IncognitoProfile
incognitoProfile <-
                          if Bool -> Bool
not Bool
shortLinkDataSet Bool -> Bool -> Bool
&& Bool
acceptIncognito
                            then IncognitoProfile -> Maybe IncognitoProfile
forall a. a -> Maybe a
Just (IncognitoProfile -> Maybe IncognitoProfile)
-> (Profile -> IncognitoProfile)
-> Profile
-> Maybe IncognitoProfile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Profile -> IncognitoProfile
NewIncognito (Profile -> Maybe IncognitoProfile)
-> ExceptT ChatError (ReaderT ChatController IO) Profile
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe IncognitoProfile)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Profile -> ExceptT ChatError (ReaderT ChatController IO) Profile
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Profile
generateRandomProfile
                            else Maybe IncognitoProfile
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe IncognitoProfile)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IncognitoProfile
forall a. Maybe a
Nothing
                        Contact
ct' <- User
-> GroupMemberId
-> Contact
-> UserContactRequest
-> Maybe IncognitoProfile
-> CM Contact
acceptContactRequestAsync User
user GroupMemberId
uclId Contact
ct UserContactRequest
ucr Maybe IncognitoProfile
incognitoProfile
                        ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> ChatEvent
CEvtAcceptingContactRequest User
user Contact
ct'
                  Just (REBusinessChat GroupInfo
gInfo GroupMember
clientMember) -> do
                    (GroupInfo
_gInfo', GroupMember
_clientMember') <- User
-> GroupMemberId
-> GroupInfo
-> GroupMember
-> UserContactRequest
-> CM (GroupInfo, GroupMember)
acceptBusinessJoinRequestAsync User
user GroupMemberId
uclId GroupInfo
gInfo GroupMember
clientMember UserContactRequest
ucr
                    let cd :: ChatDirection 'CTGroup 'MDRcv
cd = GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing GroupMember
clientMember
                    CM (Maybe AChatItem) -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM (Maybe AChatItem) -> CM ()) -> CM (Maybe AChatItem) -> CM ()
forall a b. (a -> b) -> a -> b
$ case Maybe UserContactRequest
prevUcr_ of
                      Just UserContactRequest {requestSharedMsgId :: UserContactRequest -> Maybe SharedMsgId
requestSharedMsgId = Maybe SharedMsgId
prevSharedMsgId_} ->
                        -- TODO [short links] this branch does not update feature items and e2e items, as they are highly unlikely to change
                        -- they will be updated after connection is accepted.
                        ChatDirection 'CTGroup 'MDRcv
-> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId)
-> CM (Maybe AChatItem)
upsertBusinessRequestItem ChatDirection 'CTGroup 'MDRcv
cd (Maybe (SharedMsgId, MsgContent)
requestMsg_, Maybe SharedMsgId
prevSharedMsgId_)
                      Maybe UserContactRequest
Nothing -> do
                        CM AChatItem -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM AChatItem -> CM ()) -> CM AChatItem -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> ChatDirection 'CTGroup 'MDSnd
-> Bool
-> CIContent 'MDSnd
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
createChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDSnd
CDGroupSnd GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing) Bool
False CIContent 'MDSnd
CIChatBanner Maybe SharedMsgId
forall a. Maybe a
Nothing (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
epochStart)
                        -- TODO [short links] possibly, we can just keep them created where they are created on the business side due to auto-accept
                        -- let e2eContent = CIRcvGroupE2EEInfo $ E2EInfo $ Just False -- no PQ encryption in groups
                        -- void $ createChatItem user cd False e2eContent Nothing Nothing
                        -- void $ createFeatureEnabledItems_ user ct
                        Maybe MsgContent -> (MsgContent -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (AddressSettings -> Maybe MsgContent
autoReply AddressSettings
addressSettings) ((MsgContent -> CM ()) -> CM ()) -> (MsgContent -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \MsgContent
arMC -> Maybe SharedMsgId -> (SharedMsgId -> CM AChatItem) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe SharedMsgId
welcomeSharedMsgId ((SharedMsgId -> CM AChatItem) -> CM ())
-> (SharedMsgId -> CM AChatItem) -> CM ()
forall a b. (a -> b) -> a -> b
$ \SharedMsgId
sharedMsgId ->
                          User
-> ChatDirection 'CTGroup 'MDSnd
-> Bool
-> CIContent 'MDSnd
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
createChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDSnd
CDGroupSnd GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing) Bool
False (MsgContent -> CIContent 'MDSnd
CISndMsgContent MsgContent
arMC) (SharedMsgId -> Maybe SharedMsgId
forall a. a -> Maybe a
Just SharedMsgId
sharedMsgId) Maybe UTCTime
forall a. Maybe a
Nothing
                        ((SharedMsgId, MsgContent) -> CM AChatItem)
-> Maybe (SharedMsgId, MsgContent) -> CM (Maybe AChatItem)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (ChatDirection 'CTGroup 'MDRcv
-> (SharedMsgId, MsgContent) -> CM AChatItem
forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem
createRequestItem ChatDirection 'CTGroup 'MDRcv
cd) Maybe (SharedMsgId, MsgContent)
requestMsg_
                    ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> ChatEvent
CEvtAcceptingBusinessRequest User
user GroupInfo
gInfo
              where
                upsertDirectRequestItem :: ChatDirection 'CTDirect 'MDRcv -> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId) -> CM (Maybe AChatItem)
                upsertDirectRequestItem :: ChatDirection 'CTDirect 'MDRcv
-> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId)
-> CM (Maybe AChatItem)
upsertDirectRequestItem cd :: ChatDirection 'CTDirect 'MDRcv
cd@(CDDirectRcv ct :: Contact
ct@Contact {GroupMemberId
contactId :: Contact -> GroupMemberId
contactId :: GroupMemberId
contactId}) = ChatDirection 'CTDirect 'MDRcv
-> ((SharedMsgId, MsgContent) -> CM (Maybe AChatItem))
-> (SharedMsgId -> CM ())
-> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId)
-> CM (Maybe AChatItem)
forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv
-> ((SharedMsgId, MsgContent) -> CM (Maybe AChatItem))
-> (SharedMsgId -> CM ())
-> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId)
-> CM (Maybe AChatItem)
upsertRequestItem ChatDirection 'CTDirect 'MDRcv
cd (SharedMsgId, MsgContent) -> CM (Maybe AChatItem)
updateRequestItem SharedMsgId -> CM ()
markRequestItemDeleted
                  where
                    updateRequestItem :: (SharedMsgId, MsgContent) -> CM (Maybe AChatItem)
updateRequestItem (SharedMsgId
sharedMsgId, MsgContent
mc) =
                      (Connection -> ExceptT StoreError IO (CChatItem 'CTDirect))
-> CM (CChatItem 'CTDirect)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> User
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItemBySharedMsgId Connection
db User
user GroupMemberId
contactId SharedMsgId
sharedMsgId) CM (CChatItem 'CTDirect)
-> (CChatItem 'CTDirect -> CM (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        CChatItem SMsgDirection d
SMDRcv ci :: ChatItem 'CTDirect d
ci@ChatItem {content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content = CIRcvMsgContent MsgContent
oldMC}
                          | MsgContent
mc MsgContent -> MsgContent -> Bool
forall a. Eq a => a -> a -> Bool
/= MsgContent
oldMC -> do
                              UTCTime
currentTs <- IO UTCTime -> ExceptT ChatError (ReaderT ChatController IO) UTCTime
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                              AChatItem
aci <- (Connection -> IO AChatItem) -> CM AChatItem
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO AChatItem) -> CM AChatItem)
-> (Connection -> IO AChatItem) -> CM AChatItem
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                                Connection
-> GroupMemberId
-> (UTCTime, MsgContent)
-> (UTCTime, MsgContent)
-> IO ()
addInitialAndNewCIVersions Connection
db (ChatItem 'CTDirect d -> GroupMemberId
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> GroupMemberId
chatItemId' ChatItem 'CTDirect d
ci) (ChatItem 'CTDirect d -> UTCTime
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> UTCTime
chatItemTs' ChatItem 'CTDirect d
ci, MsgContent
oldMC) (UTCTime
currentTs, MsgContent
mc)
                                ChatItem 'CTDirect 'MDRcv -> AChatItem
aChatItem (ChatItem 'CTDirect 'MDRcv -> AChatItem)
-> IO (ChatItem 'CTDirect 'MDRcv) -> IO AChatItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> User
-> GroupMemberId
-> ChatItem 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe GroupMemberId
-> IO (ChatItem 'CTDirect 'MDRcv)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupMemberId
-> ChatItem 'CTDirect d
-> CIContent d
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe GroupMemberId
-> IO (ChatItem 'CTDirect d)
updateDirectChatItem' Connection
db User
user GroupMemberId
contactId ChatItem 'CTDirect d
ChatItem 'CTDirect 'MDRcv
ci (MsgContent -> CIContent 'MDRcv
CIRcvMsgContent MsgContent
mc) Bool
True Bool
False Maybe CITimed
forall a. Maybe a
Nothing Maybe GroupMemberId
forall a. Maybe a
Nothing
                              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemUpdated User
user AChatItem
aci
                              Maybe AChatItem -> CM (Maybe AChatItem)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe AChatItem -> CM (Maybe AChatItem))
-> Maybe AChatItem -> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ AChatItem -> Maybe AChatItem
forall a. a -> Maybe a
Just AChatItem
aci
                          | Bool
otherwise -> Maybe AChatItem -> CM (Maybe AChatItem)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe AChatItem -> CM (Maybe AChatItem))
-> Maybe AChatItem -> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ AChatItem -> Maybe AChatItem
forall a. a -> Maybe a
Just (AChatItem -> Maybe AChatItem) -> AChatItem -> Maybe AChatItem
forall a b. (a -> b) -> a -> b
$ ChatItem 'CTDirect 'MDRcv -> AChatItem
aChatItem ChatItem 'CTDirect d
ChatItem 'CTDirect 'MDRcv
ci
                        CChatItem 'CTDirect
_ -> Maybe AChatItem -> CM (Maybe AChatItem)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AChatItem
forall a. Maybe a
Nothing
                      where
                        aChatItem :: ChatItem 'CTDirect 'MDRcv -> AChatItem
aChatItem = SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv (Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct)
                    markRequestItemDeleted :: SharedMsgId -> CM ()
markRequestItemDeleted SharedMsgId
sharedMsgId =
                      (Connection -> IO (Either StoreError (CChatItem 'CTDirect)))
-> CM (Either StoreError (CChatItem 'CTDirect))
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO (CChatItem 'CTDirect)
-> IO (Either StoreError (CChatItem 'CTDirect))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO (CChatItem 'CTDirect)
 -> IO (Either StoreError (CChatItem 'CTDirect)))
-> ExceptT StoreError IO (CChatItem 'CTDirect)
-> IO (Either StoreError (CChatItem 'CTDirect))
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItemBySharedMsgId Connection
db User
user GroupMemberId
contactId SharedMsgId
sharedMsgId) CM (Either StoreError (CChatItem 'CTDirect))
-> (Either StoreError (CChatItem 'CTDirect) -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Right (cci :: CChatItem 'CTDirect
cci@(CChatItem SMsgDirection d
SMDRcv ChatItem 'CTDirect d
_)) -> do
                          UTCTime
currentTs <- IO UTCTime -> ExceptT ChatError (ReaderT ChatController IO) UTCTime
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                          [ChatItemDeletion]
deletions <- if SChatFeature 'CFFullDelete
-> (PrefEnabled -> Bool) -> Contact -> Bool
forall (f :: ChatFeature).
SChatFeature f -> (PrefEnabled -> Bool) -> Contact -> Bool
featureAllowed SChatFeature 'CFFullDelete
SCFFullDelete PrefEnabled -> Bool
forContact Contact
ct
                            then User -> Contact -> [CChatItem 'CTDirect] -> CM [ChatItemDeletion]
deleteDirectCIs User
user Contact
ct [Item [CChatItem 'CTDirect]
CChatItem 'CTDirect
cci]
                            else User
-> Contact
-> [CChatItem 'CTDirect]
-> UTCTime
-> CM [ChatItemDeletion]
markDirectCIsDeleted User
user Contact
ct [Item [CChatItem 'CTDirect]
CChatItem 'CTDirect
cci] UTCTime
currentTs
                          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [ChatItemDeletion] -> Bool -> Bool -> ChatEvent
CEvtChatItemsDeleted User
user [ChatItemDeletion]
deletions Bool
False Bool
False
                        Either StoreError (CChatItem 'CTDirect)
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                upsertBusinessRequestItem :: ChatDirection 'CTGroup 'MDRcv -> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId) -> CM (Maybe AChatItem)
                upsertBusinessRequestItem :: ChatDirection 'CTGroup 'MDRcv
-> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId)
-> CM (Maybe AChatItem)
upsertBusinessRequestItem cd :: ChatDirection 'CTGroup 'MDRcv
cd@(CDGroupRcv gInfo :: GroupInfo
gInfo@GroupInfo {GroupMemberId
groupId :: GroupInfo -> GroupMemberId
groupId :: GroupMemberId
groupId} Maybe GroupChatScopeInfo
_ GroupMember
clientMember) = ChatDirection 'CTGroup 'MDRcv
-> ((SharedMsgId, MsgContent) -> CM (Maybe AChatItem))
-> (SharedMsgId -> CM ())
-> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId)
-> CM (Maybe AChatItem)
forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv
-> ((SharedMsgId, MsgContent) -> CM (Maybe AChatItem))
-> (SharedMsgId -> CM ())
-> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId)
-> CM (Maybe AChatItem)
upsertRequestItem ChatDirection 'CTGroup 'MDRcv
cd (SharedMsgId, MsgContent) -> CM (Maybe AChatItem)
updateRequestItem SharedMsgId -> CM ()
markRequestItemDeleted
                  where
                    updateRequestItem :: (SharedMsgId, MsgContent) -> CM (Maybe AChatItem)
updateRequestItem (SharedMsgId
sharedMsgId, MsgContent
mc) =
                      (Connection -> ExceptT StoreError IO (CChatItem 'CTGroup))
-> CM (CChatItem 'CTGroup)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> User
-> GroupInfo
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItemBySharedMsgId Connection
db User
user GroupInfo
gInfo (GroupMember -> GroupMemberId
groupMemberId' GroupMember
clientMember) SharedMsgId
sharedMsgId) CM (CChatItem 'CTGroup)
-> (CChatItem 'CTGroup -> CM (Maybe AChatItem))
-> CM (Maybe AChatItem)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        CChatItem SMsgDirection d
SMDRcv ci :: ChatItem 'CTGroup d
ci@ChatItem {chatDir :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIDirection c d
chatDir = CIGroupRcv GroupMember
m', content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content = CIRcvMsgContent MsgContent
oldMC}
                          | MemberId -> GroupMember -> Bool
sameMemberId (GroupMember -> MemberId
memberId' GroupMember
clientMember) GroupMember
m' ->
                              if MsgContent
mc MsgContent -> MsgContent -> Bool
forall a. Eq a => a -> a -> Bool
/= MsgContent
oldMC
                                then do
                                  UTCTime
currentTs <- IO UTCTime -> ExceptT ChatError (ReaderT ChatController IO) UTCTime
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                                  AChatItem
aci <- (Connection -> IO AChatItem) -> CM AChatItem
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO AChatItem) -> CM AChatItem)
-> (Connection -> IO AChatItem) -> CM AChatItem
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                                    Connection
-> GroupMemberId
-> (UTCTime, MsgContent)
-> (UTCTime, MsgContent)
-> IO ()
addInitialAndNewCIVersions Connection
db (ChatItem 'CTGroup d -> GroupMemberId
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> GroupMemberId
chatItemId' ChatItem 'CTGroup d
ci) (ChatItem 'CTGroup d -> UTCTime
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> UTCTime
chatItemTs' ChatItem 'CTGroup d
ci, MsgContent
oldMC) (UTCTime
currentTs, MsgContent
mc)
                                    ChatItem 'CTGroup 'MDRcv -> AChatItem
aChatItem (ChatItem 'CTGroup 'MDRcv -> AChatItem)
-> IO (ChatItem 'CTGroup 'MDRcv) -> IO AChatItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> User
-> GroupMemberId
-> ChatItem 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Bool
-> Bool
-> Maybe GroupMemberId
-> IO (ChatItem 'CTGroup 'MDRcv)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupMemberId
-> ChatItem 'CTGroup d
-> CIContent d
-> Bool
-> Bool
-> Maybe GroupMemberId
-> IO (ChatItem 'CTGroup d)
updateGroupChatItem Connection
db User
user GroupMemberId
groupId ChatItem 'CTGroup d
ChatItem 'CTGroup 'MDRcv
ci (MsgContent -> CIContent 'MDRcv
CIRcvMsgContent MsgContent
mc) Bool
True Bool
False Maybe GroupMemberId
forall a. Maybe a
Nothing
                                  ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemUpdated User
user AChatItem
aci
                                  Maybe AChatItem -> CM (Maybe AChatItem)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe AChatItem -> CM (Maybe AChatItem))
-> Maybe AChatItem -> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ AChatItem -> Maybe AChatItem
forall a. a -> Maybe a
Just AChatItem
aci
                                else Maybe AChatItem -> CM (Maybe AChatItem)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe AChatItem -> CM (Maybe AChatItem))
-> Maybe AChatItem -> CM (Maybe AChatItem)
forall a b. (a -> b) -> a -> b
$ AChatItem -> Maybe AChatItem
forall a. a -> Maybe a
Just (AChatItem -> Maybe AChatItem) -> AChatItem -> Maybe AChatItem
forall a b. (a -> b) -> a -> b
$ ChatItem 'CTGroup 'MDRcv -> AChatItem
aChatItem ChatItem 'CTGroup d
ChatItem 'CTGroup 'MDRcv
ci
                        CChatItem 'CTGroup
_ -> Maybe AChatItem -> CM (Maybe AChatItem)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AChatItem
forall a. Maybe a
Nothing
                      where
                        aChatItem :: ChatItem 'CTGroup 'MDRcv -> AChatItem
aChatItem = SChatType 'CTGroup
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTGroup
-> ChatItem 'CTGroup 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTGroup
SCTGroup SMsgDirection 'MDRcv
SMDRcv (GroupInfo -> Maybe GroupChatScopeInfo -> ChatInfo 'CTGroup
GroupChat GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing)
                    markRequestItemDeleted :: SharedMsgId -> CM ()
markRequestItemDeleted SharedMsgId
sharedMsgId =
                      (Connection -> IO (Either StoreError (CChatItem 'CTGroup)))
-> CM (Either StoreError (CChatItem 'CTGroup))
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO (CChatItem 'CTGroup)
-> IO (Either StoreError (CChatItem 'CTGroup))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO (CChatItem 'CTGroup)
 -> IO (Either StoreError (CChatItem 'CTGroup)))
-> ExceptT StoreError IO (CChatItem 'CTGroup)
-> IO (Either StoreError (CChatItem 'CTGroup))
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> GroupInfo
-> MemberId
-> SharedMsgId
-> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupMemberCIBySharedMsgId Connection
db User
user GroupInfo
gInfo (GroupMember -> MemberId
memberId' GroupMember
clientMember) SharedMsgId
sharedMsgId) CM (Either StoreError (CChatItem 'CTGroup))
-> (Either StoreError (CChatItem 'CTGroup) -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Right cci :: CChatItem 'CTGroup
cci@(CChatItem SMsgDirection d
SMDRcv ChatItem {chatDir :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIDirection c d
chatDir = CIGroupRcv GroupMember
m'})
                          | MemberId -> GroupMember -> Bool
sameMemberId (GroupMember -> MemberId
memberId' GroupMember
clientMember) GroupMember
m' -> do
                              UTCTime
currentTs <- IO UTCTime -> ExceptT ChatError (ReaderT ChatController IO) UTCTime
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
                              [ChatItemDeletion]
deletions <- if SGroupFeature 'GFFullDelete -> GroupMember -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupMember -> GroupInfo -> Bool
groupFeatureMemberAllowed SGroupFeature 'GFFullDelete
SGFFullDelete GroupMember
clientMember GroupInfo
gInfo
                                then User
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> [CChatItem 'CTGroup]
-> Maybe GroupMember
-> UTCTime
-> CM [ChatItemDeletion]
deleteGroupCIs User
user GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing [Item [CChatItem 'CTGroup]
CChatItem 'CTGroup
cci] Maybe GroupMember
forall a. Maybe a
Nothing UTCTime
currentTs
                                else User
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> [CChatItem 'CTGroup]
-> Maybe GroupMember
-> UTCTime
-> CM [ChatItemDeletion]
markGroupCIsDeleted User
user GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing [Item [CChatItem 'CTGroup]
CChatItem 'CTGroup
cci] Maybe GroupMember
forall a. Maybe a
Nothing UTCTime
currentTs
                              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [ChatItemDeletion] -> Bool -> Bool -> ChatEvent
CEvtChatItemsDeleted User
user [ChatItemDeletion]
deletions Bool
False Bool
False
                        Either StoreError (CChatItem 'CTGroup)
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                createRequestItem :: ChatTypeI c => ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem
                createRequestItem :: forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem
createRequestItem ChatDirection c 'MDRcv
cd (SharedMsgId
sharedMsgId, MsgContent
mc) = do
                  AChatItem
aci <- User
-> ChatDirection c 'MDRcv
-> Bool
-> CIContent 'MDRcv
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
createChatItem User
user ChatDirection c 'MDRcv
cd Bool
False (MsgContent -> CIContent 'MDRcv
CIRcvMsgContent MsgContent
mc) (SharedMsgId -> Maybe SharedMsgId
forall a. a -> Maybe a
Just SharedMsgId
sharedMsgId) Maybe UTCTime
forall a. Maybe a
Nothing
                  ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [Item [AChatItem]
AChatItem
aci]
                  AChatItem -> CM AChatItem
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AChatItem
aci
                upsertRequestItem :: ChatTypeI c => ChatDirection c 'MDRcv -> ((SharedMsgId, MsgContent) -> CM (Maybe AChatItem)) -> (SharedMsgId -> CM ()) -> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId) -> CM (Maybe AChatItem)
                upsertRequestItem :: forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv
-> ((SharedMsgId, MsgContent) -> CM (Maybe AChatItem))
-> (SharedMsgId -> CM ())
-> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId)
-> CM (Maybe AChatItem)
upsertRequestItem ChatDirection c 'MDRcv
cd (SharedMsgId, MsgContent) -> CM (Maybe AChatItem)
update SharedMsgId -> CM ()
delete = \case
                  (Just (SharedMsgId, MsgContent)
msg, Maybe SharedMsgId
Nothing) -> AChatItem -> Maybe AChatItem
forall a. a -> Maybe a
Just (AChatItem -> Maybe AChatItem)
-> CM AChatItem -> CM (Maybe AChatItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem
forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem
createRequestItem ChatDirection c 'MDRcv
cd (SharedMsgId, MsgContent)
msg
                  (Just msg :: (SharedMsgId, MsgContent)
msg@(SharedMsgId
sharedMsgId, MsgContent
_), Just SharedMsgId
prevSharedMsgId) | SharedMsgId
sharedMsgId SharedMsgId -> SharedMsgId -> Bool
forall a. Eq a => a -> a -> Bool
== SharedMsgId
prevSharedMsgId ->
                    (SharedMsgId, MsgContent) -> CM (Maybe AChatItem)
update (SharedMsgId, MsgContent)
msg CM (Maybe AChatItem)
-> (SharedMsgId -> CM (Maybe AChatItem)) -> CM (Maybe AChatItem)
forall a. CM a -> (SharedMsgId -> CM a) -> CM a
`catchCINotFound` \SharedMsgId
_ -> AChatItem -> Maybe AChatItem
forall a. a -> Maybe a
Just (AChatItem -> Maybe AChatItem)
-> CM AChatItem -> CM (Maybe AChatItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem
forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem
createRequestItem ChatDirection c 'MDRcv
cd (SharedMsgId, MsgContent)
msg
                  (Maybe (SharedMsgId, MsgContent)
Nothing, Just SharedMsgId
prevSharedMsgId) -> Maybe AChatItem
forall a. Maybe a
Nothing Maybe AChatItem -> CM () -> CM (Maybe AChatItem)
forall a b.
a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SharedMsgId -> CM ()
delete SharedMsgId
prevSharedMsgId
                  (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId)
_ -> Maybe AChatItem -> CM (Maybe AChatItem)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe AChatItem
forall a. Maybe a
Nothing
            -- ##### Group link join requests (don't create contact requests) #####
            Just gli :: GroupLinkInfo
gli@GroupLinkInfo {GroupMemberId
groupId :: GroupLinkInfo -> GroupMemberId
groupId :: GroupMemberId
groupId, memberRole :: GroupLinkInfo -> GroupMemberRole
memberRole = GroupMemberRole
gLinkMemRole} -> do
              -- TODO [short links] deduplicate request by xContactId?
              GroupInfo
gInfo <- (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo)
-> (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO GroupInfo
getGroupInfo Connection
db VersionRangeChat
vr User
user GroupMemberId
groupId
              Maybe
  (GroupInfo
   -> GroupLinkInfo
   -> Profile
   -> IO
        (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))
acceptMember_ <- (ChatController
 -> Maybe
      (GroupInfo
       -> GroupLinkInfo
       -> Profile
       -> IO
            (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe
        (GroupInfo
         -> GroupLinkInfo
         -> Profile
         -> IO
              (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ChatController
  -> Maybe
       (GroupInfo
        -> GroupLinkInfo
        -> Profile
        -> IO
             (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Maybe
         (GroupInfo
          -> GroupLinkInfo
          -> Profile
          -> IO
               (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))))
-> (ChatController
    -> Maybe
         (GroupInfo
          -> GroupLinkInfo
          -> Profile
          -> IO
               (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe
        (GroupInfo
         -> GroupLinkInfo
         -> Profile
         -> IO
              (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))))
forall a b. (a -> b) -> a -> b
$ ChatHooks
-> Maybe
     (GroupInfo
      -> GroupLinkInfo
      -> Profile
      -> IO
           (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))
acceptMember (ChatHooks
 -> Maybe
      (GroupInfo
       -> GroupLinkInfo
       -> Profile
       -> IO
            (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))))
-> (ChatController -> ChatHooks)
-> ChatController
-> Maybe
     (GroupInfo
      -> GroupLinkInfo
      -> Profile
      -> IO
           (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatConfig -> ChatHooks
chatHooks (ChatConfig -> ChatHooks)
-> (ChatController -> ChatConfig) -> ChatController -> ChatHooks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config
              ExceptT
  ChatError
  (ReaderT ChatController IO)
  (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
-> ((GroupInfo
     -> GroupLinkInfo
     -> Profile
     -> IO
          (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))
-> Maybe
     (GroupInfo
      -> GroupLinkInfo
      -> Profile
      -> IO
           (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))
-> Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
forall a b. (a -> b) -> a -> b
$ (GroupAcceptance, GroupMemberRole)
-> Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)
forall a b. b -> Either a b
Right (GroupAcceptance
GAAccepted, GroupMemberRole
gLinkMemRole)) (\GroupInfo
-> GroupLinkInfo
-> Profile
-> IO
     (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
am -> IO (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))
-> IO
     (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupLinkInfo
-> Profile
-> IO
     (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
am GroupInfo
gInfo GroupLinkInfo
gli Profile
p) Maybe
  (GroupInfo
   -> GroupLinkInfo
   -> Profile
   -> IO
        (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))
acceptMember_ ExceptT
  ChatError
  (ReaderT ChatController IO)
  (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole))
-> (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)
    -> CM ())
-> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Right (GroupAcceptance
acceptance, GroupMemberRole
useRole)
                  | Version ChatVersion
v Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
< Version ChatVersion
groupFastLinkJoinVersion ->
                      Text -> CM ()
messageError Text
"processUserContactRequest: chat version range incompatible for accepting group join request"
                  | Bool
otherwise -> do
                      let profileMode :: Maybe IncognitoProfile
profileMode = LocalProfile -> IncognitoProfile
ExistingIncognito (LocalProfile -> IncognitoProfile)
-> Maybe LocalProfile -> Maybe IncognitoProfile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GroupInfo -> Maybe LocalProfile
incognitoMembershipProfile GroupInfo
gInfo
                      GroupMember
mem <- User
-> GroupMemberId
-> GroupInfo
-> ByteString
-> VersionRangeChat
-> Profile
-> Maybe XContactId
-> Maybe SharedMsgId
-> GroupAcceptance
-> GroupMemberRole
-> Maybe IncognitoProfile
-> CM GroupMember
acceptGroupJoinRequestAsync User
user GroupMemberId
uclId GroupInfo
gInfo ByteString
invId VersionRangeChat
chatVRange Profile
p Maybe XContactId
xContactId_ Maybe SharedMsgId
welcomeMsgId_ GroupAcceptance
acceptance GroupMemberRole
useRole Maybe IncognitoProfile
profileMode
                      (GroupInfo
gInfo', GroupMember
mem', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo GroupMember
mem
                      User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
mem') (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
RGEInvitedViaGroupLink) Maybe UTCTime
forall a. Maybe a
Nothing
                      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> ChatEvent
CEvtAcceptingGroupJoinRequestMember User
user GroupInfo
gInfo' GroupMember
mem'
                Left GroupRejectionReason
rjctReason
                  | Version ChatVersion
v Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
< Version ChatVersion
groupJoinRejectVersion ->
                      Text -> CM ()
messageWarning (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"processUserContactRequest (group " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupInfo -> Text
groupName' GroupInfo
gInfo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"): joining of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
displayName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is blocked"
                  | Bool
otherwise -> do
                      GroupMember
mem <- User
-> GroupMemberId
-> GroupInfo
-> ByteString
-> VersionRangeChat
-> Profile
-> Maybe XContactId
-> GroupRejectionReason
-> CM GroupMember
acceptGroupJoinSendRejectAsync User
user GroupMemberId
uclId GroupInfo
gInfo ByteString
invId VersionRangeChat
chatVRange Profile
p Maybe XContactId
xContactId_ GroupRejectionReason
rjctReason
                      TerminalEvent -> CM ()
toViewTE (TerminalEvent -> CM ()) -> TerminalEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> GroupInfo
-> GroupMember
-> GroupRejectionReason
-> TerminalEvent
TERejectingGroupJoinRequestMember User
user GroupInfo
gInfo GroupMember
mem GroupRejectionReason
rjctReason

    memberCanSend ::
      GroupMember ->
      Maybe MsgScope ->
      CM (Maybe DeliveryJobScope) ->
      CM (Maybe DeliveryJobScope)
    memberCanSend :: GroupMember
-> Maybe MsgScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
memberCanSend m :: GroupMember
m@GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole} Maybe MsgScope
msgScope ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
a = case Maybe MsgScope
msgScope of
      Just MSMember {} -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
a
      Maybe MsgScope
Nothing
        | GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
> GroupMemberRole
GRObserver Bool -> Bool -> Bool
|| GroupMember -> Bool
memberPending GroupMember
m -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
a
        | Bool
otherwise -> Text -> CM ()
messageError Text
"member is not allowed to send messages" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing

    processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM ()
    processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM ()
processConnMERR ConnectionEntity
connEntity Connection
conn AgentErrorType
err = do
      case AgentErrorType
err of
        SMP String
_ ErrorType
SMP.AUTH -> do
          Int
authErrCounter' <- (Connection -> IO Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO Int)
 -> ExceptT ChatError (ReaderT ChatController IO) Int)
-> (Connection -> IO Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Connection -> IO Int
incAuthErrCounter Connection
db User
user Connection
conn
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
authErrCounter' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
authErrDisableCount) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ case ConnectionEntity
connEntity of
            RcvDirectMsgConnection Connection
ctConn (Just Contact
ct) -> do
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> ChatEvent
CEvtContactDisabled User
user Contact
ct {activeConn = Just ctConn {authErrCounter = authErrCounter'}}
            ConnectionEntity
_ -> ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ ConnectionEntity -> ChatEvent
CEvtConnectionDisabled ConnectionEntity
connEntity
        SMP String
_ ErrorType
SMP.QUOTA ->
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Connection -> Bool
connInactive Connection
conn) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Connection -> Int -> IO ()
setQuotaErrCounter Connection
db User
user Connection
conn Int
quotaErrSetOnMERR
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ ConnectionEntity -> Bool -> ChatEvent
CEvtConnectionInactive ConnectionEntity
connEntity Bool
True
        AgentErrorType
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    processConnMWARN :: ConnectionEntity -> Connection -> AgentErrorType -> CM ()
    processConnMWARN :: ConnectionEntity -> Connection -> AgentErrorType -> CM ()
processConnMWARN ConnectionEntity
connEntity Connection
conn AgentErrorType
err = do
      case AgentErrorType
err of
        SMP String
_ ErrorType
SMP.QUOTA ->
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Connection -> Bool
connInactive Connection
conn) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
            Int
quotaErrCounter' <- (Connection -> IO Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO Int)
 -> ExceptT ChatError (ReaderT ChatController IO) Int)
-> (Connection -> IO Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Connection -> IO Int
incQuotaErrCounter Connection
db User
user Connection
conn
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
quotaErrCounter' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
quotaErrInactiveCount) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ ConnectionEntity -> Bool -> ChatEvent
CEvtConnectionInactive ConnectionEntity
connEntity Bool
True
        AgentErrorType
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    continueSending :: ConnectionEntity -> Connection -> CM Bool
    continueSending :: ConnectionEntity
-> Connection -> ExceptT ChatError (ReaderT ChatController IO) Bool
continueSending ConnectionEntity
connEntity Connection
conn =
      if Connection -> Bool
connInactive Connection
conn
        then do
          (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Connection -> Int -> IO ()
setQuotaErrCounter Connection
db User
user Connection
conn Int
0
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ ConnectionEntity -> Bool -> ChatEvent
CEvtConnectionInactive ConnectionEntity
connEntity Bool
False
          Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

    -- TODO v5.7 / v6.0 - together with deprecating old group protocol establishing direct connections?
    -- we could save command records only for agent APIs we process continuations for (INV)
    withCompletedCommand :: forall e. AEntityI e => Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
    withCompletedCommand :: forall (e :: AEntity).
AEntityI e =>
Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
withCompletedCommand Connection {GroupMemberId
connId :: Connection -> GroupMemberId
connId :: GroupMemberId
connId} AEvent e
agentMsg CommandData -> CM ()
action = do
      let agentMsgTag :: AEvtTag
agentMsgTag = SAEntity e -> AEventTag e -> AEvtTag
forall (e :: AEntity).
AEntityI e =>
SAEntity e -> AEventTag e -> AEvtTag
AEvtTag (forall (e :: AEntity). AEntityI e => SAEntity e
sAEntity @e) (AEventTag e -> AEvtTag) -> AEventTag e -> AEvtTag
forall a b. (a -> b) -> a -> b
$ AEvent e -> AEventTag e
forall (e :: AEntity). AEvent e -> AEventTag e
aEventTag AEvent e
agentMsg
      Maybe CommandData
cmdData_ <- (Connection -> IO (Maybe CommandData)) -> CM (Maybe CommandData)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (Maybe CommandData)) -> CM (Maybe CommandData))
-> (Connection -> IO (Maybe CommandData)) -> CM (Maybe CommandData)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> ByteString -> IO (Maybe CommandData)
getCommandDataByCorrId Connection
db User
user ByteString
corrId
      case Maybe CommandData
cmdData_ of
        Just cmdData :: CommandData
cmdData@CommandData {GroupMemberId
cmdId :: GroupMemberId
cmdId :: CommandData -> GroupMemberId
cmdId, cmdConnId :: CommandData -> Maybe GroupMemberId
cmdConnId = Just GroupMemberId
cmdConnId', CommandFunction
cmdFunction :: CommandData -> CommandFunction
cmdFunction :: CommandFunction
cmdFunction}
          | GroupMemberId
connId GroupMemberId -> GroupMemberId -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberId
cmdConnId' Bool -> Bool -> Bool
&& (AEvtTag
agentMsgTag AEvtTag -> AEvtTag -> Bool
forall a. Eq a => a -> a -> Bool
== CommandFunction -> AEvtTag
commandExpectedResponse CommandFunction
cmdFunction Bool -> Bool -> Bool
|| AEvtTag
agentMsgTag AEvtTag -> AEvtTag -> Bool
forall a. Eq a => a -> a -> Bool
== SAEntity 'AEConn -> AEventTag 'AEConn -> AEvtTag
forall (e :: AEntity).
AEntityI e =>
SAEntity e -> AEventTag e -> AEvtTag
AEvtTag SAEntity 'AEConn
SAEConn AEventTag 'AEConn
ERR_) -> do
              (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> IO ()
deleteCommand Connection
db User
user GroupMemberId
cmdId
              CommandData -> CM ()
action CommandData
cmdData
          | Bool
otherwise -> GroupMemberId -> String -> CM ()
err GroupMemberId
cmdId (String -> CM ()) -> String -> CM ()
forall a b. (a -> b) -> a -> b
$ String
"not matching connection id or unexpected response, corrId = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
corrId
        Just CommandData {GroupMemberId
cmdId :: CommandData -> GroupMemberId
cmdId :: GroupMemberId
cmdId, cmdConnId :: CommandData -> Maybe GroupMemberId
cmdConnId = Maybe GroupMemberId
Nothing} -> GroupMemberId -> String -> CM ()
err GroupMemberId
cmdId (String -> CM ()) -> String -> CM ()
forall a b. (a -> b) -> a -> b
$ String
"no command connection id, corrId = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
corrId
        Maybe CommandData
Nothing -> ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ())
-> (String -> ChatErrorType) -> String -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ChatErrorType
CEAgentCommandError (String -> CM ()) -> String -> CM ()
forall a b. (a -> b) -> a -> b
$ String
"command not found, corrId = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
corrId
      where
        err :: GroupMemberId -> String -> CM ()
err GroupMemberId
cmdId String
msg = do
          (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> CommandStatus -> IO ()
updateCommandStatus Connection
db User
user GroupMemberId
cmdId CommandStatus
CSError
          ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ())
-> (String -> ChatErrorType) -> String -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ChatErrorType
CEAgentCommandError (String -> CM ()) -> String -> CM ()
forall a b. (a -> b) -> a -> b
$ String
msg

    withAckMessage' :: Text -> ConnId -> MsgMeta -> CM () -> CM ()
    withAckMessage' :: Text -> ByteString -> MsgMeta -> CM () -> CM ()
withAckMessage' Text
label ByteString
cId MsgMeta
msgMeta CM ()
action = do
      Text
-> ByteString
-> MsgMeta
-> Bool
-> Maybe (TVar [Text])
-> (Text -> CM (Bool, Bool))
-> CM ()
withAckMessage Text
label ByteString
cId MsgMeta
msgMeta Bool
False Maybe (TVar [Text])
forall a. Maybe a
Nothing ((Text -> CM (Bool, Bool)) -> CM ())
-> (Text -> CM (Bool, Bool)) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Text
_ -> CM ()
action CM () -> (Bool, Bool) -> CM (Bool, Bool)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Bool
False, Bool
False)

    withAckMessage :: Text -> ConnId -> MsgMeta -> Bool -> Maybe (TVar [Text]) -> (Text -> CM (Bool, ShouldDeleteGroupConns)) -> CM ()
    withAckMessage :: Text
-> ByteString
-> MsgMeta
-> Bool
-> Maybe (TVar [Text])
-> (Text -> CM (Bool, Bool))
-> CM ()
withAckMessage Text
label ByteString
cId MsgMeta
msgMeta Bool
showCritical Maybe (TVar [Text])
tags Text -> CM (Bool, Bool)
action = do
      -- [async agent commands] command should be asynchronous
      -- TODO catching error and sending ACK after an error, particularly if it is a database error, will result in the message not processed (and no notification to the user).
      -- Possible solutions are:
      -- 1) retry processing several times
      -- 2) stabilize database
      -- 3) show screen of death to the user asking to restart
      Text
eInfo <- ExceptT ChatError (ReaderT ChatController IO) Text
eventInfo
      Text -> CM ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logInfo (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
eInfo
      CM (Bool, Bool)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either ChatError (Bool, Bool))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors (Text -> CM (Bool, Bool)
action Text
eInfo) ExceptT
  ChatError
  (ReaderT ChatController IO)
  (Either ChatError (Bool, Bool))
-> (Either ChatError (Bool, Bool) -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right (Bool
withRcpt, Bool
shouldDelConns) ->
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
shouldDelConns (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Text -> CM () -> CM ()
withLog (Text
eInfo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ok") (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ MsgMeta -> Maybe ByteString -> CM ()
ackMsg MsgMeta
msgMeta (Maybe ByteString -> CM ()) -> Maybe ByteString -> CM ()
forall a b. (a -> b) -> a -> b
$ if Bool
withRcpt then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"" else Maybe ByteString
forall a. Maybe a
Nothing
        -- If showCritical is True, then these errors don't result in ACK and show user visible alert
        -- This prevents losing the message that failed to be processed.
        Left (ChatErrorStore SEDBBusyError {String
message :: StoreError -> String
message :: String
message}) | Bool
showCritical -> ChatError -> CM ()
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent (Bool -> String -> AgentErrorType
CRITICAL Bool
True String
message) (ByteString -> AgentConnId
AgentConnId ByteString
"") Maybe ConnectionEntity
forall a. Maybe a
Nothing
        Left ChatError
e -> do
          Text -> CM () -> CM ()
withLog (Text
eInfo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChatError -> Text
forall a. Show a => a -> Text
tshow ChatError
e) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ MsgMeta -> Maybe ByteString -> CM ()
ackMsg MsgMeta
msgMeta Maybe ByteString
forall a. Maybe a
Nothing
          ChatError -> CM ()
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
e
      where
        eventInfo :: ExceptT ChatError (ReaderT ChatController IO) Text
eventInfo = do
          TVar Int
v <- (ChatController -> TVar Int)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar Int
eventSeq
          Int
eId <- STM Int -> ExceptT ChatError (ReaderT ChatController IO) Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int -> ExceptT ChatError (ReaderT ChatController IO) Int)
-> STM Int -> ExceptT ChatError (ReaderT ChatController IO) Int
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> (Int, Int)) -> STM Int
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar Int
v ((Int -> (Int, Int)) -> STM Int) -> (Int -> (Int, Int)) -> STM Int
forall a b. (a -> b) -> a -> b
$ \Int
i -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          Text -> ExceptT ChatError (ReaderT ChatController IO) Text
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ExceptT ChatError (ReaderT ChatController IO) Text)
-> Text -> ExceptT ChatError (ReaderT ChatController IO) Text
forall a b. (a -> b) -> a -> b
$ Text
"conn_id=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a. Show a => a -> Text
tshow ByteString
cId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" event_id=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
eId
        withLog :: Text -> CM () -> CM ()
withLog Text
eInfo' CM ()
ack = do
          Text
ts <- ExceptT ChatError (ReaderT ChatController IO) Text
showTags
          Text -> CM ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logInfo (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Item [Text]
Text
label, Item [Text]
Text
"ack:", Item [Text]
Text
ts, Item [Text]
Text
eInfo']
          CM ()
ack
          Text -> CM ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
logInfo (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Item [Text]
Text
label, Item [Text]
Text
"ack=success:", Item [Text]
Text
ts, Item [Text]
Text
eInfo']
        showTags :: ExceptT ChatError (ReaderT ChatController IO) Text
showTags = do
          [Text]
ts <- ExceptT ChatError (ReaderT ChatController IO) [Text]
-> (TVar [Text]
    -> ExceptT ChatError (ReaderT ChatController IO) [Text])
-> Maybe (TVar [Text])
-> ExceptT ChatError (ReaderT ChatController IO) [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Text] -> ExceptT ChatError (ReaderT ChatController IO) [Text]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) TVar [Text] -> ExceptT ChatError (ReaderT ChatController IO) [Text]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO Maybe (TVar [Text])
tags
          Text -> ExceptT ChatError (ReaderT ChatController IO) Text
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ExceptT ChatError (ReaderT ChatController IO) Text)
-> Text -> ExceptT ChatError (ReaderT ChatController IO) Text
forall a b. (a -> b) -> a -> b
$ case [Text]
ts of
            [] -> Text
"no_chat_messages"
            [Item [Text]
t] -> Text
"chat_message=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Item [Text]
Text
t
            [Text]
_ -> Text
"chat_message_batch=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
ts)
        ackMsg :: MsgMeta -> Maybe MsgReceiptInfo -> CM ()
        ackMsg :: MsgMeta -> Maybe ByteString -> CM ()
ackMsg MsgMeta {recipient :: MsgMeta -> (GroupMemberId, UTCTime)
recipient = (GroupMemberId
msgId, UTCTime
_)} Maybe ByteString
rcpt = (AgentClient -> ExceptT AgentErrorType IO ()) -> CM ()
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ()) -> CM ())
-> (AgentClient -> ExceptT AgentErrorType IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> ByteString
-> ByteString
-> GroupMemberId
-> Maybe ByteString
-> ExceptT AgentErrorType IO ()
ackMessageAsync AgentClient
a ByteString
"" ByteString
cId GroupMemberId
msgId Maybe ByteString
rcpt

    sentMsgDeliveryEvent :: Connection -> AgentMsgId -> CM ()
    sentMsgDeliveryEvent :: Connection -> GroupMemberId -> CM ()
sentMsgDeliveryEvent Connection {GroupMemberId
connId :: Connection -> GroupMemberId
connId :: GroupMemberId
connId} GroupMemberId
msgId =
      (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> MsgDeliveryStatus 'MDSnd
-> IO ()
updateSndMsgDeliveryStatus Connection
db GroupMemberId
connId GroupMemberId
msgId MsgDeliveryStatus 'MDSnd
MDSSndSent

    agentSndError :: AgentErrorType -> SndError
    agentSndError :: AgentErrorType -> SndError
agentSndError = \case
      SMP String
_ ErrorType
AUTH -> SndError
SndErrAuth
      SMP String
_ ErrorType
QUOTA -> SndError
SndErrQuota
      BROKER String
_ BrokerErrorType
e -> (SrvError -> SndError) -> BrokerErrorType -> SndError
brokerError SrvError -> SndError
SndErrRelay BrokerErrorType
e
      SMP String
proxySrv (SMP.PROXY (SMP.BROKER BrokerErrorType
e)) -> (SrvError -> SndError) -> BrokerErrorType -> SndError
brokerError (String -> SrvError -> SndError
SndErrProxy String
proxySrv) BrokerErrorType
e
      AP.PROXY String
proxySrv String
_ (ProxyProtocolError (SMP.PROXY (SMP.BROKER BrokerErrorType
e))) -> (SrvError -> SndError) -> BrokerErrorType -> SndError
brokerError (String -> SrvError -> SndError
SndErrProxyRelay String
proxySrv) BrokerErrorType
e
      AgentErrorType
e -> Text -> SndError
SndErrOther (Text -> SndError) -> Text -> SndError
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> Text
forall a. Show a => a -> Text
tshow AgentErrorType
e
      where
        brokerError :: (SrvError -> SndError) -> BrokerErrorType -> SndError
brokerError SrvError -> SndError
srvErr = \case
          NETWORK NetworkError
_ -> SndError
SndErrExpired
          BrokerErrorType
TIMEOUT -> SndError
SndErrExpired
          BrokerErrorType
HOST -> SrvError -> SndError
srvErr SrvError
SrvErrHost
          SMP.TRANSPORT TransportError
TEVersion -> SrvError -> SndError
srvErr SrvError
SrvErrVersion
          BrokerErrorType
e -> SrvError -> SndError
srvErr (SrvError -> SndError) -> (Text -> SrvError) -> Text -> SndError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SrvError
SrvErrOther (Text -> SndError) -> Text -> SndError
forall a b. (a -> b) -> a -> b
$ BrokerErrorType -> Text
forall a. Show a => a -> Text
tshow BrokerErrorType
e

    badRcvFileChunk :: RcvFileTransfer -> String -> CM ()
    badRcvFileChunk :: RcvFileTransfer -> String -> CM ()
badRcvFileChunk RcvFileTransfer
ft String
err =
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RcvFileTransfer -> Bool
rcvFileCompleteOrCancelled RcvFileTransfer
ft) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
        User -> RcvFileTransfer -> CM ()
cancelRcvFileTransfer User
user RcvFileTransfer
ft
        ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEFileRcvChunk String
err

    memberConnectedChatItem :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM ()
    memberConnectedChatItem :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM ()
memberConnectedChatItem GroupInfo
gInfo Maybe GroupChatScopeInfo
scopeInfo GroupMember
m =
      -- ts should be broker ts but we don't have it for CON
      User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo Maybe GroupChatScopeInfo
scopeInfo GroupMember
m) (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
RGEMemberConnected) Maybe UTCTime
forall a. Maybe a
Nothing

    notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> CM ()
    notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> CM ()
notifyMemberConnected GroupInfo
gInfo GroupMember
m Maybe Contact
ct_ = do
      (GroupInfo
gInfo', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo GroupMember
m
      GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM ()
memberConnectedChatItem GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m'
      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> Maybe Contact -> ChatEvent
CEvtConnectedToGroupMember User
user GroupInfo
gInfo' GroupMember
m' Maybe Contact
ct_

    probeMatchingMembers :: Contact -> IncognitoEnabled -> CM ()
    probeMatchingMembers :: Contact -> Bool -> CM ()
probeMatchingMembers Contact
ct Bool
connectedIncognito = do
      TVar ChaChaDRG
gVar <- (ChatController -> TVar ChaChaDRG)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar ChaChaDRG
random
      Bool
contactMerge <- TVar Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChatController -> TVar Bool)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar Bool
contactMergeEnabled
      if Bool
contactMerge Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
connectedIncognito
        then do
          (Probe
probe, GroupMemberId
probeId) <- (Connection -> ExceptT StoreError IO (Probe, GroupMemberId))
-> CM (Probe, GroupMemberId)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Probe, GroupMemberId))
 -> CM (Probe, GroupMemberId))
-> (Connection -> ExceptT StoreError IO (Probe, GroupMemberId))
-> CM (Probe, GroupMemberId)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> TVar ChaChaDRG
-> GroupMemberId
-> ContactOrMember
-> ExceptT StoreError IO (Probe, GroupMemberId)
createSentProbe Connection
db TVar ChaChaDRG
gVar GroupMemberId
userId (Contact -> ContactOrMember
COMContact Contact
ct)
          -- ! when making changes to probe-and-merge mechanism,
          -- ! test scenario in which recipient receives probe after probe hashes (not covered in tests):
          -- sendProbe -> sendProbeHashes (currently)
          -- sendProbeHashes -> sendProbe (reversed - change order in code, may add delay)
          Probe -> CM ()
sendProbe Probe
probe
          [ContactOrMember]
ms <- (GroupMember -> ContactOrMember)
-> [GroupMember] -> [ContactOrMember]
forall a b. (a -> b) -> [a] -> [b]
map GroupMember -> ContactOrMember
COMGroupMember ([GroupMember] -> [ContactOrMember])
-> CM [GroupMember]
-> ExceptT ChatError (ReaderT ChatController IO) [ContactOrMember]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> Connection
-> VersionRangeChat -> User -> Contact -> IO [GroupMember]
getMatchingMembers Connection
db VersionRangeChat
vr User
user Contact
ct)
          [ContactOrMember] -> Probe -> GroupMemberId -> CM ()
sendProbeHashes [ContactOrMember]
ms Probe
probe GroupMemberId
probeId
        else Probe -> CM ()
sendProbe (Probe -> CM ()) -> (ByteString -> Probe) -> ByteString -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Probe
Probe (ByteString -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
-> CM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar ChaChaDRG -> Int -> IO ByteString
encodedRandomBytes TVar ChaChaDRG
gVar Int
32)
      where
        sendProbe :: Probe -> CM ()
        sendProbe :: Probe -> CM ()
sendProbe Probe
probe = ExceptT
  ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
 -> CM ())
-> (ChatMsgEvent 'Json
    -> ExceptT
         ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId))
-> ChatMsgEvent 'Json
-> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User
-> Contact
-> ChatMsgEvent 'Json
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> ChatMsgEvent e
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
sendDirectContactMessage User
user Contact
ct (ChatMsgEvent 'Json -> CM ()) -> ChatMsgEvent 'Json -> CM ()
forall a b. (a -> b) -> a -> b
$ Probe -> ChatMsgEvent 'Json
XInfoProbe Probe
probe

    probeMatchingMemberContact :: GroupMember -> IncognitoEnabled -> CM ()
    probeMatchingMemberContact :: GroupMember -> Bool -> CM ()
probeMatchingMemberContact GroupMember {activeConn :: GroupMember -> Maybe Connection
activeConn = Maybe Connection
Nothing} Bool
_ = () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    probeMatchingMemberContact m :: GroupMember
m@GroupMember {GroupMemberId
groupId :: GroupMemberId
groupId :: GroupMember -> GroupMemberId
groupId, activeConn :: GroupMember -> Maybe Connection
activeConn = Just Connection
conn} Bool
connectedIncognito = do
      TVar ChaChaDRG
gVar <- (ChatController -> TVar ChaChaDRG)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar ChaChaDRG
random
      Bool
contactMerge <- TVar Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChatController -> TVar Bool)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar Bool
contactMergeEnabled
      if Bool
contactMerge Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
connectedIncognito
        then do
          (Probe
probe, GroupMemberId
probeId) <- (Connection -> ExceptT StoreError IO (Probe, GroupMemberId))
-> CM (Probe, GroupMemberId)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Probe, GroupMemberId))
 -> CM (Probe, GroupMemberId))
-> (Connection -> ExceptT StoreError IO (Probe, GroupMemberId))
-> CM (Probe, GroupMemberId)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> TVar ChaChaDRG
-> GroupMemberId
-> ContactOrMember
-> ExceptT StoreError IO (Probe, GroupMemberId)
createSentProbe Connection
db TVar ChaChaDRG
gVar GroupMemberId
userId (ContactOrMember -> ExceptT StoreError IO (Probe, GroupMemberId))
-> ContactOrMember -> ExceptT StoreError IO (Probe, GroupMemberId)
forall a b. (a -> b) -> a -> b
$ GroupMember -> ContactOrMember
COMGroupMember GroupMember
m
          Probe -> CM ()
sendProbe Probe
probe
          [ContactOrMember]
cs <- (Contact -> ContactOrMember) -> [Contact] -> [ContactOrMember]
forall a b. (a -> b) -> [a] -> [b]
map Contact -> ContactOrMember
COMContact ([Contact] -> [ContactOrMember])
-> ExceptT ChatError (ReaderT ChatController IO) [Contact]
-> ExceptT ChatError (ReaderT ChatController IO) [ContactOrMember]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> IO [Contact])
-> ExceptT ChatError (ReaderT ChatController IO) [Contact]
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> Connection
-> VersionRangeChat -> User -> GroupMember -> IO [Contact]
getMatchingMemberContacts Connection
db VersionRangeChat
vr User
user GroupMember
m)
          [ContactOrMember] -> Probe -> GroupMemberId -> CM ()
sendProbeHashes [ContactOrMember]
cs Probe
probe GroupMemberId
probeId
        else Probe -> CM ()
sendProbe (Probe -> CM ()) -> (ByteString -> Probe) -> ByteString -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Probe
Probe (ByteString -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
-> CM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar ChaChaDRG -> Int -> IO ByteString
encodedRandomBytes TVar ChaChaDRG
gVar Int
32)
      where
        sendProbe :: Probe -> CM ()
        sendProbe :: Probe -> CM ()
sendProbe Probe
probe = ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, GroupMemberId, PQEncryption)
 -> CM ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
sendDirectMemberMessage Connection
conn (Probe -> ChatMsgEvent 'Json
XInfoProbe Probe
probe) GroupMemberId
groupId

    sendProbeHashes :: [ContactOrMember] -> Probe -> Int64 -> CM ()
    sendProbeHashes :: [ContactOrMember] -> Probe -> GroupMemberId -> CM ()
sendProbeHashes [ContactOrMember]
cgms Probe
probe GroupMemberId
probeId =
      [ContactOrMember] -> (ContactOrMember -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ContactOrMember]
cgms ((ContactOrMember -> CM ()) -> CM ())
-> (ContactOrMember -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \ContactOrMember
cgm -> ContactOrMember -> CM ()
sendProbeHash ContactOrMember
cgm CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        probeHash :: ProbeHash
probeHash = ByteString -> ProbeHash
ProbeHash (ByteString -> ProbeHash) -> ByteString -> ProbeHash
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
C.sha256Hash (Probe -> ByteString
unProbe Probe
probe)
        sendProbeHash :: ContactOrMember -> CM ()
        sendProbeHash :: ContactOrMember -> CM ()
sendProbeHash cgm :: ContactOrMember
cgm@(COMContact Contact
c) = do
          ExceptT
  ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
 -> CM ())
-> (ChatMsgEvent 'Json
    -> ExceptT
         ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId))
-> ChatMsgEvent 'Json
-> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User
-> Contact
-> ChatMsgEvent 'Json
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> ChatMsgEvent e
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
sendDirectContactMessage User
user Contact
c (ChatMsgEvent 'Json -> CM ()) -> ChatMsgEvent 'Json -> CM ()
forall a b. (a -> b) -> a -> b
$ ProbeHash -> ChatMsgEvent 'Json
XInfoProbeCheck ProbeHash
probeHash
          (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> GroupMemberId -> ContactOrMember -> IO ()
createSentProbeHash Connection
db GroupMemberId
userId GroupMemberId
probeId ContactOrMember
cgm
        sendProbeHash (COMGroupMember GroupMember {activeConn :: GroupMember -> Maybe Connection
activeConn = Maybe Connection
Nothing}) = () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        sendProbeHash cgm :: ContactOrMember
cgm@(COMGroupMember m :: GroupMember
m@GroupMember {GroupMemberId
groupId :: GroupMember -> GroupMemberId
groupId :: GroupMemberId
groupId, activeConn :: GroupMember -> Maybe Connection
activeConn = Just Connection
conn}) =
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupMember -> Bool
memberCurrent GroupMember
m) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
            ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, GroupMemberId, PQEncryption)
 -> CM ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
sendDirectMemberMessage Connection
conn (ProbeHash -> ChatMsgEvent 'Json
XInfoProbeCheck ProbeHash
probeHash) GroupMemberId
groupId
            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> GroupMemberId -> ContactOrMember -> IO ()
createSentProbeHash Connection
db GroupMemberId
userId GroupMemberId
probeId ContactOrMember
cgm

    messageWarning :: Text -> CM ()
    messageWarning :: Text -> CM ()
messageWarning = ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> (Text -> ChatEvent) -> Text -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> Text -> Text -> ChatEvent
CEvtMessageError User
user Text
"warning"

    messageError :: Text -> CM ()
    messageError :: Text -> CM ()
messageError = ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> (Text -> ChatEvent) -> Text -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> Text -> Text -> ChatEvent
CEvtMessageError User
user Text
"error"

    newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
    newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
newContentMessage Contact
ct MsgContainer
mc msg :: RcvMessage
msg@RcvMessage {Maybe SharedMsgId
sharedMsgId_ :: Maybe SharedMsgId
sharedMsgId_ :: RcvMessage -> Maybe SharedMsgId
sharedMsgId_} MsgMeta
msgMeta = do
      let ExtMsgContent MsgContent
content Map Text MsgMention
_ Maybe FileInvitation
fInv_ Maybe Int
_ Maybe Bool
_ Maybe MsgScope
_ = MsgContainer -> ExtMsgContent
mcExtMsgContent MsgContainer
mc
      -- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete
      -- case content of
      --   MCText "hello 111" ->
      --     UE.throwIO $ userError "#####################"
      --     -- throwChatError $ CECommandError "#####################"
      --   _ -> pure ()
      if MsgContent -> Bool
isVoice MsgContent
content Bool -> Bool -> Bool
&& Bool -> Bool
not (SChatFeature 'CFVoice -> (PrefEnabled -> Bool) -> Contact -> Bool
forall (f :: ChatFeature).
SChatFeature f -> (PrefEnabled -> Bool) -> Contact -> Bool
featureAllowed SChatFeature 'CFVoice
SCFVoice PrefEnabled -> Bool
forContact Contact
ct)
        then do
          CM () -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> CM ()
newChatItem (CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
ciContentNoParse (CIContent 'MDRcv
 -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)))
-> CIContent 'MDRcv
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
forall a b. (a -> b) -> a -> b
$ ChatFeature -> CIContent 'MDRcv
CIRcvChatFeatureRejected ChatFeature
CFVoice) Maybe (CIFile 'MDRcv)
forall a. Maybe a
Nothing Maybe CITimed
forall a. Maybe a
Nothing Bool
False
        else do
          let ExtMsgContent MsgContent
_ Map Text MsgMention
_ Maybe FileInvitation
_ Maybe Int
itemTTL Maybe Bool
live_ Maybe MsgScope
_ = MsgContainer -> ExtMsgContent
mcExtMsgContent MsgContainer
mc
              timed_ :: Maybe CITimed
timed_ = Contact -> Maybe Int -> Maybe CITimed
rcvContactCITimed Contact
ct Maybe Int
itemTTL
              live :: Bool
live = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
live_
          Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_ <- Maybe FileInvitation
-> MsgContent
-> (Connection
    -> FileInvitation
    -> Maybe InlineFileMode
    -> Integer
    -> ExceptT StoreError IO RcvFileTransfer)
-> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
processFileInvitation Maybe FileInvitation
fInv_ MsgContent
content ((Connection
  -> FileInvitation
  -> Maybe InlineFileMode
  -> Integer
  -> ExceptT StoreError IO RcvFileTransfer)
 -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv)))
-> (Connection
    -> FileInvitation
    -> Maybe InlineFileMode
    -> Integer
    -> ExceptT StoreError IO RcvFileTransfer)
-> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> Contact
-> FileInvitation
-> Maybe InlineFileMode
-> Integer
-> ExceptT StoreError IO RcvFileTransfer
createRcvFileTransfer Connection
db GroupMemberId
userId Contact
ct
          (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> CM ()
newChatItem (MsgContent -> CIContent 'MDRcv
CIRcvMsgContent MsgContent
content, MsgContent -> (Text, Maybe MarkdownList)
msgContentTexts MsgContent
content) ((RcvFileTransfer, CIFile 'MDRcv) -> CIFile 'MDRcv
forall a b. (a, b) -> b
snd ((RcvFileTransfer, CIFile 'MDRcv) -> CIFile 'MDRcv)
-> Maybe (RcvFileTransfer, CIFile 'MDRcv) -> Maybe (CIFile 'MDRcv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_) Maybe CITimed
timed_ Bool
live
          Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM ()
autoAcceptFile Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_
      where
        brokerTs :: UTCTime
brokerTs = MsgMeta -> UTCTime
metaBrokerTs MsgMeta
msgMeta
        newChatItem :: (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> CM ()
newChatItem (CIContent 'MDRcv, (Text, Maybe MarkdownList))
content Maybe (CIFile 'MDRcv)
ciFile_ Maybe CITimed
timed_ Bool
live = do
          (ChatItem 'CTDirect 'MDRcv
ci, ChatInfo 'CTDirect
cInfo) <- User
-> ChatDirection 'CTDirect 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTDirect 'MDRcv, ChatInfo 'CTDirect)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct) RcvMessage
msg Maybe SharedMsgId
sharedMsgId_ UTCTime
brokerTs (CIContent 'MDRcv, (Text, Maybe MarkdownList))
content Maybe (CIFile 'MDRcv)
ciFile_ Maybe CITimed
timed_ Bool
live Map Text MsgMention
forall k a. Map k a
M.empty
          [CIReactionCount]
reactions <- ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
-> (SharedMsgId
    -> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount])
-> Maybe SharedMsgId
-> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([CIReactionCount]
-> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (\SharedMsgId
sharedMsgId -> (Connection -> IO [CIReactionCount])
-> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [CIReactionCount])
 -> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount])
-> (Connection -> IO [CIReactionCount])
-> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> Contact -> SharedMsgId -> IO [CIReactionCount]
getDirectCIReactions Connection
db Contact
ct SharedMsgId
sharedMsgId) Maybe SharedMsgId
sharedMsgId_
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv ChatInfo 'CTDirect
cInfo ChatItem 'CTDirect 'MDRcv
ci {reactions}]

    autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM ()
    autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM ()
autoAcceptFile = ((RcvFileTransfer, CIFile 'MDRcv) -> CM ())
-> Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((RcvFileTransfer, CIFile 'MDRcv) -> CM ())
 -> Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM ())
-> ((RcvFileTransfer, CIFile 'MDRcv) -> CM ())
-> Maybe (RcvFileTransfer, CIFile 'MDRcv)
-> CM ()
forall a b. (a -> b) -> a -> b
$ \(RcvFileTransfer
ft, CIFile {Integer
fileSize :: Integer
fileSize :: forall (d :: MsgDirection). CIFile d -> Integer
fileSize}) -> do
      -- ! autoAcceptFileSize is only used in tests
      ChatConfig {autoAcceptFileSize :: ChatConfig -> Integer
autoAcceptFileSize = Integer
sz} <- (ChatController -> ChatConfig)
-> ExceptT ChatError (ReaderT ChatController IO) ChatConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> ChatConfig
config
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
sz Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
fileSize) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> RcvFileTransfer
-> Bool
-> Maybe Bool
-> Maybe String
-> CM ChatEvent
receiveFileEvt' User
user RcvFileTransfer
ft Bool
False Maybe Bool
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing CM ChatEvent -> (ChatEvent -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChatEvent -> CM ()
toView

    messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> CM ()
    messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> CM ()
messageFileDescription Contact {GroupMemberId
contactId :: Contact -> GroupMemberId
contactId :: GroupMemberId
contactId} SharedMsgId
sharedMsgId FileDescr
fileDescr = do
      (GroupMemberId
fileId, AChatItem
aci) <- (Connection -> ExceptT StoreError IO (GroupMemberId, AChatItem))
-> CM (GroupMemberId, AChatItem)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupMemberId, AChatItem))
 -> CM (GroupMemberId, AChatItem))
-> (Connection -> ExceptT StoreError IO (GroupMemberId, AChatItem))
-> CM (GroupMemberId, AChatItem)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
        GroupMemberId
fileId <- Connection
-> GroupMemberId
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO GroupMemberId
getFileIdBySharedMsgId Connection
db GroupMemberId
userId GroupMemberId
contactId SharedMsgId
sharedMsgId
        AChatItem
aci <- Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO AChatItem
getChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
        (GroupMemberId, AChatItem)
-> ExceptT StoreError IO (GroupMemberId, AChatItem)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMemberId
fileId, AChatItem
aci)
      GroupMemberId -> AChatItem -> FileDescr -> CM ()
processFDMessage GroupMemberId
fileId AChatItem
aci FileDescr
fileDescr

    groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> CM (Maybe DeliveryJobScope)
    groupMessageFileDescription :: GroupInfo
-> GroupMember
-> SharedMsgId
-> FileDescr
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMessageFileDescription g :: GroupInfo
g@GroupInfo {GroupMemberId
groupId :: GroupInfo -> GroupMemberId
groupId :: GroupMemberId
groupId} GroupMember {MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId} SharedMsgId
sharedMsgId FileDescr
fileDescr = do
      (GroupMemberId
fileId, AChatItem
aci) <- (Connection -> ExceptT StoreError IO (GroupMemberId, AChatItem))
-> CM (GroupMemberId, AChatItem)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupMemberId, AChatItem))
 -> CM (GroupMemberId, AChatItem))
-> (Connection -> ExceptT StoreError IO (GroupMemberId, AChatItem))
-> CM (GroupMemberId, AChatItem)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
        GroupMemberId
fileId <- Connection
-> GroupMemberId
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO GroupMemberId
getGroupFileIdBySharedMsgId Connection
db GroupMemberId
userId GroupMemberId
groupId SharedMsgId
sharedMsgId
        AChatItem
aci <- Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO AChatItem
getChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
        (GroupMemberId, AChatItem)
-> ExceptT StoreError IO (GroupMemberId, AChatItem)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMemberId
fileId, AChatItem
aci)
      case AChatItem
aci of
        AChatItem SChatType c
SCTGroup SMsgDirection d
SMDRcv (GroupChat GroupInfo
_g Maybe GroupChatScopeInfo
scopeInfo) ChatItem {chatDir :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIDirection c d
chatDir = CIGroupRcv GroupMember
m} ->
          if MemberId -> GroupMember -> Bool
sameMemberId MemberId
memberId GroupMember
m
            then do
              -- in processFDMessage some paths are programmed as errors,
              -- for example failure on not approved relays (CEFileNotApproved).
              -- we catch error, so that even if processFDMessage fails, message can still be forwarded.
              GroupMemberId -> AChatItem -> FileDescr -> CM ()
processFDMessage GroupMemberId
fileId AChatItem
aci FileDescr
fileDescr CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DeliveryJobScope -> Maybe DeliveryJobScope)
-> DeliveryJobScope -> Maybe DeliveryJobScope
forall a b. (a -> b) -> a -> b
$ GroupInfo -> Maybe GroupChatScopeInfo -> DeliveryJobScope
infoToDeliveryScope GroupInfo
g Maybe GroupChatScopeInfo
scopeInfo
            else
              Text -> CM ()
messageError Text
"x.msg.file.descr: file of another member" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
        AChatItem
_ -> Text -> CM ()
messageError Text
"x.msg.file.descr: invalid file description part" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing

    processFDMessage :: FileTransferId -> AChatItem -> FileDescr -> CM ()
    processFDMessage :: GroupMemberId -> AChatItem -> FileDescr -> CM ()
processFDMessage GroupMemberId
fileId AChatItem
aci FileDescr
fileDescr = do
      RcvFileTransfer
ft <- (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RcvFileTransfer)
 -> CM RcvFileTransfer)
-> (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User -> GroupMemberId -> ExceptT StoreError IO RcvFileTransfer
getRcvFileTransfer Connection
db User
user GroupMemberId
fileId
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RcvFileTransfer -> Bool
rcvFileCompleteOrCancelled RcvFileTransfer
ft) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
        (rfd :: RcvFileDescr
rfd@RcvFileDescr {Bool
fileDescrComplete :: Bool
fileDescrComplete :: RcvFileDescr -> Bool
fileDescrComplete}, ft' :: RcvFileTransfer
ft'@RcvFileTransfer {RcvFileStatus
fileStatus :: RcvFileStatus
fileStatus :: RcvFileTransfer -> RcvFileStatus
fileStatus, Maybe XFTPRcvFile
xftpRcvFile :: Maybe XFTPRcvFile
xftpRcvFile :: RcvFileTransfer -> Maybe XFTPRcvFile
xftpRcvFile, Maybe CryptoFileArgs
cryptoArgs :: Maybe CryptoFileArgs
cryptoArgs :: RcvFileTransfer -> Maybe CryptoFileArgs
cryptoArgs}) <- (Connection
 -> ExceptT StoreError IO (RcvFileDescr, RcvFileTransfer))
-> CM (RcvFileDescr, RcvFileTransfer)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection
  -> ExceptT StoreError IO (RcvFileDescr, RcvFileTransfer))
 -> CM (RcvFileDescr, RcvFileTransfer))
-> (Connection
    -> ExceptT StoreError IO (RcvFileDescr, RcvFileTransfer))
-> CM (RcvFileDescr, RcvFileTransfer)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
          RcvFileDescr
rfd <- Connection
-> GroupMemberId
-> GroupMemberId
-> FileDescr
-> ExceptT StoreError IO RcvFileDescr
appendRcvFD Connection
db GroupMemberId
userId GroupMemberId
fileId FileDescr
fileDescr
          -- reading second time in the same transaction as appending description
          -- to prevent race condition with accept
          RcvFileTransfer
ft' <- Connection
-> User -> GroupMemberId -> ExceptT StoreError IO RcvFileTransfer
getRcvFileTransfer Connection
db User
user GroupMemberId
fileId
          (RcvFileDescr, RcvFileTransfer)
-> ExceptT StoreError IO (RcvFileDescr, RcvFileTransfer)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RcvFileDescr
rfd, RcvFileTransfer
ft')
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fileDescrComplete (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> RcvFileTransfer -> RcvFileDescr -> ChatEvent
CEvtRcvFileDescrReady User
user AChatItem
aci RcvFileTransfer
ft' RcvFileDescr
rfd
        case (RcvFileStatus
fileStatus, Maybe XFTPRcvFile
xftpRcvFile) of
          (RFSAccepted String
_, Just XFTPRcvFile {Bool
userApprovedRelays :: Bool
userApprovedRelays :: XFTPRcvFile -> Bool
userApprovedRelays}) -> User
-> GroupMemberId
-> RcvFileDescr
-> Bool
-> Maybe CryptoFileArgs
-> CM ()
receiveViaCompleteFD User
user GroupMemberId
fileId RcvFileDescr
rfd Bool
userApprovedRelays Maybe CryptoFileArgs
cryptoArgs
          (RcvFileStatus, Maybe XFTPRcvFile)
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer) -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
    processFileInvitation :: Maybe FileInvitation
-> MsgContent
-> (Connection
    -> FileInvitation
    -> Maybe InlineFileMode
    -> Integer
    -> ExceptT StoreError IO RcvFileTransfer)
-> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
processFileInvitation Maybe FileInvitation
fInv_ MsgContent
mc Connection
-> FileInvitation
-> Maybe InlineFileMode
-> Integer
-> ExceptT StoreError IO RcvFileTransfer
createRcvFT = Maybe FileInvitation
-> (FileInvitation
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (RcvFileTransfer, CIFile 'MDRcv))
-> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe FileInvitation
fInv_ ((FileInvitation
  -> ExceptT
       ChatError
       (ReaderT ChatController IO)
       (RcvFileTransfer, CIFile 'MDRcv))
 -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv)))
-> (FileInvitation
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (RcvFileTransfer, CIFile 'MDRcv))
-> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
forall a b. (a -> b) -> a -> b
$ \FileInvitation
fInv' -> do
      ChatConfig {Integer
fileChunkSize :: Integer
fileChunkSize :: ChatConfig -> Integer
fileChunkSize} <- (ChatController -> ChatConfig)
-> ExceptT ChatError (ReaderT ChatController IO) ChatConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> ChatConfig
config
      let fInv :: FileInvitation
fInv@FileInvitation {String
fileName :: String
fileName :: FileInvitation -> String
fileName, Integer
fileSize :: Integer
fileSize :: FileInvitation -> Integer
fileSize} = FileInvitation -> FileInvitation
mkValidFileInvitation FileInvitation
fInv'
      Maybe InlineFileMode
inline <- FileInvitation
-> Maybe MsgContent -> Integer -> CM (Maybe InlineFileMode)
receiveInlineMode FileInvitation
fInv (MsgContent -> Maybe MsgContent
forall a. a -> Maybe a
Just MsgContent
mc) Integer
fileChunkSize
      ft :: RcvFileTransfer
ft@RcvFileTransfer {GroupMemberId
fileId :: RcvFileTransfer -> GroupMemberId
fileId :: GroupMemberId
fileId, Maybe XFTPRcvFile
xftpRcvFile :: RcvFileTransfer -> Maybe XFTPRcvFile
xftpRcvFile :: Maybe XFTPRcvFile
xftpRcvFile} <- (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RcvFileTransfer)
 -> CM RcvFileTransfer)
-> (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> FileInvitation
-> Maybe InlineFileMode
-> Integer
-> ExceptT StoreError IO RcvFileTransfer
createRcvFT Connection
db FileInvitation
fInv Maybe InlineFileMode
inline Integer
fileChunkSize
      let fileProtocol :: FileProtocol
fileProtocol = if Maybe XFTPRcvFile -> Bool
forall a. Maybe a -> Bool
isJust Maybe XFTPRcvFile
xftpRcvFile then FileProtocol
FPXFTP else FileProtocol
FPSMP
      (Maybe String
filePath, CIFileStatus 'MDRcv
fileStatus, RcvFileTransfer
ft') <- case Maybe InlineFileMode
inline of
        Just InlineFileMode
IFMSent -> do
          Bool
encrypt <- (ChatController -> TVar Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar Bool
encryptLocalFiles
          RcvFileTransfer
ft' <- (if Bool
encrypt then RcvFileTransfer -> CM RcvFileTransfer
setFileToEncrypt else RcvFileTransfer -> CM RcvFileTransfer
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) RcvFileTransfer
ft
          String
fPath <- GroupMemberId
-> Maybe String
-> String
-> Bool
-> ExceptT ChatError (ReaderT ChatController IO) String
getRcvFilePath GroupMemberId
fileId Maybe String
forall a. Maybe a
Nothing String
fileName Bool
True
          (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> RcvFileTransfer
-> String
-> Maybe InlineFileMode
-> IO ()
startRcvInlineFT Connection
db User
user RcvFileTransfer
ft' String
fPath Maybe InlineFileMode
inline
          (Maybe String, CIFileStatus 'MDRcv, RcvFileTransfer)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe String, CIFileStatus 'MDRcv, RcvFileTransfer)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
fPath, CIFileStatus 'MDRcv
CIFSRcvAccepted, RcvFileTransfer
ft')
        Maybe InlineFileMode
_ -> (Maybe String, CIFileStatus 'MDRcv, RcvFileTransfer)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe String, CIFileStatus 'MDRcv, RcvFileTransfer)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String
forall a. Maybe a
Nothing, CIFileStatus 'MDRcv
CIFSRcvInvitation, RcvFileTransfer
ft)
      let RcvFileTransfer {Maybe CryptoFileArgs
cryptoArgs :: RcvFileTransfer -> Maybe CryptoFileArgs
cryptoArgs :: Maybe CryptoFileArgs
cryptoArgs} = RcvFileTransfer
ft'
          fileSource :: Maybe CryptoFile
fileSource = (String -> Maybe CryptoFileArgs -> CryptoFile
`CryptoFile` Maybe CryptoFileArgs
cryptoArgs) (String -> CryptoFile) -> Maybe String -> Maybe CryptoFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
filePath
      (RcvFileTransfer, CIFile 'MDRcv)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (RcvFileTransfer, CIFile 'MDRcv)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RcvFileTransfer
ft', CIFile {GroupMemberId
fileId :: GroupMemberId
fileId :: GroupMemberId
fileId, String
fileName :: String
fileName :: String
fileName, Integer
fileSize :: Integer
fileSize :: Integer
fileSize, Maybe CryptoFile
fileSource :: Maybe CryptoFile
fileSource :: Maybe CryptoFile
fileSource, CIFileStatus 'MDRcv
fileStatus :: CIFileStatus 'MDRcv
fileStatus :: CIFileStatus 'MDRcv
fileStatus, FileProtocol
fileProtocol :: FileProtocol
fileProtocol :: FileProtocol
fileProtocol})

    mkValidFileInvitation :: FileInvitation -> FileInvitation
    mkValidFileInvitation :: FileInvitation -> FileInvitation
mkValidFileInvitation fInv :: FileInvitation
fInv@FileInvitation {String
fileName :: FileInvitation -> String
fileName :: String
fileName} = FileInvitation
fInv {fileName = FP.makeValid $ FP.takeFileName fileName}

    messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> CM ()
    messageUpdate :: Contact
-> SharedMsgId
-> MsgContent
-> RcvMessage
-> MsgMeta
-> Maybe Int
-> Maybe Bool
-> CM ()
messageUpdate ct :: Contact
ct@Contact {GroupMemberId
contactId :: Contact -> GroupMemberId
contactId :: GroupMemberId
contactId} SharedMsgId
sharedMsgId MsgContent
mc msg :: RcvMessage
msg@RcvMessage {GroupMemberId
msgId :: RcvMessage -> GroupMemberId
msgId :: GroupMemberId
msgId} MsgMeta
msgMeta Maybe Int
ttl Maybe Bool
live_ = do
      CM ()
updateRcvChatItem CM () -> (SharedMsgId -> CM ()) -> CM ()
forall a. CM a -> (SharedMsgId -> CM a) -> CM a
`catchCINotFound` \SharedMsgId
_ -> do
        -- This patches initial sharedMsgId into chat item when locally deleted chat item
        -- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
        -- Chat item and update message which created it will have different sharedMsgId in this case...
        let timed_ :: Maybe CITimed
timed_ = Contact -> Maybe Int -> Maybe CITimed
rcvContactCITimed Contact
ct Maybe Int
ttl
            ts :: (Text, Maybe MarkdownList)
ts = CIContent 'MDRcv -> (Text, Maybe MarkdownList)
forall (d :: MsgDirection).
CIContent d -> (Text, Maybe MarkdownList)
ciContentTexts CIContent 'MDRcv
content
        (ChatItem 'CTDirect 'MDRcv
ci, ChatInfo 'CTDirect
cInfo) <- User
-> ChatDirection 'CTDirect 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTDirect 'MDRcv, ChatInfo 'CTDirect)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct) RcvMessage
msg (SharedMsgId -> Maybe SharedMsgId
forall a. a -> Maybe a
Just SharedMsgId
sharedMsgId) UTCTime
brokerTs (CIContent 'MDRcv
content, (Text, Maybe MarkdownList)
ts) Maybe (CIFile 'MDRcv)
forall a. Maybe a
Nothing Maybe CITimed
timed_ Bool
live Map Text MsgMention
forall k a. Map k a
M.empty
        ChatItem 'CTDirect 'MDRcv
ci' <- (Connection -> IO (ChatItem 'CTDirect 'MDRcv))
-> CM (ChatItem 'CTDirect 'MDRcv)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (ChatItem 'CTDirect 'MDRcv))
 -> CM (ChatItem 'CTDirect 'MDRcv))
-> (Connection -> IO (ChatItem 'CTDirect 'MDRcv))
-> CM (ChatItem 'CTDirect 'MDRcv)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
          Connection -> GroupMemberId -> UTCTime -> MsgContent -> IO ()
createChatItemVersion Connection
db (ChatItem 'CTDirect 'MDRcv -> GroupMemberId
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> GroupMemberId
chatItemId' ChatItem 'CTDirect 'MDRcv
ci) UTCTime
brokerTs MsgContent
mc
          Connection
-> User
-> GroupMemberId
-> ChatItem 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe GroupMemberId
-> IO (ChatItem 'CTDirect 'MDRcv)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupMemberId
-> ChatItem 'CTDirect d
-> CIContent d
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe GroupMemberId
-> IO (ChatItem 'CTDirect d)
updateDirectChatItem' Connection
db User
user GroupMemberId
contactId ChatItem 'CTDirect 'MDRcv
ci CIContent 'MDRcv
content Bool
True Bool
live Maybe CITimed
forall a. Maybe a
Nothing Maybe GroupMemberId
forall a. Maybe a
Nothing
        ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemUpdated User
user (SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv ChatInfo 'CTDirect
cInfo ChatItem 'CTDirect 'MDRcv
ci')
      where
        brokerTs :: UTCTime
brokerTs = MsgMeta -> UTCTime
metaBrokerTs MsgMeta
msgMeta
        content :: CIContent 'MDRcv
content = MsgContent -> CIContent 'MDRcv
CIRcvMsgContent MsgContent
mc
        live :: Bool
live = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
live_
        updateRcvChatItem :: CM ()
updateRcvChatItem = do
          CChatItem 'CTDirect
cci <- (Connection -> ExceptT StoreError IO (CChatItem 'CTDirect))
-> CM (CChatItem 'CTDirect)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (CChatItem 'CTDirect))
 -> CM (CChatItem 'CTDirect))
-> (Connection -> ExceptT StoreError IO (CChatItem 'CTDirect))
-> CM (CChatItem 'CTDirect)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItemBySharedMsgId Connection
db User
user GroupMemberId
contactId SharedMsgId
sharedMsgId
          case CChatItem 'CTDirect
cci of
            CChatItem SMsgDirection d
SMDRcv ci :: ChatItem 'CTDirect d
ci@ChatItem {meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta = CIMeta {Maybe CIForwardedFrom
itemForwarded :: Maybe CIForwardedFrom
itemForwarded :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> Maybe CIForwardedFrom
itemForwarded, Maybe Bool
itemLive :: Maybe Bool
itemLive :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> Maybe Bool
itemLive}, content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content = CIRcvMsgContent MsgContent
oldMC}
              | Maybe CIForwardedFrom -> Bool
forall a. Maybe a -> Bool
isNothing Maybe CIForwardedFrom
itemForwarded -> do
                  let changed :: Bool
changed = MsgContent
mc MsgContent -> MsgContent -> Bool
forall a. Eq a => a -> a -> Bool
/= MsgContent
oldMC
                  if Bool
changed Bool -> Bool -> Bool
|| Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
itemLive
                    then do
                      ChatItem 'CTDirect d
ci' <- (Connection -> IO (ChatItem 'CTDirect d))
-> CM (ChatItem 'CTDirect d)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (ChatItem 'CTDirect d))
 -> CM (ChatItem 'CTDirect d))
-> (Connection -> IO (ChatItem 'CTDirect d))
-> CM (ChatItem 'CTDirect d)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                          Connection
-> GroupMemberId
-> (UTCTime, MsgContent)
-> (UTCTime, MsgContent)
-> IO ()
addInitialAndNewCIVersions Connection
db (ChatItem 'CTDirect d -> GroupMemberId
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> GroupMemberId
chatItemId' ChatItem 'CTDirect d
ci) (ChatItem 'CTDirect d -> UTCTime
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> UTCTime
chatItemTs' ChatItem 'CTDirect d
ci, MsgContent
oldMC) (UTCTime
brokerTs, MsgContent
mc)
                        [CIReactionCount]
reactions <- Connection -> Contact -> SharedMsgId -> IO [CIReactionCount]
getDirectCIReactions Connection
db Contact
ct SharedMsgId
sharedMsgId
                        let edited :: Bool
edited = Maybe Bool
itemLive Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
                        Connection
-> User
-> GroupMemberId
-> ChatItem 'CTDirect d
-> CIContent d
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe GroupMemberId
-> IO (ChatItem 'CTDirect d)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupMemberId
-> ChatItem 'CTDirect d
-> CIContent d
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe GroupMemberId
-> IO (ChatItem 'CTDirect d)
updateDirectChatItem' Connection
db User
user GroupMemberId
contactId ChatItem 'CTDirect d
ci {reactions} CIContent d
CIContent 'MDRcv
content Bool
edited Bool
live Maybe CITimed
forall a. Maybe a
Nothing (Maybe GroupMemberId -> IO (ChatItem 'CTDirect d))
-> Maybe GroupMemberId -> IO (ChatItem 'CTDirect d)
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just GroupMemberId
msgId
                      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemUpdated User
user (SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv (Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct) ChatItem 'CTDirect d
ChatItem 'CTDirect 'MDRcv
ci')
                      User
-> ChatRef -> ChatItem 'CTDirect d -> ChatItem 'CTDirect d -> CM ()
forall (c :: ChatType) (d :: MsgDirection).
User -> ChatRef -> ChatItem c d -> ChatItem c d -> CM ()
startUpdatedTimedItemThread User
user (ChatType -> GroupMemberId -> Maybe GroupChatScope -> ChatRef
ChatRef ChatType
CTDirect GroupMemberId
contactId Maybe GroupChatScope
forall a. Maybe a
Nothing) ChatItem 'CTDirect d
ci ChatItem 'CTDirect d
ci'
                    else ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemNotChanged User
user (SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv (Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct) ChatItem 'CTDirect d
ChatItem 'CTDirect 'MDRcv
ci)
            CChatItem 'CTDirect
_ -> Text -> CM ()
messageError Text
"x.msg.update: contact attempted invalid message update"

    messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> CM ()
    messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> CM ()
messageDelete ct :: Contact
ct@Contact {GroupMemberId
contactId :: Contact -> GroupMemberId
contactId :: GroupMemberId
contactId} SharedMsgId
sharedMsgId RcvMessage
_rcvMessage MsgMeta
msgMeta = do
      CM ()
deleteRcvChatItem CM () -> (SharedMsgId -> CM ()) -> CM ()
forall a. CM a -> (SharedMsgId -> CM a) -> CM a
`catchCINotFound` (ChatEvent -> CM ()
toView (ChatEvent -> CM ())
-> (SharedMsgId -> ChatEvent) -> SharedMsgId -> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> Contact -> SharedMsgId -> ChatEvent
CEvtChatItemDeletedNotFound User
user Contact
ct)
      where
        brokerTs :: UTCTime
brokerTs = MsgMeta -> UTCTime
metaBrokerTs MsgMeta
msgMeta
        deleteRcvChatItem :: CM ()
deleteRcvChatItem = do
          cci :: CChatItem 'CTDirect
cci@(CChatItem SMsgDirection d
msgDir ChatItem 'CTDirect d
ci) <- (Connection -> ExceptT StoreError IO (CChatItem 'CTDirect))
-> CM (CChatItem 'CTDirect)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (CChatItem 'CTDirect))
 -> CM (CChatItem 'CTDirect))
-> (Connection -> ExceptT StoreError IO (CChatItem 'CTDirect))
-> CM (CChatItem 'CTDirect)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItemBySharedMsgId Connection
db User
user GroupMemberId
contactId SharedMsgId
sharedMsgId
          case SMsgDirection d
msgDir of
            SMsgDirection d
SMDRcv
              | ChatItem 'CTDirect d -> UTCTime -> Bool
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> UTCTime -> Bool
rcvItemDeletable ChatItem 'CTDirect d
ci UTCTime
brokerTs -> do
                  [ChatItemDeletion]
deletions <- if SChatFeature 'CFFullDelete
-> (PrefEnabled -> Bool) -> Contact -> Bool
forall (f :: ChatFeature).
SChatFeature f -> (PrefEnabled -> Bool) -> Contact -> Bool
featureAllowed SChatFeature 'CFFullDelete
SCFFullDelete PrefEnabled -> Bool
forContact Contact
ct
                    then User -> Contact -> [CChatItem 'CTDirect] -> CM [ChatItemDeletion]
deleteDirectCIs User
user Contact
ct [Item [CChatItem 'CTDirect]
CChatItem 'CTDirect
cci]
                    else User
-> Contact
-> [CChatItem 'CTDirect]
-> UTCTime
-> CM [ChatItemDeletion]
markDirectCIsDeleted User
user Contact
ct [Item [CChatItem 'CTDirect]
CChatItem 'CTDirect
cci] UTCTime
brokerTs
                  ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [ChatItemDeletion] -> Bool -> Bool -> ChatEvent
CEvtChatItemsDeleted User
user [ChatItemDeletion]
deletions Bool
False Bool
False
              | Bool
otherwise -> Text -> CM ()
messageError Text
"x.msg.del: contact attempted invalid message delete"
            SMsgDirection d
SMDSnd -> Text -> CM ()
messageError Text
"x.msg.del: contact attempted invalid message delete"

    rcvItemDeletable :: ChatItem c d -> UTCTime -> Bool
    rcvItemDeletable :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> UTCTime -> Bool
rcvItemDeletable ChatItem {meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta = CIMeta {UTCTime
itemTs :: UTCTime
itemTs :: forall (c :: ChatType) (d :: MsgDirection). CIMeta c d -> UTCTime
itemTs, Maybe (CIDeleted c)
itemDeleted :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> Maybe (CIDeleted c)
itemDeleted :: Maybe (CIDeleted c)
itemDeleted}} UTCTime
brokerTs =
      -- 78 hours margin to account for possible sending delay
      UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
brokerTs UTCTime
itemTs NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< (NominalDiffTime
78 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
3600) Bool -> Bool -> Bool
&& Maybe (CIDeleted c) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (CIDeleted c)
itemDeleted

    directMsgReaction :: Contact -> SharedMsgId -> MsgReaction -> Bool -> RcvMessage -> MsgMeta -> CM ()
    directMsgReaction :: Contact
-> SharedMsgId
-> MsgReaction
-> Bool
-> RcvMessage
-> MsgMeta
-> CM ()
directMsgReaction Contact
ct SharedMsgId
sharedMsgId MsgReaction
reaction Bool
add RcvMessage {GroupMemberId
msgId :: RcvMessage -> GroupMemberId
msgId :: GroupMemberId
msgId} MsgMeta {broker :: MsgMeta -> (ByteString, UTCTime)
broker = (ByteString
_, UTCTime
brokerTs)} = do
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SChatFeature 'CFReactions
-> (PrefEnabled -> Bool) -> Contact -> Bool
forall (f :: ChatFeature).
SChatFeature f -> (PrefEnabled -> Bool) -> Contact -> Bool
featureAllowed SChatFeature 'CFReactions
SCFReactions PrefEnabled -> Bool
forContact Contact
ct) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
        [MsgReaction]
rs <- (Connection -> IO [MsgReaction]) -> CM [MsgReaction]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [MsgReaction]) -> CM [MsgReaction])
-> (Connection -> IO [MsgReaction]) -> CM [MsgReaction]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> Contact -> SharedMsgId -> Bool -> IO [MsgReaction]
getDirectReactions Connection
db Contact
ct SharedMsgId
sharedMsgId Bool
False
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> MsgReaction -> [MsgReaction] -> Bool
reactionAllowed Bool
add MsgReaction
reaction [MsgReaction]
rs) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
          CM ()
updateChatItemReaction CM () -> (SharedMsgId -> CM ()) -> CM ()
forall a. CM a -> (SharedMsgId -> CM a) -> CM a
`catchCINotFound` \SharedMsgId
_ ->
            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> Contact
-> SharedMsgId
-> Bool
-> MsgReaction
-> Bool
-> GroupMemberId
-> UTCTime
-> IO ()
setDirectReaction Connection
db Contact
ct SharedMsgId
sharedMsgId Bool
False MsgReaction
reaction Bool
add GroupMemberId
msgId UTCTime
brokerTs
      where
        updateChatItemReaction :: CM ()
updateChatItemReaction = do
          Maybe ChatEvent
cEvt_ <- (Connection -> ExceptT StoreError IO (Maybe ChatEvent))
-> CM (Maybe ChatEvent)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe ChatEvent))
 -> CM (Maybe ChatEvent))
-> (Connection -> ExceptT StoreError IO (Maybe ChatEvent))
-> CM (Maybe ChatEvent)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
            CChatItem SMsgDirection d
md ChatItem 'CTDirect d
ci <- Connection
-> User
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItemBySharedMsgId Connection
db User
user (Contact -> GroupMemberId
forall a. IsContact a => a -> GroupMemberId
contactId' Contact
ct) SharedMsgId
sharedMsgId
            if ChatItem 'CTDirect d -> Bool
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> Bool
ciReactionAllowed ChatItem 'CTDirect d
ci
              then IO (Maybe ChatEvent) -> ExceptT StoreError IO (Maybe ChatEvent)
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ChatEvent) -> ExceptT StoreError IO (Maybe ChatEvent))
-> IO (Maybe ChatEvent) -> ExceptT StoreError IO (Maybe ChatEvent)
forall a b. (a -> b) -> a -> b
$ do
                Connection
-> Contact
-> SharedMsgId
-> Bool
-> MsgReaction
-> Bool
-> GroupMemberId
-> UTCTime
-> IO ()
setDirectReaction Connection
db Contact
ct SharedMsgId
sharedMsgId Bool
False MsgReaction
reaction Bool
add GroupMemberId
msgId UTCTime
brokerTs
                [CIReactionCount]
reactions <- Connection -> Contact -> SharedMsgId -> IO [CIReactionCount]
getDirectCIReactions Connection
db Contact
ct SharedMsgId
sharedMsgId
                let ci' :: CChatItem 'CTDirect
ci' = SMsgDirection d -> ChatItem 'CTDirect d -> CChatItem 'CTDirect
forall (c :: ChatType) (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d -> ChatItem c d -> CChatItem c
CChatItem SMsgDirection d
md ChatItem 'CTDirect d
ci {reactions}
                    r :: ACIReaction
r = SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> CIReaction 'CTDirect 'MDRcv
-> ACIReaction
forall (c :: ChatType) (d :: MsgDirection).
ChatTypeI c =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> CIReaction c d -> ACIReaction
ACIReaction SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv (Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct) (CIReaction 'CTDirect 'MDRcv -> ACIReaction)
-> CIReaction 'CTDirect 'MDRcv -> ACIReaction
forall a b. (a -> b) -> a -> b
$ CIDirection 'CTDirect 'MDRcv
-> CChatItem 'CTDirect
-> UTCTime
-> MsgReaction
-> CIReaction 'CTDirect 'MDRcv
forall (c :: ChatType) (d :: MsgDirection).
CIDirection c d
-> CChatItem c -> UTCTime -> MsgReaction -> CIReaction c d
CIReaction CIDirection 'CTDirect 'MDRcv
CIDirectRcv CChatItem 'CTDirect
ci' UTCTime
brokerTs MsgReaction
reaction
                Maybe ChatEvent -> IO (Maybe ChatEvent)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ChatEvent -> IO (Maybe ChatEvent))
-> Maybe ChatEvent -> IO (Maybe ChatEvent)
forall a b. (a -> b) -> a -> b
$ ChatEvent -> Maybe ChatEvent
forall a. a -> Maybe a
Just (ChatEvent -> Maybe ChatEvent) -> ChatEvent -> Maybe ChatEvent
forall a b. (a -> b) -> a -> b
$ User -> Bool -> ACIReaction -> ChatEvent
CEvtChatItemReaction User
user Bool
add ACIReaction
r
              else Maybe ChatEvent -> ExceptT StoreError IO (Maybe ChatEvent)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ChatEvent
forall a. Maybe a
Nothing
          (ChatEvent -> CM ()) -> Maybe ChatEvent -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ChatEvent -> CM ()
toView Maybe ChatEvent
cEvt_

    groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> Maybe MsgScope -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
    groupMsgReaction :: GroupInfo
-> GroupMember
-> SharedMsgId
-> MemberId
-> Maybe MsgScope
-> MsgReaction
-> Bool
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMsgReaction GroupInfo
g m :: GroupMember
m@GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole} SharedMsgId
sharedMsgId MemberId
itemMemberId Maybe MsgScope
scope_ MsgReaction
reaction Bool
add RcvMessage {GroupMemberId
msgId :: RcvMessage -> GroupMemberId
msgId :: GroupMemberId
msgId} UTCTime
brokerTs
      | SGroupFeature 'GFReactions -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureNoRoleI f =>
SGroupFeature f -> GroupInfo -> Bool
groupFeatureAllowed SGroupFeature 'GFReactions
SGFReactions GroupInfo
g = do
          [MsgReaction]
rs <- (Connection -> IO [MsgReaction]) -> CM [MsgReaction]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [MsgReaction]) -> CM [MsgReaction])
-> (Connection -> IO [MsgReaction]) -> CM [MsgReaction]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupInfo
-> GroupMember
-> MemberId
-> SharedMsgId
-> Bool
-> IO [MsgReaction]
getGroupReactions Connection
db GroupInfo
g GroupMember
m MemberId
itemMemberId SharedMsgId
sharedMsgId Bool
False
          if Bool -> MsgReaction -> [MsgReaction] -> Bool
reactionAllowed Bool
add MsgReaction
reaction [MsgReaction]
rs
            then
              ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
updateChatItemReaction ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> (SharedMsgId
    -> ExceptT
         ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. CM a -> (SharedMsgId -> CM a) -> CM a
`catchCINotFound` \SharedMsgId
_ -> case Maybe MsgScope
scope_ of
                Just (MSMember MemberId
scopeMemberId)
                  | GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
>= GroupMemberRole
GRModerator Bool -> Bool -> Bool
|| MemberId
scopeMemberId MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMember -> MemberId
memberId' GroupMember
m ->
                      (Connection -> ExceptT StoreError IO (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe DeliveryJobScope))
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> (Connection -> ExceptT StoreError IO (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                        IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection
-> GroupInfo
-> GroupMember
-> MemberId
-> SharedMsgId
-> Bool
-> MsgReaction
-> Bool
-> GroupMemberId
-> UTCTime
-> IO ()
setGroupReaction Connection
db GroupInfo
g GroupMember
m MemberId
itemMemberId SharedMsgId
sharedMsgId Bool
False MsgReaction
reaction Bool
add GroupMemberId
msgId UTCTime
brokerTs
                        DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DeliveryJobScope -> Maybe DeliveryJobScope)
-> (GroupMemberId -> DeliveryJobScope)
-> GroupMemberId
-> Maybe DeliveryJobScope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupMemberId -> DeliveryJobScope
DJSMemberSupport (GroupMemberId -> Maybe DeliveryJobScope)
-> ExceptT StoreError IO GroupMemberId
-> ExceptT StoreError IO (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> User
-> GroupInfo
-> GroupMember
-> MemberId
-> ExceptT StoreError IO GroupMemberId
getScopeMemberIdViaMemberId Connection
db User
user GroupInfo
g GroupMember
m MemberId
scopeMemberId
                  | Bool
otherwise -> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
forall a. Maybe a
Nothing
                Maybe MsgScope
Nothing -> do
                  (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupInfo
-> GroupMember
-> MemberId
-> SharedMsgId
-> Bool
-> MsgReaction
-> Bool
-> GroupMemberId
-> UTCTime
-> IO ()
setGroupReaction Connection
db GroupInfo
g GroupMember
m MemberId
itemMemberId SharedMsgId
sharedMsgId Bool
False MsgReaction
reaction Bool
add GroupMemberId
msgId UTCTime
brokerTs
                  Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just DJSGroup {jobSpec :: DeliveryJobSpec
jobSpec = DJDeliveryJob {includePending :: Bool
includePending = Bool
False}}
            else Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
forall a. Maybe a
Nothing
      | Bool
otherwise = Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
forall a. Maybe a
Nothing
      where
        updateChatItemReaction :: ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
updateChatItemReaction = do
          (CChatItem SMsgDirection d
md ChatItem 'CTGroup d
ci, Maybe GroupChatScopeInfo
scopeInfo) <- (Connection
 -> ExceptT
      StoreError IO (CChatItem 'CTGroup, Maybe GroupChatScopeInfo))
-> CM (CChatItem 'CTGroup, Maybe GroupChatScopeInfo)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection
  -> ExceptT
       StoreError IO (CChatItem 'CTGroup, Maybe GroupChatScopeInfo))
 -> CM (CChatItem 'CTGroup, Maybe GroupChatScopeInfo))
-> (Connection
    -> ExceptT
         StoreError IO (CChatItem 'CTGroup, Maybe GroupChatScopeInfo))
-> CM (CChatItem 'CTGroup, Maybe GroupChatScopeInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
            CChatItem 'CTGroup
cci <- Connection
-> User
-> GroupInfo
-> MemberId
-> SharedMsgId
-> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupMemberCIBySharedMsgId Connection
db User
user GroupInfo
g MemberId
itemMemberId SharedMsgId
sharedMsgId
            Maybe GroupChatScopeInfo
scopeInfo <- Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> GroupMemberId
-> ExceptT StoreError IO (Maybe GroupChatScopeInfo)
getGroupChatScopeInfoForItem Connection
db VersionRangeChat
vr User
user GroupInfo
g (CChatItem 'CTGroup -> GroupMemberId
forall (c :: ChatType). CChatItem c -> GroupMemberId
cChatItemId CChatItem 'CTGroup
cci)
            (CChatItem 'CTGroup, Maybe GroupChatScopeInfo)
-> ExceptT
     StoreError IO (CChatItem 'CTGroup, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CChatItem 'CTGroup
cci, Maybe GroupChatScopeInfo
scopeInfo)
          if ChatItem 'CTGroup d -> Bool
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> Bool
ciReactionAllowed ChatItem 'CTGroup d
ci
            then do
              [CIReactionCount]
reactions <- (Connection -> IO [CIReactionCount])
-> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [CIReactionCount])
 -> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount])
-> (Connection -> IO [CIReactionCount])
-> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                Connection
-> GroupInfo
-> GroupMember
-> MemberId
-> SharedMsgId
-> Bool
-> MsgReaction
-> Bool
-> GroupMemberId
-> UTCTime
-> IO ()
setGroupReaction Connection
db GroupInfo
g GroupMember
m MemberId
itemMemberId SharedMsgId
sharedMsgId Bool
False MsgReaction
reaction Bool
add GroupMemberId
msgId UTCTime
brokerTs
                Connection
-> GroupInfo -> MemberId -> SharedMsgId -> IO [CIReactionCount]
getGroupCIReactions Connection
db GroupInfo
g MemberId
itemMemberId SharedMsgId
sharedMsgId
              let ci' :: CChatItem 'CTGroup
ci' = SMsgDirection d -> ChatItem 'CTGroup d -> CChatItem 'CTGroup
forall (c :: ChatType) (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d -> ChatItem c d -> CChatItem c
CChatItem SMsgDirection d
md ChatItem 'CTGroup d
ci {reactions}
                  r :: ACIReaction
r = SChatType 'CTGroup
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTGroup
-> CIReaction 'CTGroup 'MDRcv
-> ACIReaction
forall (c :: ChatType) (d :: MsgDirection).
ChatTypeI c =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> CIReaction c d -> ACIReaction
ACIReaction SChatType 'CTGroup
SCTGroup SMsgDirection 'MDRcv
SMDRcv (GroupInfo -> Maybe GroupChatScopeInfo -> ChatInfo 'CTGroup
GroupChat GroupInfo
g Maybe GroupChatScopeInfo
scopeInfo) (CIReaction 'CTGroup 'MDRcv -> ACIReaction)
-> CIReaction 'CTGroup 'MDRcv -> ACIReaction
forall a b. (a -> b) -> a -> b
$ CIDirection 'CTGroup 'MDRcv
-> CChatItem 'CTGroup
-> UTCTime
-> MsgReaction
-> CIReaction 'CTGroup 'MDRcv
forall (c :: ChatType) (d :: MsgDirection).
CIDirection c d
-> CChatItem c -> UTCTime -> MsgReaction -> CIReaction c d
CIReaction (GroupMember -> CIDirection 'CTGroup 'MDRcv
CIGroupRcv GroupMember
m) CChatItem 'CTGroup
ci' UTCTime
brokerTs MsgReaction
reaction
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Bool -> ACIReaction -> ChatEvent
CEvtChatItemReaction User
user Bool
add ACIReaction
r
              Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DeliveryJobScope -> Maybe DeliveryJobScope)
-> DeliveryJobScope -> Maybe DeliveryJobScope
forall a b. (a -> b) -> a -> b
$ GroupInfo -> Maybe GroupChatScopeInfo -> DeliveryJobScope
infoToDeliveryScope GroupInfo
g Maybe GroupChatScopeInfo
scopeInfo
            else Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
forall a. Maybe a
Nothing

    reactionAllowed :: Bool -> MsgReaction -> [MsgReaction] -> Bool
    reactionAllowed :: Bool -> MsgReaction -> [MsgReaction] -> Bool
reactionAllowed Bool
add MsgReaction
reaction [MsgReaction]
rs = (MsgReaction
reaction MsgReaction -> [MsgReaction] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MsgReaction]
rs) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
add Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool
add Bool -> Bool -> Bool
&& [MsgReaction] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MsgReaction]
rs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxMsgReactions)

    catchCINotFound :: CM a -> (SharedMsgId -> CM a) -> CM a
    catchCINotFound :: forall a. CM a -> (SharedMsgId -> CM a) -> CM a
catchCINotFound CM a
f SharedMsgId -> CM a
handle =
      CM a
f CM a -> (ChatError -> CM a) -> CM a
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \case
        ChatErrorStore (SEChatItemSharedMsgIdNotFound SharedMsgId
sharedMsgId) -> SharedMsgId -> CM a
handle SharedMsgId
sharedMsgId
        ChatError
e -> ChatError -> CM a
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
e

    newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope)
    newGroupContentMessage :: GroupInfo
-> GroupMember
-> MsgContainer
-> RcvMessage
-> UTCTime
-> Bool
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
newGroupContentMessage GroupInfo
gInfo m :: GroupMember
m@GroupMember {MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId, GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole} MsgContainer
mc msg :: RcvMessage
msg@RcvMessage {Maybe SharedMsgId
sharedMsgId_ :: RcvMessage -> Maybe SharedMsgId
sharedMsgId_ :: Maybe SharedMsgId
sharedMsgId_} UTCTime
brokerTs Bool
forwarded = do
      (GroupInfo
gInfo', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- VersionRangeChat
-> User
-> GroupInfo
-> GroupMember
-> MsgContent
-> Maybe MsgScope
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGetMessageChatScope VersionRangeChat
vr User
user GroupInfo
gInfo GroupMember
m MsgContent
content Maybe MsgScope
msgScope_
      if GroupMember -> Bool
blockedByAdmin GroupMember
m'
        then GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> CM ()
createBlockedByAdmin GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
        else
          case GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> MsgContent
-> Maybe MarkdownList
-> Maybe FileInvitation
-> Bool
-> Maybe GroupFeature
forall f.
GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> MsgContent
-> Maybe MarkdownList
-> Maybe f
-> Bool
-> Maybe GroupFeature
prohibitedGroupContent GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo MsgContent
content Maybe MarkdownList
ft_ Maybe FileInvitation
fInv_ Bool
False of
            Just GroupFeature
f -> GroupInfo
-> GroupMember -> Maybe GroupChatScopeInfo -> GroupFeature -> CM ()
rejected GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo GroupFeature
f CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
            Maybe GroupFeature
Nothing ->
              (Connection -> IO (Maybe CIModeration)) -> CM (Maybe CIModeration)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> Maybe SharedMsgId
-> IO (Maybe CIModeration)
getCIModeration Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo' MemberId
memberId Maybe SharedMsgId
sharedMsgId_) CM (Maybe CIModeration)
-> (Maybe CIModeration
    -> ExceptT
         ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just CIModeration
ciModeration -> do
                  GroupInfo
-> GroupMember -> Maybe GroupChatScopeInfo -> CIModeration -> CM ()
applyModeration GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo CIModeration
ciModeration
                  (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> GroupInfo -> MemberId -> Maybe SharedMsgId -> IO ()
deleteCIModeration Connection
db GroupInfo
gInfo' MemberId
memberId Maybe SharedMsgId
sharedMsgId_
                  Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
forall a. Maybe a
Nothing
                Maybe CIModeration
Nothing -> do
                  GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> CM ()
createContentItem GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo
                  Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DeliveryJobScope -> Maybe DeliveryJobScope)
-> DeliveryJobScope -> Maybe DeliveryJobScope
forall a b. (a -> b) -> a -> b
$ GroupInfo -> Maybe GroupChatScopeInfo -> DeliveryJobScope
infoToDeliveryScope GroupInfo
gInfo Maybe GroupChatScopeInfo
scopeInfo
      where
        rejected :: GroupInfo
-> GroupMember -> Maybe GroupChatScopeInfo -> GroupFeature -> CM ()
rejected GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo GroupFeature
f = GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> CM ()
newChatItem GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo (CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
ciContentNoParse (CIContent 'MDRcv
 -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)))
-> CIContent 'MDRcv
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
forall a b. (a -> b) -> a -> b
$ GroupFeature -> CIContent 'MDRcv
CIRcvGroupFeatureRejected GroupFeature
f) Maybe (CIFile 'MDRcv)
forall a. Maybe a
Nothing Maybe CITimed
forall a. Maybe a
Nothing Bool
False
        timed' :: GroupInfo -> Maybe CITimed
timed' GroupInfo
gInfo' = if Bool
forwarded then Maybe (Maybe Int) -> Maybe Int -> Maybe CITimed
rcvCITimed_ (Maybe Int -> Maybe (Maybe Int)
forall a. a -> Maybe a
Just Maybe Int
forall a. Maybe a
Nothing) Maybe Int
itemTTL else GroupInfo -> Maybe Int -> Maybe CITimed
rcvGroupCITimed GroupInfo
gInfo' Maybe Int
itemTTL
        live' :: Bool
live' = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
live_
        ExtMsgContent MsgContent
content Map Text MsgMention
mentions Maybe FileInvitation
fInv_ Maybe Int
itemTTL Maybe Bool
live_ Maybe MsgScope
msgScope_ = MsgContainer -> ExtMsgContent
mcExtMsgContent MsgContainer
mc
        ts :: (Text, Maybe MarkdownList)
ts@(Text
_, Maybe MarkdownList
ft_) = MsgContent -> (Text, Maybe MarkdownList)
msgContentTexts MsgContent
content
        saveRcvCI :: GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
saveRcvCI GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo = User
-> ChatDirection 'CTGroup 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') RcvMessage
msg Maybe SharedMsgId
sharedMsgId_ UTCTime
brokerTs
        createBlockedByAdmin :: GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> CM ()
createBlockedByAdmin GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo
          | SGroupFeature 'GFFullDelete -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureNoRoleI f =>
SGroupFeature f -> GroupInfo -> Bool
groupFeatureAllowed SGroupFeature 'GFFullDelete
SGFFullDelete GroupInfo
gInfo' = do
              -- ignores member role when blocked by admin
              (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
saveRcvCI GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo (CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
ciContentNoParse CIContent 'MDRcv
CIRcvBlocked) Maybe (CIFile 'MDRcv)
forall a. Maybe a
Nothing (GroupInfo -> Maybe CITimed
timed' GroupInfo
gInfo') Bool
False Map Text MsgMention
forall k a. Map k a
M.empty
              ChatItem 'CTGroup 'MDRcv
ci' <- (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (ChatItem 'CTGroup 'MDRcv))
 -> CM (ChatItem 'CTGroup 'MDRcv))
-> (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup 'MDRcv
-> UTCTime
-> IO (ChatItem 'CTGroup 'MDRcv)
forall (d :: MsgDirection).
Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup d
-> UTCTime
-> IO (ChatItem 'CTGroup d)
updateGroupCIBlockedByAdmin Connection
db User
user GroupInfo
gInfo' ChatItem 'CTGroup 'MDRcv
ci UTCTime
brokerTs
              ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci'
          | Bool
otherwise = do
              Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_ <- GroupMember -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
processFileInv GroupMember
m'
              (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> Maybe (RcvFileTransfer, CIFile 'MDRcv)
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
createNonLive GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_
              ChatItem 'CTGroup 'MDRcv
ci' <- (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (ChatItem 'CTGroup 'MDRcv))
 -> CM (ChatItem 'CTGroup 'MDRcv))
-> (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup 'MDRcv
-> IO (ChatItem 'CTGroup 'MDRcv)
markGroupCIBlockedByAdmin Connection
db User
user GroupInfo
gInfo' ChatItem 'CTGroup 'MDRcv
ci
              ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci'
        applyModeration :: GroupInfo
-> GroupMember -> Maybe GroupChatScopeInfo -> CIModeration -> CM ()
applyModeration GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo CIModeration {moderatorMember :: CIModeration -> GroupMember
moderatorMember = moderator :: GroupMember
moderator@GroupMember {memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
moderatorRole}, UTCTime
moderatedAt :: UTCTime
moderatedAt :: CIModeration -> UTCTime
moderatedAt}
          | GroupMemberRole
moderatorRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GRModerator Bool -> Bool -> Bool
|| GroupMemberRole
moderatorRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
memberRole =
              GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> CM ()
createContentItem GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo
          | SGroupFeature 'GFFullDelete -> GroupMember -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupMember -> GroupInfo -> Bool
groupFeatureMemberAllowed SGroupFeature 'GFFullDelete
SGFFullDelete GroupMember
moderator GroupInfo
gInfo' = do
              (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
saveRcvCI GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo (CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
ciContentNoParse CIContent 'MDRcv
CIRcvModerated) Maybe (CIFile 'MDRcv)
forall a. Maybe a
Nothing (GroupInfo -> Maybe CITimed
timed' GroupInfo
gInfo') Bool
False Map Text MsgMention
forall k a. Map k a
M.empty
              ChatItem 'CTGroup 'MDRcv
ci' <- (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (ChatItem 'CTGroup 'MDRcv))
 -> CM (ChatItem 'CTGroup 'MDRcv))
-> (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup 'MDRcv
-> GroupMember
-> UTCTime
-> IO (ChatItem 'CTGroup 'MDRcv)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup d
-> GroupMember
-> UTCTime
-> IO (ChatItem 'CTGroup d)
updateGroupChatItemModerated Connection
db User
user GroupInfo
gInfo' ChatItem 'CTGroup 'MDRcv
ci GroupMember
moderator UTCTime
moderatedAt
              ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci'
          | Bool
otherwise = do
              Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_ <- GroupMember -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
processFileInv GroupMember
m'
              (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
_cInfo) <- GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> Maybe (RcvFileTransfer, CIFile 'MDRcv)
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
createNonLive GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_
              [ChatItemDeletion]
deletions <- User
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> [CChatItem 'CTGroup]
-> Maybe GroupMember
-> UTCTime
-> CM [ChatItemDeletion]
markGroupCIsDeleted User
user GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo [SMsgDirection 'MDRcv
-> ChatItem 'CTGroup 'MDRcv -> CChatItem 'CTGroup
forall (c :: ChatType) (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d -> ChatItem c d -> CChatItem c
CChatItem SMsgDirection 'MDRcv
SMDRcv ChatItem 'CTGroup 'MDRcv
ci] (GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
moderator) UTCTime
moderatedAt
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [ChatItemDeletion] -> Bool -> Bool -> ChatEvent
CEvtChatItemsDeleted User
user [ChatItemDeletion]
deletions Bool
False Bool
False
        createNonLive :: GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> Maybe (RcvFileTransfer, CIFile 'MDRcv)
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
createNonLive GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_ = do
          GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
saveRcvCI GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo (MsgContent -> CIContent 'MDRcv
CIRcvMsgContent MsgContent
content, (Text, Maybe MarkdownList)
ts) ((RcvFileTransfer, CIFile 'MDRcv) -> CIFile 'MDRcv
forall a b. (a, b) -> b
snd ((RcvFileTransfer, CIFile 'MDRcv) -> CIFile 'MDRcv)
-> Maybe (RcvFileTransfer, CIFile 'MDRcv) -> Maybe (CIFile 'MDRcv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_) (GroupInfo -> Maybe CITimed
timed' GroupInfo
gInfo') Bool
False Map Text MsgMention
mentions
        createContentItem :: GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> CM ()
createContentItem GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo = do
          Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_ <- GroupMember -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
processFileInv GroupMember
m'
          GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> CM ()
newChatItem GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo (MsgContent -> CIContent 'MDRcv
CIRcvMsgContent MsgContent
content, (Text, Maybe MarkdownList)
ts) ((RcvFileTransfer, CIFile 'MDRcv) -> CIFile 'MDRcv
forall a b. (a, b) -> b
snd ((RcvFileTransfer, CIFile 'MDRcv) -> CIFile 'MDRcv)
-> Maybe (RcvFileTransfer, CIFile 'MDRcv) -> Maybe (CIFile 'MDRcv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_) (GroupInfo -> Maybe CITimed
timed' GroupInfo
gInfo') Bool
live'
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupMember -> Bool
memberBlocked GroupMember
m') (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM ()
autoAcceptFile Maybe (RcvFileTransfer, CIFile 'MDRcv)
file_
        processFileInv :: GroupMember -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
processFileInv GroupMember
m' =
          Maybe FileInvitation
-> MsgContent
-> (Connection
    -> FileInvitation
    -> Maybe InlineFileMode
    -> Integer
    -> ExceptT StoreError IO RcvFileTransfer)
-> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
processFileInvitation Maybe FileInvitation
fInv_ MsgContent
content ((Connection
  -> FileInvitation
  -> Maybe InlineFileMode
  -> Integer
  -> ExceptT StoreError IO RcvFileTransfer)
 -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv)))
-> (Connection
    -> FileInvitation
    -> Maybe InlineFileMode
    -> Integer
    -> ExceptT StoreError IO RcvFileTransfer)
-> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMember
-> FileInvitation
-> Maybe InlineFileMode
-> Integer
-> ExceptT StoreError IO RcvFileTransfer
createRcvGroupFileTransfer Connection
db GroupMemberId
userId GroupMember
m'
        newChatItem :: GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> CM ()
newChatItem GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo (CIContent 'MDRcv, (Text, Maybe MarkdownList))
ciContent Maybe (CIFile 'MDRcv)
ciFile_ Maybe CITimed
timed_ Bool
live = do
          let mentions' :: Map Text MsgMention
mentions' = if GroupMember -> Bool
memberBlocked GroupMember
m' then [] else Map Text MsgMention
mentions
          (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
saveRcvCI GroupInfo
gInfo' GroupMember
m' Maybe GroupChatScopeInfo
scopeInfo (CIContent 'MDRcv, (Text, Maybe MarkdownList))
ciContent Maybe (CIFile 'MDRcv)
ciFile_ Maybe CITimed
timed_ Bool
live Map Text MsgMention
mentions'
          ChatItem 'CTGroup 'MDRcv
ci' <- GroupInfo
-> GroupMember
-> ChatItem 'CTGroup 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv)
blockedMemberCI GroupInfo
gInfo' GroupMember
m' ChatItem 'CTGroup 'MDRcv
ci
          [CIReactionCount]
reactions <- ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
-> (SharedMsgId
    -> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount])
-> Maybe SharedMsgId
-> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([CIReactionCount]
-> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (\SharedMsgId
sharedMsgId -> (Connection -> IO [CIReactionCount])
-> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [CIReactionCount])
 -> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount])
-> (Connection -> IO [CIReactionCount])
-> ExceptT ChatError (ReaderT ChatController IO) [CIReactionCount]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupInfo -> MemberId -> SharedMsgId -> IO [CIReactionCount]
getGroupCIReactions Connection
db GroupInfo
gInfo' MemberId
memberId SharedMsgId
sharedMsgId) Maybe SharedMsgId
sharedMsgId_
          ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci' {reactions}

    groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM (Maybe DeliveryJobScope)
    groupMessageUpdate :: GroupInfo
-> GroupMember
-> SharedMsgId
-> MsgContent
-> Map Text MsgMention
-> Maybe MsgScope
-> RcvMessage
-> UTCTime
-> Maybe Int
-> Maybe Bool
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMessageUpdate gInfo :: GroupInfo
gInfo@GroupInfo {GroupMemberId
groupId :: GroupInfo -> GroupMemberId
groupId :: GroupMemberId
groupId} m :: GroupMember
m@GroupMember {GroupMemberId
groupMemberId :: GroupMember -> GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId, MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId} SharedMsgId
sharedMsgId MsgContent
mc Map Text MsgMention
mentions Maybe MsgScope
msgScope_ msg :: RcvMessage
msg@RcvMessage {GroupMemberId
msgId :: RcvMessage -> GroupMemberId
msgId :: GroupMemberId
msgId} UTCTime
brokerTs Maybe Int
ttl_ Maybe Bool
live_
      | GroupInfo -> GroupMember -> Maybe MarkdownList -> Bool
prohibitedSimplexLinks GroupInfo
gInfo GroupMember
m Maybe MarkdownList
ft_ =
          Text -> CM ()
messageWarning (Text
"x.msg.update ignored: feature not allowed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupFeature -> Text
groupFeatureNameText GroupFeature
GFSimplexLinks) CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
      | Bool
otherwise = do
          ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
updateRcvChatItem ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> (SharedMsgId
    -> ExceptT
         ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. CM a -> (SharedMsgId -> CM a) -> CM a
`catchCINotFound` \SharedMsgId
_ -> do
            -- This patches initial sharedMsgId into chat item when locally deleted chat item
            -- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
            -- Chat item and update message which created it will have different sharedMsgId in this case...
            let timed_ :: Maybe CITimed
timed_ = GroupInfo -> Maybe Int -> Maybe CITimed
rcvGroupCITimed GroupInfo
gInfo Maybe Int
ttl_
                mentions' :: Map Text MsgMention
mentions' = if GroupMember -> Bool
memberBlocked GroupMember
m then [] else Map Text MsgMention
mentions
            (GroupInfo
gInfo', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- VersionRangeChat
-> User
-> GroupInfo
-> GroupMember
-> MsgContent
-> Maybe MsgScope
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGetMessageChatScope VersionRangeChat
vr User
user GroupInfo
gInfo GroupMember
m MsgContent
mc Maybe MsgScope
msgScope_
            (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- User
-> ChatDirection 'CTGroup 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') RcvMessage
msg (SharedMsgId -> Maybe SharedMsgId
forall a. a -> Maybe a
Just SharedMsgId
sharedMsgId) UTCTime
brokerTs (CIContent 'MDRcv
content, (Text, Maybe MarkdownList)
ts) Maybe (CIFile 'MDRcv)
forall a. Maybe a
Nothing Maybe CITimed
timed_ Bool
live Map Text MsgMention
mentions'
            ChatItem 'CTGroup 'MDRcv
ci' <- (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (ChatItem 'CTGroup 'MDRcv))
 -> CM (ChatItem 'CTGroup 'MDRcv))
-> (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
              Connection -> GroupMemberId -> UTCTime -> MsgContent -> IO ()
createChatItemVersion Connection
db (ChatItem 'CTGroup 'MDRcv -> GroupMemberId
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> GroupMemberId
chatItemId' ChatItem 'CTGroup 'MDRcv
ci) UTCTime
brokerTs MsgContent
mc
              Connection
-> User
-> GroupMemberId
-> ChatItem 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Bool
-> Bool
-> Maybe GroupMemberId
-> IO (ChatItem 'CTGroup 'MDRcv)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupMemberId
-> ChatItem 'CTGroup d
-> CIContent d
-> Bool
-> Bool
-> Maybe GroupMemberId
-> IO (ChatItem 'CTGroup d)
updateGroupChatItem Connection
db User
user GroupMemberId
groupId ChatItem 'CTGroup 'MDRcv
ci CIContent 'MDRcv
content Bool
True Bool
live Maybe GroupMemberId
forall a. Maybe a
Nothing
            ChatItem 'CTGroup 'MDRcv
ci'' <- GroupInfo
-> GroupMember
-> ChatItem 'CTGroup 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv)
blockedMemberCI GroupInfo
gInfo' GroupMember
m' ChatItem 'CTGroup 'MDRcv
ci'
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemUpdated User
user (SChatType 'CTGroup
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTGroup
-> ChatItem 'CTGroup 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTGroup
SCTGroup SMsgDirection 'MDRcv
SMDRcv ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci'')
            Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DeliveryJobScope -> Maybe DeliveryJobScope)
-> DeliveryJobScope -> Maybe DeliveryJobScope
forall a b. (a -> b) -> a -> b
$ GroupInfo -> Maybe GroupChatScopeInfo -> DeliveryJobScope
infoToDeliveryScope GroupInfo
gInfo Maybe GroupChatScopeInfo
scopeInfo
      where
        content :: CIContent 'MDRcv
content = MsgContent -> CIContent 'MDRcv
CIRcvMsgContent MsgContent
mc
        ts :: (Text, Maybe MarkdownList)
ts@(Text
_, Maybe MarkdownList
ft_) = MsgContent -> (Text, Maybe MarkdownList)
msgContentTexts MsgContent
mc
        live :: Bool
live = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
live_
        updateRcvChatItem :: ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
updateRcvChatItem = do
          CChatItem 'CTGroup
cci <- (Connection -> ExceptT StoreError IO (CChatItem 'CTGroup))
-> CM (CChatItem 'CTGroup)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (CChatItem 'CTGroup))
 -> CM (CChatItem 'CTGroup))
-> (Connection -> ExceptT StoreError IO (CChatItem 'CTGroup))
-> CM (CChatItem 'CTGroup)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItemBySharedMsgId Connection
db User
user GroupInfo
gInfo GroupMemberId
groupMemberId SharedMsgId
sharedMsgId
          Maybe GroupChatScopeInfo
scopeInfo <- (Connection -> ExceptT StoreError IO (Maybe GroupChatScopeInfo))
-> CM (Maybe GroupChatScopeInfo)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe GroupChatScopeInfo))
 -> CM (Maybe GroupChatScopeInfo))
-> (Connection -> ExceptT StoreError IO (Maybe GroupChatScopeInfo))
-> CM (Maybe GroupChatScopeInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> GroupMemberId
-> ExceptT StoreError IO (Maybe GroupChatScopeInfo)
getGroupChatScopeInfoForItem Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo (CChatItem 'CTGroup -> GroupMemberId
forall (c :: ChatType). CChatItem c -> GroupMemberId
cChatItemId CChatItem 'CTGroup
cci)
          case CChatItem 'CTGroup
cci of
            CChatItem SMsgDirection d
SMDRcv ci :: ChatItem 'CTGroup d
ci@ChatItem {chatDir :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIDirection c d
chatDir = CIGroupRcv GroupMember
m', meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta = CIMeta {Maybe Bool
itemLive :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> Maybe Bool
itemLive :: Maybe Bool
itemLive}, content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content = CIRcvMsgContent MsgContent
oldMC} ->
              if MemberId -> GroupMember -> Bool
sameMemberId MemberId
memberId GroupMember
m'
                then do
                  let changed :: Bool
changed = MsgContent
mc MsgContent -> MsgContent -> Bool
forall a. Eq a => a -> a -> Bool
/= MsgContent
oldMC
                  if Bool
changed Bool -> Bool -> Bool
|| Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
itemLive
                    then do
                      ChatItem 'CTGroup d
ci' <- (Connection -> IO (ChatItem 'CTGroup d))
-> CM (ChatItem 'CTGroup d)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (ChatItem 'CTGroup d))
 -> CM (ChatItem 'CTGroup d))
-> (Connection -> IO (ChatItem 'CTGroup d))
-> CM (ChatItem 'CTGroup d)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                          Connection
-> GroupMemberId
-> (UTCTime, MsgContent)
-> (UTCTime, MsgContent)
-> IO ()
addInitialAndNewCIVersions Connection
db (ChatItem 'CTGroup d -> GroupMemberId
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> GroupMemberId
chatItemId' ChatItem 'CTGroup d
ci) (ChatItem 'CTGroup d -> UTCTime
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> UTCTime
chatItemTs' ChatItem 'CTGroup d
ci, MsgContent
oldMC) (UTCTime
brokerTs, MsgContent
mc)
                        [CIReactionCount]
reactions <- Connection
-> GroupInfo -> MemberId -> SharedMsgId -> IO [CIReactionCount]
getGroupCIReactions Connection
db GroupInfo
gInfo MemberId
memberId SharedMsgId
sharedMsgId
                        let edited :: Bool
edited = Maybe Bool
itemLive Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
                        Map Text CIMention
ciMentions <- Connection
-> User
-> GroupInfo
-> Maybe MarkdownList
-> Map Text MsgMention
-> IO (Map Text CIMention)
getRcvCIMentions Connection
db User
user GroupInfo
gInfo Maybe MarkdownList
ft_ Map Text MsgMention
mentions
                        ChatItem 'CTGroup d
ci' <- Connection
-> User
-> GroupMemberId
-> ChatItem 'CTGroup d
-> CIContent d
-> Bool
-> Bool
-> Maybe GroupMemberId
-> IO (ChatItem 'CTGroup d)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupMemberId
-> ChatItem 'CTGroup d
-> CIContent d
-> Bool
-> Bool
-> Maybe GroupMemberId
-> IO (ChatItem 'CTGroup d)
updateGroupChatItem Connection
db User
user GroupMemberId
groupId ChatItem 'CTGroup d
ci {reactions} CIContent d
CIContent 'MDRcv
content Bool
edited Bool
live (Maybe GroupMemberId -> IO (ChatItem 'CTGroup d))
-> Maybe GroupMemberId -> IO (ChatItem 'CTGroup d)
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just GroupMemberId
msgId
                        Connection
-> GroupInfo
-> ChatItem 'CTGroup d
-> Map Text CIMention
-> IO (ChatItem 'CTGroup d)
forall (d :: MsgDirection).
Connection
-> GroupInfo
-> ChatItem 'CTGroup d
-> Map Text CIMention
-> IO (ChatItem 'CTGroup d)
updateGroupCIMentions Connection
db GroupInfo
gInfo ChatItem 'CTGroup d
ci' Map Text CIMention
ciMentions
                      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemUpdated User
user (SChatType 'CTGroup
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTGroup
-> ChatItem 'CTGroup 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTGroup
SCTGroup SMsgDirection 'MDRcv
SMDRcv (GroupInfo -> Maybe GroupChatScopeInfo -> ChatInfo 'CTGroup
GroupChat GroupInfo
gInfo Maybe GroupChatScopeInfo
scopeInfo) ChatItem 'CTGroup d
ChatItem 'CTGroup 'MDRcv
ci')
                      User
-> ChatRef -> ChatItem 'CTGroup d -> ChatItem 'CTGroup d -> CM ()
forall (c :: ChatType) (d :: MsgDirection).
User -> ChatRef -> ChatItem c d -> ChatItem c d -> CM ()
startUpdatedTimedItemThread User
user (ChatType -> GroupMemberId -> Maybe GroupChatScope -> ChatRef
ChatRef ChatType
CTGroup GroupMemberId
groupId (Maybe GroupChatScope -> ChatRef)
-> Maybe GroupChatScope -> ChatRef
forall a b. (a -> b) -> a -> b
$ GroupChatScopeInfo -> GroupChatScope
toChatScope (GroupChatScopeInfo -> GroupChatScope)
-> Maybe GroupChatScopeInfo -> Maybe GroupChatScope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GroupChatScopeInfo
scopeInfo) ChatItem 'CTGroup d
ci ChatItem 'CTGroup d
ci'
                      Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DeliveryJobScope -> Maybe DeliveryJobScope)
-> DeliveryJobScope -> Maybe DeliveryJobScope
forall a b. (a -> b) -> a -> b
$ GroupInfo -> Maybe GroupChatScopeInfo -> DeliveryJobScope
infoToDeliveryScope GroupInfo
gInfo Maybe GroupChatScopeInfo
scopeInfo
                    else do
                      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemNotChanged User
user (SChatType 'CTGroup
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTGroup
-> ChatItem 'CTGroup 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTGroup
SCTGroup SMsgDirection 'MDRcv
SMDRcv (GroupInfo -> Maybe GroupChatScopeInfo -> ChatInfo 'CTGroup
GroupChat GroupInfo
gInfo Maybe GroupChatScopeInfo
scopeInfo) ChatItem 'CTGroup d
ChatItem 'CTGroup 'MDRcv
ci)
                      Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
forall a. Maybe a
Nothing
                else Text -> CM ()
messageError Text
"x.msg.update: group member attempted to update a message of another member" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
            CChatItem 'CTGroup
_ -> Text -> CM ()
messageError Text
"x.msg.update: group member attempted invalid message update" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing

    groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
    groupMessageDelete :: GroupInfo
-> GroupMember
-> SharedMsgId
-> Maybe MemberId
-> Maybe MsgScope
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMessageDelete gInfo :: GroupInfo
gInfo@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} m :: GroupMember
m@GroupMember {MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId, memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
senderRole} SharedMsgId
sharedMsgId Maybe MemberId
sndMemberId_ Maybe MsgScope
scope_ RcvMessage {GroupMemberId
msgId :: RcvMessage -> GroupMemberId
msgId :: GroupMemberId
msgId} UTCTime
brokerTs = do
      let msgMemberId :: MemberId
msgMemberId = MemberId -> Maybe MemberId -> MemberId
forall a. a -> Maybe a -> a
fromMaybe MemberId
memberId Maybe MemberId
sndMemberId_
      (Connection -> IO (Either StoreError (CChatItem 'CTGroup)))
-> CM (Either StoreError (CChatItem 'CTGroup))
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO (CChatItem 'CTGroup)
-> IO (Either StoreError (CChatItem 'CTGroup))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO (CChatItem 'CTGroup)
 -> IO (Either StoreError (CChatItem 'CTGroup)))
-> ExceptT StoreError IO (CChatItem 'CTGroup)
-> IO (Either StoreError (CChatItem 'CTGroup))
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> GroupInfo
-> MemberId
-> SharedMsgId
-> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupMemberCIBySharedMsgId Connection
db User
user GroupInfo
gInfo MemberId
msgMemberId SharedMsgId
sharedMsgId) CM (Either StoreError (CChatItem 'CTGroup))
-> (Either StoreError (CChatItem 'CTGroup)
    -> ExceptT
         ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right cci :: CChatItem 'CTGroup
cci@(CChatItem SMsgDirection d
_ ci :: ChatItem 'CTGroup d
ci@ChatItem {CIDirection 'CTGroup d
chatDir :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIDirection c d
chatDir :: CIDirection 'CTGroup d
chatDir}) -> case CIDirection 'CTGroup d
chatDir of
          CIGroupRcv GroupMember
mem -> case Maybe MemberId
sndMemberId_ of
            -- regular deletion
            Maybe MemberId
Nothing
              | MemberId -> GroupMember -> Bool
sameMemberId MemberId
memberId GroupMember
mem Bool -> Bool -> Bool
&& MemberId
msgMemberId MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== MemberId
memberId Bool -> Bool -> Bool
&& ChatItem 'CTGroup d -> UTCTime -> Bool
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> UTCTime -> Bool
rcvItemDeletable ChatItem 'CTGroup d
ci UTCTime
brokerTs ->
                  DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DeliveryJobScope -> Maybe DeliveryJobScope)
-> ExceptT ChatError (ReaderT ChatController IO) DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CChatItem 'CTGroup
-> Maybe GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) DeliveryJobScope
delete CChatItem 'CTGroup
cci Maybe GroupMember
forall a. Maybe a
Nothing
              | Bool
otherwise ->
                  Text -> CM ()
messageError Text
"x.msg.del: member attempted invalid message delete" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
            -- moderation (not limited by time)
            Just MemberId
_
              | MemberId -> GroupMember -> Bool
sameMemberId MemberId
memberId GroupMember
mem Bool -> Bool -> Bool
&& MemberId
msgMemberId MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== MemberId
memberId ->
                  DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DeliveryJobScope -> Maybe DeliveryJobScope)
-> ExceptT ChatError (ReaderT ChatController IO) DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CChatItem 'CTGroup
-> Maybe GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) DeliveryJobScope
delete CChatItem 'CTGroup
cci (GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
m)
              | Bool
otherwise ->
                  GroupMember
-> CChatItem 'CTGroup
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
moderate GroupMember
mem CChatItem 'CTGroup
cci
          CIDirection 'CTGroup d
CIGroupSnd -> GroupMember
-> CChatItem 'CTGroup
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
moderate GroupMember
membership CChatItem 'CTGroup
cci
        Left StoreError
e
          | MemberId
msgMemberId MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== MemberId
memberId ->
              Text -> CM ()
messageError (Text
"x.msg.del: message not found, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreError -> Text
forall a. Show a => a -> Text
tshow StoreError
e) CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
          | GroupMemberRole
senderRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GRModerator -> do
              Text -> CM ()
messageError (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"x.msg.del: message not found, message of another member with insufficient member permissions, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreError -> Text
forall a. Show a => a -> Text
tshow StoreError
e
              Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
forall a. Maybe a
Nothing
          | Bool
otherwise -> case Maybe MsgScope
scope_ of
              Just (MSMember MemberId
scopeMemberId) ->
                (Connection -> ExceptT StoreError IO (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe DeliveryJobScope))
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> (Connection -> ExceptT StoreError IO (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                  IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection
-> GroupInfo
-> GroupMember
-> MemberId
-> SharedMsgId
-> GroupMemberId
-> UTCTime
-> IO ()
createCIModeration Connection
db GroupInfo
gInfo GroupMember
m MemberId
msgMemberId SharedMsgId
sharedMsgId GroupMemberId
msgId UTCTime
brokerTs
                  DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DeliveryJobScope -> Maybe DeliveryJobScope)
-> (GroupMemberId -> DeliveryJobScope)
-> GroupMemberId
-> Maybe DeliveryJobScope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupMemberId -> DeliveryJobScope
DJSMemberSupport (GroupMemberId -> Maybe DeliveryJobScope)
-> ExceptT StoreError IO GroupMemberId
-> ExceptT StoreError IO (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> User
-> GroupInfo
-> GroupMember
-> MemberId
-> ExceptT StoreError IO GroupMemberId
getScopeMemberIdViaMemberId Connection
db User
user GroupInfo
gInfo GroupMember
m MemberId
scopeMemberId
              Maybe MsgScope
Nothing -> do
                (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupInfo
-> GroupMember
-> MemberId
-> SharedMsgId
-> GroupMemberId
-> UTCTime
-> IO ()
createCIModeration Connection
db GroupInfo
gInfo GroupMember
m MemberId
msgMemberId SharedMsgId
sharedMsgId GroupMemberId
msgId UTCTime
brokerTs
                Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just DJSGroup {jobSpec :: DeliveryJobSpec
jobSpec = DJDeliveryJob {includePending :: Bool
includePending = Bool
False}}
      where
        moderate :: GroupMember -> CChatItem 'CTGroup -> CM (Maybe DeliveryJobScope)
        moderate :: GroupMember
-> CChatItem 'CTGroup
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
moderate GroupMember
mem CChatItem 'CTGroup
cci = case Maybe MemberId
sndMemberId_ of
          Just MemberId
sndMemberId
            | MemberId -> GroupMember -> Bool
sameMemberId MemberId
sndMemberId GroupMember
mem -> GroupMember
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
checkRole GroupMember
mem (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ do
                DeliveryJobScope
jobScope <- CChatItem 'CTGroup
-> Maybe GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) DeliveryJobScope
delete CChatItem 'CTGroup
cci (GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
m)
                CChatItem 'CTGroup -> GroupMember -> CM ()
archiveMessageReports CChatItem 'CTGroup
cci GroupMember
m
                Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just DeliveryJobScope
jobScope
            | Bool
otherwise -> Text -> CM ()
messageError Text
"x.msg.del: message of another member with incorrect memberId" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
          Maybe MemberId
_ -> Text -> CM ()
messageError Text
"x.msg.del: message of another member without memberId" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
        checkRole :: GroupMember
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
checkRole GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole} ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
a
          | GroupMemberRole
senderRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GRModerator Bool -> Bool -> Bool
|| GroupMemberRole
senderRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
memberRole =
              Text -> CM ()
messageError Text
"x.msg.del: message of another member with insufficient member permissions" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
          | Bool
otherwise = ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
a
        delete :: CChatItem 'CTGroup -> Maybe GroupMember -> CM DeliveryJobScope
        delete :: CChatItem 'CTGroup
-> Maybe GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) DeliveryJobScope
delete CChatItem 'CTGroup
cci Maybe GroupMember
byGroupMember = do
          Maybe GroupChatScopeInfo
scopeInfo <- (Connection -> ExceptT StoreError IO (Maybe GroupChatScopeInfo))
-> CM (Maybe GroupChatScopeInfo)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe GroupChatScopeInfo))
 -> CM (Maybe GroupChatScopeInfo))
-> (Connection -> ExceptT StoreError IO (Maybe GroupChatScopeInfo))
-> CM (Maybe GroupChatScopeInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> GroupMemberId
-> ExceptT StoreError IO (Maybe GroupChatScopeInfo)
getGroupChatScopeInfoForItem Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo (CChatItem 'CTGroup -> GroupMemberId
forall (c :: ChatType). CChatItem c -> GroupMemberId
cChatItemId CChatItem 'CTGroup
cci)
          [ChatItemDeletion]
deletions <- if SGroupFeature 'GFFullDelete -> GroupMember -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupMember -> GroupInfo -> Bool
groupFeatureMemberAllowed SGroupFeature 'GFFullDelete
SGFFullDelete GroupMember
m GroupInfo
gInfo
            then User
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> [CChatItem 'CTGroup]
-> Maybe GroupMember
-> UTCTime
-> CM [ChatItemDeletion]
deleteGroupCIs User
user GroupInfo
gInfo Maybe GroupChatScopeInfo
scopeInfo [Item [CChatItem 'CTGroup]
CChatItem 'CTGroup
cci] Maybe GroupMember
byGroupMember UTCTime
brokerTs
            else User
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> [CChatItem 'CTGroup]
-> Maybe GroupMember
-> UTCTime
-> CM [ChatItemDeletion]
markGroupCIsDeleted User
user GroupInfo
gInfo Maybe GroupChatScopeInfo
scopeInfo [Item [CChatItem 'CTGroup]
CChatItem 'CTGroup
cci] Maybe GroupMember
byGroupMember UTCTime
brokerTs
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [ChatItemDeletion] -> Bool -> Bool -> ChatEvent
CEvtChatItemsDeleted User
user [ChatItemDeletion]
deletions Bool
False Bool
False
          DeliveryJobScope
-> ExceptT ChatError (ReaderT ChatController IO) DeliveryJobScope
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeliveryJobScope
 -> ExceptT ChatError (ReaderT ChatController IO) DeliveryJobScope)
-> DeliveryJobScope
-> ExceptT ChatError (ReaderT ChatController IO) DeliveryJobScope
forall a b. (a -> b) -> a -> b
$ GroupInfo -> Maybe GroupChatScopeInfo -> DeliveryJobScope
infoToDeliveryScope GroupInfo
gInfo Maybe GroupChatScopeInfo
scopeInfo
        archiveMessageReports :: CChatItem 'CTGroup -> GroupMember -> CM ()
        archiveMessageReports :: CChatItem 'CTGroup -> GroupMember -> CM ()
archiveMessageReports (CChatItem SMsgDirection d
_ ChatItem 'CTGroup d
ci) GroupMember
byMember = do
          [GroupMemberId]
ciIds <- (Connection -> IO [GroupMemberId]) -> CM [GroupMemberId]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [GroupMemberId]) -> CM [GroupMemberId])
-> (Connection -> IO [GroupMemberId]) -> CM [GroupMemberId]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup d
-> GroupMember
-> UTCTime
-> IO [GroupMemberId]
forall (d :: MsgDirection).
Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup d
-> GroupMember
-> UTCTime
-> IO [GroupMemberId]
markMessageReportsDeleted Connection
db User
user GroupInfo
gInfo ChatItem 'CTGroup d
ci GroupMember
byMember UTCTime
brokerTs
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GroupMemberId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GroupMemberId]
ciIds) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> GroupInfo
-> [GroupMemberId]
-> Bool
-> Maybe GroupMember
-> ChatEvent
CEvtGroupChatItemsDeleted User
user GroupInfo
gInfo [GroupMemberId]
ciIds Bool
False (GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
byMember)

    -- TODO remove once XFile is discontinued
    processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> CM ()
    processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> CM ()
processFileInvitation' Contact
ct FileInvitation
fInv' msg :: RcvMessage
msg@RcvMessage {Maybe SharedMsgId
sharedMsgId_ :: RcvMessage -> Maybe SharedMsgId
sharedMsgId_ :: Maybe SharedMsgId
sharedMsgId_} MsgMeta
msgMeta = do
      ChatConfig {Integer
fileChunkSize :: ChatConfig -> Integer
fileChunkSize :: Integer
fileChunkSize} <- (ChatController -> ChatConfig)
-> ExceptT ChatError (ReaderT ChatController IO) ChatConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> ChatConfig
config
      let fInv :: FileInvitation
fInv@FileInvitation {String
fileName :: FileInvitation -> String
fileName :: String
fileName, Integer
fileSize :: FileInvitation -> Integer
fileSize :: Integer
fileSize} = FileInvitation -> FileInvitation
mkValidFileInvitation FileInvitation
fInv'
      Maybe InlineFileMode
inline <- FileInvitation
-> Maybe MsgContent -> Integer -> CM (Maybe InlineFileMode)
receiveInlineMode FileInvitation
fInv Maybe MsgContent
forall a. Maybe a
Nothing Integer
fileChunkSize
      RcvFileTransfer {GroupMemberId
fileId :: RcvFileTransfer -> GroupMemberId
fileId :: GroupMemberId
fileId, Maybe XFTPRcvFile
xftpRcvFile :: RcvFileTransfer -> Maybe XFTPRcvFile
xftpRcvFile :: Maybe XFTPRcvFile
xftpRcvFile} <- (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RcvFileTransfer)
 -> CM RcvFileTransfer)
-> (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> Contact
-> FileInvitation
-> Maybe InlineFileMode
-> Integer
-> ExceptT StoreError IO RcvFileTransfer
createRcvFileTransfer Connection
db GroupMemberId
userId Contact
ct FileInvitation
fInv Maybe InlineFileMode
inline Integer
fileChunkSize
      let fileProtocol :: FileProtocol
fileProtocol = if Maybe XFTPRcvFile -> Bool
forall a. Maybe a -> Bool
isJust Maybe XFTPRcvFile
xftpRcvFile then FileProtocol
FPXFTP else FileProtocol
FPSMP
          ciFile :: Maybe (CIFile 'MDRcv)
ciFile = CIFile 'MDRcv -> Maybe (CIFile 'MDRcv)
forall a. a -> Maybe a
Just (CIFile 'MDRcv -> Maybe (CIFile 'MDRcv))
-> CIFile 'MDRcv -> Maybe (CIFile 'MDRcv)
forall a b. (a -> b) -> a -> b
$ CIFile {GroupMemberId
fileId :: GroupMemberId
fileId :: GroupMemberId
fileId, String
fileName :: String
fileName :: String
fileName, Integer
fileSize :: Integer
fileSize :: Integer
fileSize, fileSource :: Maybe CryptoFile
fileSource = Maybe CryptoFile
forall a. Maybe a
Nothing, fileStatus :: CIFileStatus 'MDRcv
fileStatus = CIFileStatus 'MDRcv
CIFSRcvInvitation, FileProtocol
fileProtocol :: FileProtocol
fileProtocol :: FileProtocol
fileProtocol}
          content :: (CIContent 'MDRcv, (Text, Maybe MarkdownList))
content = CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
ciContentNoParse (CIContent 'MDRcv
 -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)))
-> CIContent 'MDRcv
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
forall a b. (a -> b) -> a -> b
$ MsgContent -> CIContent 'MDRcv
CIRcvMsgContent (MsgContent -> CIContent 'MDRcv) -> MsgContent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ Text -> MsgContent
MCFile Text
""
      (ChatItem 'CTDirect 'MDRcv
ci, ChatInfo 'CTDirect
cInfo) <- User
-> ChatDirection 'CTDirect 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTDirect 'MDRcv, ChatInfo 'CTDirect)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct) RcvMessage
msg Maybe SharedMsgId
sharedMsgId_ UTCTime
brokerTs (CIContent 'MDRcv, (Text, Maybe MarkdownList))
content Maybe (CIFile 'MDRcv)
ciFile Maybe CITimed
forall a. Maybe a
Nothing Bool
False Map Text MsgMention
forall k a. Map k a
M.empty
      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv ChatInfo 'CTDirect
cInfo ChatItem 'CTDirect 'MDRcv
ci]
      where
        brokerTs :: UTCTime
brokerTs = MsgMeta -> UTCTime
metaBrokerTs MsgMeta
msgMeta

    -- TODO remove once XFile is discontinued
    processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> UTCTime -> CM ()
    processGroupFileInvitation' :: GroupInfo
-> GroupMember -> FileInvitation -> RcvMessage -> UTCTime -> CM ()
processGroupFileInvitation' GroupInfo
gInfo GroupMember
m fInv :: FileInvitation
fInv@FileInvitation {String
fileName :: FileInvitation -> String
fileName :: String
fileName, Integer
fileSize :: FileInvitation -> Integer
fileSize :: Integer
fileSize} msg :: RcvMessage
msg@RcvMessage {Maybe SharedMsgId
sharedMsgId_ :: RcvMessage -> Maybe SharedMsgId
sharedMsgId_ :: Maybe SharedMsgId
sharedMsgId_} UTCTime
brokerTs = do
      ChatConfig {Integer
fileChunkSize :: ChatConfig -> Integer
fileChunkSize :: Integer
fileChunkSize} <- (ChatController -> ChatConfig)
-> ExceptT ChatError (ReaderT ChatController IO) ChatConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> ChatConfig
config
      Maybe InlineFileMode
inline <- FileInvitation
-> Maybe MsgContent -> Integer -> CM (Maybe InlineFileMode)
receiveInlineMode FileInvitation
fInv Maybe MsgContent
forall a. Maybe a
Nothing Integer
fileChunkSize
      RcvFileTransfer {GroupMemberId
fileId :: RcvFileTransfer -> GroupMemberId
fileId :: GroupMemberId
fileId, Maybe XFTPRcvFile
xftpRcvFile :: RcvFileTransfer -> Maybe XFTPRcvFile
xftpRcvFile :: Maybe XFTPRcvFile
xftpRcvFile} <- (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RcvFileTransfer)
 -> CM RcvFileTransfer)
-> (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMember
-> FileInvitation
-> Maybe InlineFileMode
-> Integer
-> ExceptT StoreError IO RcvFileTransfer
createRcvGroupFileTransfer Connection
db GroupMemberId
userId GroupMember
m FileInvitation
fInv Maybe InlineFileMode
inline Integer
fileChunkSize
      let fileProtocol :: FileProtocol
fileProtocol = if Maybe XFTPRcvFile -> Bool
forall a. Maybe a -> Bool
isJust Maybe XFTPRcvFile
xftpRcvFile then FileProtocol
FPXFTP else FileProtocol
FPSMP
          ciFile :: Maybe (CIFile 'MDRcv)
ciFile = CIFile 'MDRcv -> Maybe (CIFile 'MDRcv)
forall a. a -> Maybe a
Just (CIFile 'MDRcv -> Maybe (CIFile 'MDRcv))
-> CIFile 'MDRcv -> Maybe (CIFile 'MDRcv)
forall a b. (a -> b) -> a -> b
$ CIFile {GroupMemberId
fileId :: GroupMemberId
fileId :: GroupMemberId
fileId, String
fileName :: String
fileName :: String
fileName, Integer
fileSize :: Integer
fileSize :: Integer
fileSize, fileSource :: Maybe CryptoFile
fileSource = Maybe CryptoFile
forall a. Maybe a
Nothing, fileStatus :: CIFileStatus 'MDRcv
fileStatus = CIFileStatus 'MDRcv
CIFSRcvInvitation, FileProtocol
fileProtocol :: FileProtocol
fileProtocol :: FileProtocol
fileProtocol}
          content :: (CIContent 'MDRcv, (Text, Maybe MarkdownList))
content = CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
ciContentNoParse (CIContent 'MDRcv
 -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)))
-> CIContent 'MDRcv
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
forall a b. (a -> b) -> a -> b
$ MsgContent -> CIContent 'MDRcv
CIRcvMsgContent (MsgContent -> CIContent 'MDRcv) -> MsgContent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ Text -> MsgContent
MCFile Text
""
      (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- User
-> ChatDirection 'CTGroup 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing GroupMember
m) RcvMessage
msg Maybe SharedMsgId
sharedMsgId_ UTCTime
brokerTs (CIContent 'MDRcv, (Text, Maybe MarkdownList))
content Maybe (CIFile 'MDRcv)
ciFile Maybe CITimed
forall a. Maybe a
Nothing Bool
False Map Text MsgMention
forall k a. Map k a
M.empty
      ChatItem 'CTGroup 'MDRcv
ci' <- GroupInfo
-> GroupMember
-> ChatItem 'CTGroup 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv)
blockedMemberCI GroupInfo
gInfo GroupMember
m ChatItem 'CTGroup 'MDRcv
ci
      ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci'

    blockedMemberCI :: GroupInfo -> GroupMember -> ChatItem 'CTGroup 'MDRcv -> CM (ChatItem 'CTGroup 'MDRcv)
    blockedMemberCI :: GroupInfo
-> GroupMember
-> ChatItem 'CTGroup 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv)
blockedMemberCI GroupInfo
gInfo GroupMember
m ChatItem 'CTGroup 'MDRcv
ci
      | GroupMember -> Bool
blockedByAdmin GroupMember
m =
          (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (ChatItem 'CTGroup 'MDRcv))
 -> CM (ChatItem 'CTGroup 'MDRcv))
-> (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup 'MDRcv
-> IO (ChatItem 'CTGroup 'MDRcv)
markGroupCIBlockedByAdmin Connection
db User
user GroupInfo
gInfo ChatItem 'CTGroup 'MDRcv
ci
      | Bool -> Bool
not (GroupMemberSettings -> Bool
showMessages (GroupMemberSettings -> Bool) -> GroupMemberSettings -> Bool
forall a b. (a -> b) -> a -> b
$ GroupMember -> GroupMemberSettings
memberSettings GroupMember
m) =
          (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (ChatItem 'CTGroup 'MDRcv))
 -> CM (ChatItem 'CTGroup 'MDRcv))
-> (Connection -> IO (ChatItem 'CTGroup 'MDRcv))
-> CM (ChatItem 'CTGroup 'MDRcv)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup 'MDRcv
-> IO (ChatItem 'CTGroup 'MDRcv)
markGroupChatItemBlocked Connection
db User
user GroupInfo
gInfo ChatItem 'CTGroup 'MDRcv
ci
      | Bool
otherwise =
          ChatItem 'CTGroup 'MDRcv -> CM (ChatItem 'CTGroup 'MDRcv)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChatItem 'CTGroup 'MDRcv
ci

    receiveInlineMode :: FileInvitation -> Maybe MsgContent -> Integer -> CM (Maybe InlineFileMode)
    receiveInlineMode :: FileInvitation
-> Maybe MsgContent -> Integer -> CM (Maybe InlineFileMode)
receiveInlineMode FileInvitation {Integer
fileSize :: FileInvitation -> Integer
fileSize :: Integer
fileSize, Maybe InlineFileMode
fileInline :: Maybe InlineFileMode
fileInline :: FileInvitation -> Maybe InlineFileMode
fileInline, Maybe FileDescr
fileDescr :: Maybe FileDescr
fileDescr :: FileInvitation -> Maybe FileDescr
fileDescr} Maybe MsgContent
mc_ Integer
chSize = case (Maybe InlineFileMode
fileInline, Maybe FileDescr
fileDescr) of
      (Just InlineFileMode
mode, Maybe FileDescr
Nothing) -> do
        InlineFilesConfig {Integer
receiveChunks :: Integer
receiveChunks :: InlineFilesConfig -> Integer
receiveChunks, Bool
receiveInstant :: Bool
receiveInstant :: InlineFilesConfig -> Bool
receiveInstant} <- (ChatController -> InlineFilesConfig)
-> ExceptT ChatError (ReaderT ChatController IO) InlineFilesConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ChatController -> InlineFilesConfig)
 -> ExceptT ChatError (ReaderT ChatController IO) InlineFilesConfig)
-> (ChatController -> InlineFilesConfig)
-> ExceptT ChatError (ReaderT ChatController IO) InlineFilesConfig
forall a b. (a -> b) -> a -> b
$ ChatConfig -> InlineFilesConfig
inlineFiles (ChatConfig -> InlineFilesConfig)
-> (ChatController -> ChatConfig)
-> ChatController
-> InlineFilesConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config
        Maybe InlineFileMode -> CM (Maybe InlineFileMode)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe InlineFileMode -> CM (Maybe InlineFileMode))
-> Maybe InlineFileMode -> CM (Maybe InlineFileMode)
forall a b. (a -> b) -> a -> b
$ if Integer
fileSize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
receiveChunks Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
chSize then Bool -> Maybe InlineFileMode
inline' Bool
receiveInstant else Maybe InlineFileMode
forall a. Maybe a
Nothing
        where
          inline' :: Bool -> Maybe InlineFileMode
inline' Bool
receiveInstant = if InlineFileMode
mode InlineFileMode -> InlineFileMode -> Bool
forall a. Eq a => a -> a -> Bool
== InlineFileMode
IFMOffer Bool -> Bool -> Bool
|| (Bool
receiveInstant Bool -> Bool -> Bool
&& Bool -> (MsgContent -> Bool) -> Maybe MsgContent -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False MsgContent -> Bool
isVoice Maybe MsgContent
mc_) then Maybe InlineFileMode
fileInline else Maybe InlineFileMode
forall a. Maybe a
Nothing
      (Maybe InlineFileMode, Maybe FileDescr)
_ -> Maybe InlineFileMode -> CM (Maybe InlineFileMode)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe InlineFileMode
forall a. Maybe a
Nothing

    xFileCancel :: Contact -> SharedMsgId -> CM ()
    xFileCancel :: Contact -> SharedMsgId -> CM ()
xFileCancel Contact {GroupMemberId
contactId :: Contact -> GroupMemberId
contactId :: GroupMemberId
contactId} SharedMsgId
sharedMsgId = do
      GroupMemberId
fileId <- (Connection -> ExceptT StoreError IO GroupMemberId)
-> CM GroupMemberId
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMemberId)
 -> CM GroupMemberId)
-> (Connection -> ExceptT StoreError IO GroupMemberId)
-> CM GroupMemberId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO GroupMemberId
getFileIdBySharedMsgId Connection
db GroupMemberId
userId GroupMemberId
contactId SharedMsgId
sharedMsgId
      RcvFileTransfer
ft <- (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> User -> GroupMemberId -> ExceptT StoreError IO RcvFileTransfer
getRcvFileTransfer Connection
db User
user GroupMemberId
fileId)
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RcvFileTransfer -> Bool
rcvFileCompleteOrCancelled RcvFileTransfer
ft) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
        User -> RcvFileTransfer -> CM ()
cancelRcvFileTransfer User
user RcvFileTransfer
ft
        AChatItem
ci <- (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem)
-> (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO AChatItem
getChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
        ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> RcvFileTransfer -> ChatEvent
CEvtRcvFileSndCancelled User
user AChatItem
ci RcvFileTransfer
ft

    xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM ()
    xFileAcptInv :: Contact
-> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM ()
xFileAcptInv Contact
ct SharedMsgId
sharedMsgId Maybe ConnReqInvitation
fileConnReq_ String
fName = do
      GroupMemberId
fileId <- (Connection -> ExceptT StoreError IO GroupMemberId)
-> CM GroupMemberId
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMemberId)
 -> CM GroupMemberId)
-> (Connection -> ExceptT StoreError IO GroupMemberId)
-> CM GroupMemberId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> Contact
-> SharedMsgId
-> ExceptT StoreError IO GroupMemberId
getDirectFileIdBySharedMsgId Connection
db User
user Contact
ct SharedMsgId
sharedMsgId
      (AChatItem SChatType c
_ SMsgDirection d
_ ChatInfo c
_ ChatItem c d
ci) <- (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem)
-> (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO AChatItem
getChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
      ChatItem c d -> CM ()
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> CM ()
assertSMPAcceptNotProhibited ChatItem c d
ci
      ft :: FileTransferMeta
ft@FileTransferMeta {String
fileName :: String
fileName :: FileTransferMeta -> String
fileName, Integer
fileSize :: Integer
fileSize :: FileTransferMeta -> Integer
fileSize, Maybe InlineFileMode
fileInline :: Maybe InlineFileMode
fileInline :: FileTransferMeta -> Maybe InlineFileMode
fileInline, Bool
cancelled :: FileTransferMeta -> Bool
cancelled :: Bool
cancelled} <- (Connection -> ExceptT StoreError IO FileTransferMeta)
-> CM FileTransferMeta
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> User -> GroupMemberId -> ExceptT StoreError IO FileTransferMeta
getFileTransferMeta Connection
db User
user GroupMemberId
fileId)
      -- [async agent commands] no continuation needed, but command should be asynchronous for stability
      if String
fName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fileName
        then Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cancelled (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ case Maybe ConnReqInvitation
fileConnReq_ of
          -- receiving inline
          Maybe ConnReqInvitation
Nothing -> do
            ChatEvent
event <- (Connection -> ExceptT StoreError IO ChatEvent) -> CM ChatEvent
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO ChatEvent) -> CM ChatEvent)
-> (Connection -> ExceptT StoreError IO ChatEvent) -> CM ChatEvent
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
              AChatItem
ci' <- Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> CIFileStatus 'MDSnd
-> ExceptT StoreError IO AChatItem
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> CIFileStatus d
-> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId (CIFileStatus 'MDSnd -> ExceptT StoreError IO AChatItem)
-> CIFileStatus 'MDSnd -> ExceptT StoreError IO AChatItem
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> GroupMemberId -> CIFileStatus 'MDSnd
CIFSSndTransfer GroupMemberId
0 GroupMemberId
1
              SndFileTransfer
sft <- Connection
-> Contact
-> FileTransferMeta
-> ExceptT StoreError IO SndFileTransfer
createSndDirectInlineFT Connection
db Contact
ct FileTransferMeta
ft
              ChatEvent -> ExceptT StoreError IO ChatEvent
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatEvent -> ExceptT StoreError IO ChatEvent)
-> ChatEvent -> ExceptT StoreError IO ChatEvent
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> SndFileTransfer -> ChatEvent
CEvtSndFileStart User
user AChatItem
ci' SndFileTransfer
sft
            ChatEvent -> CM ()
toView ChatEvent
event
            ExceptT ChatError (ReaderT ChatController IO) Bool
-> CM () -> CM () -> CM ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
              (Integer
-> Maybe InlineFileMode
-> ExceptT ChatError (ReaderT ChatController IO) Bool
allowSendInline Integer
fileSize Maybe InlineFileMode
fileInline)
              (User -> Contact -> FileTransferMeta -> SharedMsgId -> CM ()
sendDirectFileInline User
user Contact
ct FileTransferMeta
ft SharedMsgId
sharedMsgId)
              (Text -> CM ()
messageError Text
"x.file.acpt.inv: fileSize is bigger than allowed to send inline")
          Just ConnReqInvitation
_fileConnReq -> Text -> CM ()
messageError Text
"x.file.acpt.inv: receiving file via a separate connection is deprecated"
        else Text -> CM ()
messageError Text
"x.file.acpt.inv: fileName is different from expected"

    assertSMPAcceptNotProhibited :: ChatItem c d -> CM ()
    assertSMPAcceptNotProhibited :: forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> CM ()
assertSMPAcceptNotProhibited ChatItem {file :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIFile d)
file = Just CIFile {GroupMemberId
fileId :: forall (d :: MsgDirection). CIFile d -> GroupMemberId
fileId :: GroupMemberId
fileId, FileProtocol
fileProtocol :: forall (d :: MsgDirection). CIFile d -> FileProtocol
fileProtocol :: FileProtocol
fileProtocol}, CIContent d
content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content :: CIContent d
content}
      | FileProtocol
fileProtocol FileProtocol -> FileProtocol -> Bool
forall a. Eq a => a -> a -> Bool
== FileProtocol
FPXFTP Bool -> Bool -> Bool
&& Bool -> Bool
not (CIContent d -> Bool
forall (d :: MsgDirection). CIContent d -> Bool
imageOrVoice CIContent d
content) = ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> ChatErrorType
CEFallbackToSMPProhibited GroupMemberId
fileId
      | Bool
otherwise = () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        imageOrVoice :: CIContent d -> Bool
        imageOrVoice :: forall (d :: MsgDirection). CIContent d -> Bool
imageOrVoice (CISndMsgContent (MCImage Text
_ ImageData
_)) = Bool
True
        imageOrVoice (CISndMsgContent (MCVoice Text
_ Int
_)) = Bool
True
        imageOrVoice CIContent d
_ = Bool
False
    assertSMPAcceptNotProhibited ChatItem c d
_ = () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    checkSndInlineFTComplete :: Connection -> AgentMsgId -> CM ()
    checkSndInlineFTComplete :: Connection -> GroupMemberId -> CM ()
checkSndInlineFTComplete Connection
conn GroupMemberId
agentMsgId = do
      Maybe SndFileTransfer
sft_ <- (Connection -> IO (Maybe SndFileTransfer))
-> CM (Maybe SndFileTransfer)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (Maybe SndFileTransfer))
 -> CM (Maybe SndFileTransfer))
-> (Connection -> IO (Maybe SndFileTransfer))
-> CM (Maybe SndFileTransfer)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> Connection
-> GroupMemberId
-> IO (Maybe SndFileTransfer)
getSndFTViaMsgDelivery Connection
db User
user Connection
conn GroupMemberId
agentMsgId
      Maybe SndFileTransfer -> (SndFileTransfer -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe SndFileTransfer
sft_ ((SndFileTransfer -> CM ()) -> CM ())
-> (SndFileTransfer -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \sft :: SndFileTransfer
sft@SndFileTransfer {GroupMemberId
fileId :: GroupMemberId
fileId :: SndFileTransfer -> GroupMemberId
fileId} -> do
        ci :: AChatItem
ci@(AChatItem SChatType c
_ SMsgDirection d
_ ChatInfo c
_ ChatItem {Maybe (CIFile d)
file :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIFile d)
file :: Maybe (CIFile d)
file}) <- (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem)
-> (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
          IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> SndFileTransfer -> FileStatus -> IO ()
updateSndFileStatus Connection
db SndFileTransfer
sft FileStatus
FSComplete
          Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> CIFileStatus 'MDSnd
-> ExceptT StoreError IO AChatItem
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> CIFileStatus d
-> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId CIFileStatus 'MDSnd
CIFSSndComplete
        case Maybe (CIFile d)
file of
          Just CIFile {fileProtocol :: forall (d :: MsgDirection). CIFile d -> FileProtocol
fileProtocol = FileProtocol
FPXFTP} -> do
            FileTransferMeta
ft <- (Connection -> ExceptT StoreError IO FileTransferMeta)
-> CM FileTransferMeta
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO FileTransferMeta)
 -> CM FileTransferMeta)
-> (Connection -> ExceptT StoreError IO FileTransferMeta)
-> CM FileTransferMeta
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User -> GroupMemberId -> ExceptT StoreError IO FileTransferMeta
getFileTransferMeta Connection
db User
user GroupMemberId
fileId
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> FileTransferMeta -> ChatEvent
CEvtSndFileCompleteXFTP User
user AChatItem
ci FileTransferMeta
ft
          Maybe (CIFile d)
_ -> ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> SndFileTransfer -> ChatEvent
CEvtSndFileComplete User
user AChatItem
ci SndFileTransfer
sft

    allowSendInline :: Integer -> Maybe InlineFileMode -> CM Bool
    allowSendInline :: Integer
-> Maybe InlineFileMode
-> ExceptT ChatError (ReaderT ChatController IO) Bool
allowSendInline Integer
fileSize = \case
      Just InlineFileMode
IFMOffer -> do
        ChatConfig {Integer
fileChunkSize :: ChatConfig -> Integer
fileChunkSize :: Integer
fileChunkSize, InlineFilesConfig
inlineFiles :: ChatConfig -> InlineFilesConfig
inlineFiles :: InlineFilesConfig
inlineFiles} <- (ChatController -> ChatConfig)
-> ExceptT ChatError (ReaderT ChatController IO) ChatConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> ChatConfig
config
        Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a b. (a -> b) -> a -> b
$ Integer
fileSize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
fileChunkSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* InlineFilesConfig -> Integer
offerChunks InlineFilesConfig
inlineFiles
      Maybe InlineFileMode
_ -> Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

    bFileChunk :: Contact -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
    bFileChunk :: Contact -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
bFileChunk Contact
ct SharedMsgId
sharedMsgId FileChunk
chunk MsgMeta
meta = do
      RcvFileTransfer
ft <- (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RcvFileTransfer)
 -> CM RcvFileTransfer)
-> (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> Contact
-> SharedMsgId
-> ExceptT StoreError IO GroupMemberId
getDirectFileIdBySharedMsgId Connection
db User
user Contact
ct SharedMsgId
sharedMsgId ExceptT StoreError IO GroupMemberId
-> (GroupMemberId -> ExceptT StoreError IO RcvFileTransfer)
-> ExceptT StoreError IO RcvFileTransfer
forall a b.
ExceptT StoreError IO a
-> (a -> ExceptT StoreError IO b) -> ExceptT StoreError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection
-> User -> GroupMemberId -> ExceptT StoreError IO RcvFileTransfer
getRcvFileTransfer Connection
db User
user
      RcvFileTransfer -> FileChunk -> MsgMeta -> CM ()
receiveInlineChunk RcvFileTransfer
ft FileChunk
chunk MsgMeta
meta

    bFileChunkGroup :: GroupInfo -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
    bFileChunkGroup :: GroupInfo -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
bFileChunkGroup GroupInfo {GroupMemberId
groupId :: GroupInfo -> GroupMemberId
groupId :: GroupMemberId
groupId} SharedMsgId
sharedMsgId FileChunk
chunk MsgMeta
meta = do
      RcvFileTransfer
ft <- (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RcvFileTransfer)
 -> CM RcvFileTransfer)
-> (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO GroupMemberId
getGroupFileIdBySharedMsgId Connection
db GroupMemberId
userId GroupMemberId
groupId SharedMsgId
sharedMsgId ExceptT StoreError IO GroupMemberId
-> (GroupMemberId -> ExceptT StoreError IO RcvFileTransfer)
-> ExceptT StoreError IO RcvFileTransfer
forall a b.
ExceptT StoreError IO a
-> (a -> ExceptT StoreError IO b) -> ExceptT StoreError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection
-> User -> GroupMemberId -> ExceptT StoreError IO RcvFileTransfer
getRcvFileTransfer Connection
db User
user
      RcvFileTransfer -> FileChunk -> MsgMeta -> CM ()
receiveInlineChunk RcvFileTransfer
ft FileChunk
chunk MsgMeta
meta

    receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> CM ()
    receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> CM ()
receiveInlineChunk RcvFileTransfer {GroupMemberId
fileId :: RcvFileTransfer -> GroupMemberId
fileId :: GroupMemberId
fileId, fileStatus :: RcvFileTransfer -> RcvFileStatus
fileStatus = RcvFileStatus
RFSNew} FileChunk {Integer
chunkNo :: FileChunk -> Integer
chunkNo :: Integer
chunkNo} MsgMeta
_
      | Integer
chunkNo Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 = ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> ChatErrorType
CEInlineFileProhibited GroupMemberId
fileId
      | Bool
otherwise = () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    receiveInlineChunk ft :: RcvFileTransfer
ft@RcvFileTransfer {GroupMemberId
fileId :: RcvFileTransfer -> GroupMemberId
fileId :: GroupMemberId
fileId} FileChunk
chunk MsgMeta
meta = do
      case FileChunk
chunk of
        FileChunk {Integer
chunkNo :: FileChunk -> Integer
chunkNo :: Integer
chunkNo} -> Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
chunkNo Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupMemberId -> CM ()
startReceivingFile User
user GroupMemberId
fileId
        FileChunk
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      RcvFileTransfer
-> Maybe Connection -> MsgMeta -> FileChunk -> CM ()
receiveFileChunk RcvFileTransfer
ft Maybe Connection
forall a. Maybe a
Nothing MsgMeta
meta FileChunk
chunk

    xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> CM (Maybe DeliveryJobScope)
    xFileCancelGroup :: GroupInfo
-> GroupMember
-> SharedMsgId
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xFileCancelGroup g :: GroupInfo
g@GroupInfo {GroupMemberId
groupId :: GroupInfo -> GroupMemberId
groupId :: GroupMemberId
groupId} GroupMember {MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId} SharedMsgId
sharedMsgId = do
      (GroupMemberId
fileId, AChatItem
aci) <- (Connection -> ExceptT StoreError IO (GroupMemberId, AChatItem))
-> CM (GroupMemberId, AChatItem)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupMemberId, AChatItem))
 -> CM (GroupMemberId, AChatItem))
-> (Connection -> ExceptT StoreError IO (GroupMemberId, AChatItem))
-> CM (GroupMemberId, AChatItem)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
        GroupMemberId
fileId <- Connection
-> GroupMemberId
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO GroupMemberId
getGroupFileIdBySharedMsgId Connection
db GroupMemberId
userId GroupMemberId
groupId SharedMsgId
sharedMsgId
        AChatItem
aci <- Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO AChatItem
getChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
        (GroupMemberId, AChatItem)
-> ExceptT StoreError IO (GroupMemberId, AChatItem)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMemberId
fileId, AChatItem
aci)
      case AChatItem
aci of
        AChatItem SChatType c
SCTGroup SMsgDirection d
SMDRcv (GroupChat GroupInfo
_g Maybe GroupChatScopeInfo
scopeInfo) ChatItem {chatDir :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIDirection c d
chatDir = CIGroupRcv GroupMember
m} -> do
          if MemberId -> GroupMember -> Bool
sameMemberId MemberId
memberId GroupMember
m
            then do
              RcvFileTransfer
ft <- (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RcvFileTransfer)
 -> CM RcvFileTransfer)
-> (Connection -> ExceptT StoreError IO RcvFileTransfer)
-> CM RcvFileTransfer
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User -> GroupMemberId -> ExceptT StoreError IO RcvFileTransfer
getRcvFileTransfer Connection
db User
user GroupMemberId
fileId
              Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RcvFileTransfer -> Bool
rcvFileCompleteOrCancelled RcvFileTransfer
ft) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
                User -> RcvFileTransfer -> CM ()
cancelRcvFileTransfer User
user RcvFileTransfer
ft
                ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> RcvFileTransfer -> ChatEvent
CEvtRcvFileSndCancelled User
user AChatItem
aci RcvFileTransfer
ft
              Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DeliveryJobScope -> Maybe DeliveryJobScope)
-> DeliveryJobScope -> Maybe DeliveryJobScope
forall a b. (a -> b) -> a -> b
$ GroupInfo -> Maybe GroupChatScopeInfo -> DeliveryJobScope
infoToDeliveryScope GroupInfo
g Maybe GroupChatScopeInfo
scopeInfo
            else
              -- shouldn't happen now that query includes group member id
              Text -> CM ()
messageError Text
"x.file.cancel: group member attempted to cancel file of another member" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
        AChatItem
_ -> Text -> CM ()
messageError Text
"x.file.cancel: group member attempted invalid file cancel" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing

    xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM ()
    xFileAcptInvGroup :: GroupInfo
-> GroupMember
-> SharedMsgId
-> Maybe ConnReqInvitation
-> String
-> CM ()
xFileAcptInvGroup GroupInfo {GroupMemberId
groupId :: GroupInfo -> GroupMemberId
groupId :: GroupMemberId
groupId} m :: GroupMember
m@GroupMember {Maybe Connection
activeConn :: GroupMember -> Maybe Connection
activeConn :: Maybe Connection
activeConn} SharedMsgId
sharedMsgId Maybe ConnReqInvitation
fileConnReq_ String
fName = do
      GroupMemberId
fileId <- (Connection -> ExceptT StoreError IO GroupMemberId)
-> CM GroupMemberId
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMemberId)
 -> CM GroupMemberId)
-> (Connection -> ExceptT StoreError IO GroupMemberId)
-> CM GroupMemberId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> SharedMsgId
-> ExceptT StoreError IO GroupMemberId
getGroupFileIdBySharedMsgId Connection
db GroupMemberId
userId GroupMemberId
groupId SharedMsgId
sharedMsgId
      (AChatItem SChatType c
_ SMsgDirection d
_ ChatInfo c
_ ChatItem c d
ci) <- (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem)
-> (Connection -> ExceptT StoreError IO AChatItem) -> CM AChatItem
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO AChatItem
getChatItemByFileId Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId
      ChatItem c d -> CM ()
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> CM ()
assertSMPAcceptNotProhibited ChatItem c d
ci
      -- TODO check that it's not already accepted
      ft :: FileTransferMeta
ft@FileTransferMeta {String
fileName :: FileTransferMeta -> String
fileName :: String
fileName, Integer
fileSize :: FileTransferMeta -> Integer
fileSize :: Integer
fileSize, Maybe InlineFileMode
fileInline :: FileTransferMeta -> Maybe InlineFileMode
fileInline :: Maybe InlineFileMode
fileInline, Bool
cancelled :: FileTransferMeta -> Bool
cancelled :: Bool
cancelled} <- (Connection -> ExceptT StoreError IO FileTransferMeta)
-> CM FileTransferMeta
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> User -> GroupMemberId -> ExceptT StoreError IO FileTransferMeta
getFileTransferMeta Connection
db User
user GroupMemberId
fileId)
      if String
fName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fileName
        then Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cancelled (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ case (Maybe ConnReqInvitation
fileConnReq_, Maybe Connection
activeConn) of
          (Maybe ConnReqInvitation
Nothing, Just Connection
conn) -> do
            -- receiving inline
            ChatEvent
event <- (Connection -> ExceptT StoreError IO ChatEvent) -> CM ChatEvent
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO ChatEvent) -> CM ChatEvent)
-> (Connection -> ExceptT StoreError IO ChatEvent) -> CM ChatEvent
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
              AChatItem
ci' <- Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> CIFileStatus 'MDSnd
-> ExceptT StoreError IO AChatItem
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> CIFileStatus d
-> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus Connection
db VersionRangeChat
vr User
user GroupMemberId
fileId (CIFileStatus 'MDSnd -> ExceptT StoreError IO AChatItem)
-> CIFileStatus 'MDSnd -> ExceptT StoreError IO AChatItem
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> GroupMemberId -> CIFileStatus 'MDSnd
CIFSSndTransfer GroupMemberId
0 GroupMemberId
1
              SndFileTransfer
sft <- IO SndFileTransfer -> ExceptT StoreError IO SndFileTransfer
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SndFileTransfer -> ExceptT StoreError IO SndFileTransfer)
-> IO SndFileTransfer -> ExceptT StoreError IO SndFileTransfer
forall a b. (a -> b) -> a -> b
$ Connection
-> GroupMember
-> Connection
-> FileTransferMeta
-> IO SndFileTransfer
createSndGroupInlineFT Connection
db GroupMember
m Connection
conn FileTransferMeta
ft
              ChatEvent -> ExceptT StoreError IO ChatEvent
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatEvent -> ExceptT StoreError IO ChatEvent)
-> ChatEvent -> ExceptT StoreError IO ChatEvent
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> SndFileTransfer -> ChatEvent
CEvtSndFileStart User
user AChatItem
ci' SndFileTransfer
sft
            ChatEvent -> CM ()
toView ChatEvent
event
            ExceptT ChatError (ReaderT ChatController IO) Bool
-> CM () -> CM () -> CM ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
              (Integer
-> Maybe InlineFileMode
-> ExceptT ChatError (ReaderT ChatController IO) Bool
allowSendInline Integer
fileSize Maybe InlineFileMode
fileInline)
              (GroupMember
-> Connection -> FileTransferMeta -> SharedMsgId -> CM ()
sendMemberFileInline GroupMember
m Connection
conn FileTransferMeta
ft SharedMsgId
sharedMsgId)
              (Text -> CM ()
messageError Text
"x.file.acpt.inv: fileSize is bigger than allowed to send inline")
          (Just ConnReqInvitation
_fileConnReq, Maybe Connection
_) -> Text -> CM ()
messageError Text
"x.file.acpt.inv: receiving file via a separate connection is deprecated"
          (Maybe ConnReqInvitation, Maybe Connection)
_ -> Text -> CM ()
messageError Text
"x.file.acpt.inv: member connection is not active"
        else Text -> CM ()
messageError Text
"x.file.acpt.inv: fileName is different from expected"

    groupMsgToView :: forall d. MsgDirectionI d => ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
    groupMsgToView :: forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup d
ci = do
      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [SChatType 'CTGroup
-> SMsgDirection d
-> ChatInfo 'CTGroup
-> ChatItem 'CTGroup d
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTGroup
SCTGroup (forall (d :: MsgDirection). MsgDirectionI d => SMsgDirection d
msgDirection @d) ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup d
ci]

    processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> CM ()
    processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> CM ()
processGroupInvitation Contact
ct GroupInvitation
inv RcvMessage
msg MsgMeta
msgMeta = do
      let Contact {localDisplayName :: Contact -> Text
localDisplayName = Text
c, Maybe Connection
activeConn :: Maybe Connection
activeConn :: Contact -> Maybe Connection
activeConn} = Contact
ct
          GroupInvitation {fromMember :: GroupInvitation -> MemberIdRole
fromMember = (MemberIdRole MemberId
fromMemId GroupMemberRole
fromRole), invitedMember :: GroupInvitation -> MemberIdRole
invitedMember = (MemberIdRole MemberId
memId GroupMemberRole
memRole), ConnReqInvitation
connRequest :: GroupInvitation -> ConnReqInvitation
connRequest :: ConnReqInvitation
connRequest, Maybe GroupLinkId
groupLinkId :: GroupInvitation -> Maybe GroupLinkId
groupLinkId :: Maybe GroupLinkId
groupLinkId} = GroupInvitation
inv
      Maybe Connection -> (Connection -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Connection
activeConn ((Connection -> CM ()) -> CM ()) -> (Connection -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection {GroupMemberId
connId :: Connection -> GroupMemberId
connId :: GroupMemberId
connId, Version ChatVersion
connChatVersion :: Connection -> Version ChatVersion
connChatVersion :: Version ChatVersion
connChatVersion, VersionRangeChat
peerChatVRange :: Connection -> VersionRangeChat
peerChatVRange :: VersionRangeChat
peerChatVRange, Maybe GroupMemberId
customUserProfileId :: Connection -> Maybe GroupMemberId
customUserProfileId :: Maybe GroupMemberId
customUserProfileId, groupLinkId :: Connection -> Maybe GroupLinkId
groupLinkId = Maybe GroupLinkId
groupLinkId'} -> do
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupMemberRole
fromRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GRAdmin Bool -> Bool -> Bool
|| GroupMemberRole
fromRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
memRole) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (Text -> ChatErrorType
CEGroupContactRole Text
c)
        Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MemberId
fromMemId MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== MemberId
memId) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError ChatErrorType
CEGroupDuplicateMemberId
        -- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
        (gInfo :: GroupInfo
gInfo@GroupInfo {GroupMemberId
groupId :: GroupInfo -> GroupMemberId
groupId :: GroupMemberId
groupId, Text
localDisplayName :: Text
localDisplayName :: GroupInfo -> Text
localDisplayName, GroupProfile
groupProfile :: GroupInfo -> GroupProfile
groupProfile :: GroupProfile
groupProfile, GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership}, GroupMemberId
hostId) <- (Connection -> ExceptT StoreError IO (GroupInfo, GroupMemberId))
-> CM (GroupInfo, GroupMemberId)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupInfo, GroupMemberId))
 -> CM (GroupInfo, GroupMemberId))
-> (Connection -> ExceptT StoreError IO (GroupInfo, GroupMemberId))
-> CM (GroupInfo, GroupMemberId)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> Contact
-> GroupInvitation
-> Maybe GroupMemberId
-> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation Connection
db VersionRangeChat
vr User
user Contact
ct GroupInvitation
inv Maybe GroupMemberId
customUserProfileId
        CM AChatItem -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM AChatItem -> CM ()) -> CM AChatItem -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> ChatDirection 'CTGroup 'MDSnd
-> Bool
-> CIContent 'MDSnd
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> CM AChatItem
createChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDSnd
CDGroupSnd GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing) Bool
False CIContent 'MDSnd
CIChatBanner Maybe SharedMsgId
forall a. Maybe a
Nothing (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
epochStart)
        let GroupMember {GroupMemberId
groupMemberId :: GroupMember -> GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId, memberId :: GroupMember -> MemberId
memberId = MemberId
membershipMemId} = GroupMember
membership
        if Maybe GroupLinkId -> Maybe GroupLinkId -> Bool
sameGroupLinkId Maybe GroupLinkId
groupLinkId Maybe GroupLinkId
groupLinkId'
          then do
            SubscriptionMode
subMode <- (ChatController -> TVar SubscriptionMode) -> CM SubscriptionMode
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar SubscriptionMode
subscriptionMode
            ByteString
dm <- ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall (e :: MsgEncoding).
MsgEncodingI e =>
ChatMsgEvent e
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
encodeConnInfo (ChatMsgEvent 'Json
 -> ExceptT ChatError (ReaderT ChatController IO) ByteString)
-> ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall a b. (a -> b) -> a -> b
$ MemberId -> ChatMsgEvent 'Json
XGrpAcpt MemberId
membershipMemId
            (GroupMemberId, ByteString)
connIds <- User
-> Bool
-> ConnReqInvitation
-> ByteString
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
forall (c :: ConnectionMode).
User
-> Bool
-> ConnectionRequestUri c
-> ByteString
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
joinAgentConnectionAsync User
user Bool
True ConnReqInvitation
connRequest ByteString
dm SubscriptionMode
subMode
            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
              Connection -> GroupMemberId -> GroupMemberId -> IO ()
setViaGroupLinkUri Connection
db GroupMemberId
groupId GroupMemberId
connId
              Connection
-> User
-> GroupMemberId
-> (GroupMemberId, ByteString)
-> Version ChatVersion
-> VersionRangeChat
-> SubscriptionMode
-> IO ()
createMemberConnectionAsync Connection
db User
user GroupMemberId
hostId (GroupMemberId, ByteString)
connIds Version ChatVersion
connChatVersion VersionRangeChat
peerChatVRange SubscriptionMode
subMode
              Connection
-> GroupMemberId -> GroupMemberId -> GroupMemberStatus -> IO ()
updateGroupMemberStatusById Connection
db GroupMemberId
userId GroupMemberId
hostId GroupMemberStatus
GSMemAccepted
              Connection
-> GroupMemberId -> GroupMember -> GroupMemberStatus -> IO ()
updateGroupMemberStatus Connection
db GroupMemberId
userId GroupMember
membership GroupMemberStatus
GSMemAccepted
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> Maybe Contact -> ChatEvent
CEvtUserAcceptedGroupSent User
user GroupInfo
gInfo {membership = membership {memberStatus = GSMemAccepted}} (Contact -> Maybe Contact
forall a. a -> Maybe a
Just Contact
ct)
          else do
            let content :: CIContent 'MDRcv
content = CIGroupInvitation -> GroupMemberRole -> CIContent 'MDRcv
CIRcvGroupInvitation (CIGroupInvitation {GroupMemberId
groupId :: GroupMemberId
groupId :: GroupMemberId
groupId, GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId, Text
localDisplayName :: Text
localDisplayName :: Text
localDisplayName, GroupProfile
groupProfile :: GroupProfile
groupProfile :: GroupProfile
groupProfile, status :: CIGroupInvitationStatus
status = CIGroupInvitationStatus
CIGISPending}) GroupMemberRole
memRole
            (ChatItem 'CTDirect 'MDRcv
ci, ChatInfo 'CTDirect
cInfo) <- User
-> ChatDirection 'CTDirect 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem 'CTDirect 'MDRcv, ChatInfo 'CTDirect)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct) RcvMessage
msg UTCTime
brokerTs CIContent 'MDRcv
content
            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> GroupMemberId -> IO ()
setGroupInvitationChatItemId Connection
db User
user GroupMemberId
groupId (ChatItem 'CTDirect 'MDRcv -> GroupMemberId
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> GroupMemberId
chatItemId' ChatItem 'CTDirect 'MDRcv
ci)
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv ChatInfo 'CTDirect
cInfo ChatItem 'CTDirect 'MDRcv
ci]
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ CEvtReceivedGroupInvitation {User
user :: User
user :: User
user, groupInfo :: GroupInfo
groupInfo = GroupInfo
gInfo, contact :: Contact
contact = Contact
ct, fromMemberRole :: GroupMemberRole
fromMemberRole = GroupMemberRole
fromRole, memberRole :: GroupMemberRole
memberRole = GroupMemberRole
memRole}
      where
        brokerTs :: UTCTime
brokerTs = MsgMeta -> UTCTime
metaBrokerTs MsgMeta
msgMeta
        sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool
        sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool
sameGroupLinkId (Just GroupLinkId
gli) (Just GroupLinkId
gli') = GroupLinkId
gli GroupLinkId -> GroupLinkId -> Bool
forall a. Eq a => a -> a -> Bool
== GroupLinkId
gli'
        sameGroupLinkId Maybe GroupLinkId
_ Maybe GroupLinkId
_ = Bool
False

    checkIntegrityCreateItem :: forall c. ChatTypeI c => ChatDirection c 'MDRcv -> MsgMeta -> CM ()
    checkIntegrityCreateItem :: forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv -> MsgMeta -> CM ()
checkIntegrityCreateItem ChatDirection c 'MDRcv
cd MsgMeta {MsgIntegrity
integrity :: MsgMeta -> MsgIntegrity
integrity :: MsgIntegrity
integrity, broker :: MsgMeta -> (ByteString, UTCTime)
broker = (ByteString
_, UTCTime
brokerTs)} = case MsgIntegrity
integrity of
      MsgIntegrity
MsgOk -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      MsgError MsgErrorType
e -> User
-> ChatDirection c 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user ChatDirection c 'MDRcv
cd (MsgErrorType -> CIContent 'MDRcv
CIRcvIntegrityError MsgErrorType
e) (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
brokerTs)

    xInfo :: Contact -> Profile -> CM ()
    xInfo :: Contact -> Profile -> CM ()
xInfo Contact
c Profile
p' = CM Contact -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM Contact -> CM ()) -> CM Contact -> CM ()
forall a b. (a -> b) -> a -> b
$ Contact -> Profile -> Bool -> CM Contact
processContactProfileUpdate Contact
c Profile
p' Bool
True

    xDirectDel :: Contact -> RcvMessage -> MsgMeta -> CM ()
    xDirectDel :: Contact -> RcvMessage -> MsgMeta -> CM ()
xDirectDel Contact
c RcvMessage
msg MsgMeta
msgMeta =
      if Contact -> Bool
directOrUsed Contact
c
        then do
          Contact
ct' <- (Connection -> IO Contact) -> CM Contact
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO Contact) -> CM Contact)
-> (Connection -> IO Contact) -> CM Contact
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Contact -> ContactStatus -> IO Contact
updateContactStatus Connection
db User
user Contact
c ContactStatus
CSDeleted
          [Connection]
contactConns <- (Connection -> IO [Connection]) -> CM [Connection]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [Connection]) -> CM [Connection])
-> (Connection -> IO [Connection]) -> CM [Connection]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat -> GroupMemberId -> Contact -> IO [Connection]
getContactConnections Connection
db VersionRangeChat
vr GroupMemberId
userId Contact
ct'
          [ByteString] -> CM ()
deleteAgentConnectionsAsync ([ByteString] -> CM ()) -> [ByteString] -> CM ()
forall a b. (a -> b) -> a -> b
$ (Connection -> ByteString) -> [Connection] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Connection -> ByteString
aConnId [Connection]
contactConns
          [Connection] -> (Connection -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Connection]
contactConns ((Connection -> CM ()) -> CM ()) -> (Connection -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> Connection -> ConnStatus -> IO ()
updateConnectionStatus Connection
db Connection
conn ConnStatus
ConnDeleted
          Maybe Connection
activeConn' <- Maybe Connection
-> (Connection
    -> ExceptT ChatError (ReaderT ChatController IO) Connection)
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Connection)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Contact -> Maybe Connection
contactConn Contact
ct') ((Connection
  -> ExceptT ChatError (ReaderT ChatController IO) Connection)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe Connection))
-> (Connection
    -> ExceptT ChatError (ReaderT ChatController IO) Connection)
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Connection)
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection
-> ExceptT ChatError (ReaderT ChatController IO) Connection
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
conn {connStatus = ConnDeleted}
          let ct'' :: Contact
ct'' = Contact
ct' {activeConn = activeConn'} :: Contact
          (ChatItem 'CTDirect 'MDRcv
ci, ChatInfo 'CTDirect
cInfo) <- User
-> ChatDirection 'CTDirect 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem 'CTDirect 'MDRcv, ChatInfo 'CTDirect)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct'') RcvMessage
msg UTCTime
brokerTs (RcvDirectEvent -> CIContent 'MDRcv
CIRcvDirectEvent RcvDirectEvent
RDEContactDeleted)
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv ChatInfo 'CTDirect
cInfo ChatItem 'CTDirect 'MDRcv
ci]
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> ChatEvent
CEvtContactDeletedByContact User
user Contact
ct''
        else do
          [Connection]
contactConns <- (Connection -> IO [Connection]) -> CM [Connection]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [Connection]) -> CM [Connection])
-> (Connection -> IO [Connection]) -> CM [Connection]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat -> GroupMemberId -> Contact -> IO [Connection]
getContactConnections Connection
db VersionRangeChat
vr GroupMemberId
userId Contact
c
          [ByteString] -> CM ()
deleteAgentConnectionsAsync ([ByteString] -> CM ()) -> [ByteString] -> CM ()
forall a b. (a -> b) -> a -> b
$ (Connection -> ByteString) -> [Connection] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Connection -> ByteString
aConnId [Connection]
contactConns
          (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO ()) -> CM ())
-> (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Contact -> ExceptT StoreError IO ()
deleteContact Connection
db User
user Contact
c
      where
        brokerTs :: UTCTime
brokerTs = MsgMeta -> UTCTime
metaBrokerTs MsgMeta
msgMeta

    processContactProfileUpdate :: Contact -> Profile -> Bool -> CM Contact
    processContactProfileUpdate :: Contact -> Profile -> Bool -> CM Contact
processContactProfileUpdate c :: Contact
c@Contact {profile :: Contact -> LocalProfile
profile = LocalProfile
lp} Profile
p' Bool
createItems
      | Profile
p Profile -> Profile -> Bool
forall a. Eq a => a -> a -> Bool
/= Profile
p' = do
          Contact
c' <- (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO Contact) -> CM Contact)
-> (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a b. (a -> b) -> a -> b
$ \Connection
db ->
            if Maybe Int
userTTL Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
rcvTTL
              then Connection
-> User -> Contact -> Profile -> ExceptT StoreError IO Contact
updateContactProfile Connection
db User
user Contact
c Profile
p'
              else do
                Contact
c' <- IO Contact -> ExceptT StoreError IO Contact
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Contact -> ExceptT StoreError IO Contact)
-> IO Contact -> ExceptT StoreError IO Contact
forall a b. (a -> b) -> a -> b
$ Connection -> User -> Contact -> Preferences -> IO Contact
updateContactUserPreferences Connection
db User
user Contact
c Preferences
ctUserPrefs'
                Connection
-> User -> Contact -> Profile -> ExceptT StoreError IO Contact
updateContactProfile Connection
db User
user Contact
c' Profile
p'
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Contact -> Bool
directOrUsed Contact
c' Bool -> Bool -> Bool
&& Bool
createItems) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
            Contact -> CM ()
createProfileUpdatedItem Contact
c'
            ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> Contact -> ReaderT ChatController IO ()
createRcvFeatureItems User
user Contact
c Contact
c'
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> Contact -> ChatEvent
CEvtContactUpdated User
user Contact
c Contact
c'
          Contact -> CM Contact
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Contact
c'
      | Bool
otherwise =
          Contact -> CM Contact
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Contact
c
      where
        p :: Profile
p = LocalProfile -> Profile
fromLocalProfile LocalProfile
lp
        Contact {userPreferences :: Contact -> Preferences
userPreferences = ctUserPrefs :: Preferences
ctUserPrefs@Preferences {timedMessages :: Preferences -> Maybe TimedMessagesPreference
timedMessages = Maybe TimedMessagesPreference
ctUserTMPref}} = Contact
c
        userTTL :: Maybe Int
userTTL = FeaturePreference 'CFTimedMessages -> Maybe Int
forall (f :: ChatFeature).
FeatureI f =>
FeaturePreference f -> Maybe Int
prefParam (FeaturePreference 'CFTimedMessages -> Maybe Int)
-> FeaturePreference 'CFTimedMessages -> Maybe Int
forall a b. (a -> b) -> a -> b
$ SChatFeature 'CFTimedMessages
-> Preferences -> FeaturePreference 'CFTimedMessages
forall p (f :: ChatFeature).
PreferenceI p =>
SChatFeature f -> p -> FeaturePreference f
forall (f :: ChatFeature).
SChatFeature f -> Preferences -> FeaturePreference f
getPreference SChatFeature 'CFTimedMessages
SCFTimedMessages Preferences
ctUserPrefs
        Profile {preferences :: Profile -> Maybe Preferences
preferences = Maybe Preferences
rcvPrefs_} = Profile
p'
        rcvTTL :: Maybe Int
rcvTTL = FeaturePreference 'CFTimedMessages -> Maybe Int
forall (f :: ChatFeature).
FeatureI f =>
FeaturePreference f -> Maybe Int
prefParam (FeaturePreference 'CFTimedMessages -> Maybe Int)
-> FeaturePreference 'CFTimedMessages -> Maybe Int
forall a b. (a -> b) -> a -> b
$ SChatFeature 'CFTimedMessages
-> Maybe Preferences -> FeaturePreference 'CFTimedMessages
forall p (f :: ChatFeature).
PreferenceI p =>
SChatFeature f -> p -> FeaturePreference f
forall (f :: ChatFeature).
SChatFeature f -> Maybe Preferences -> FeaturePreference f
getPreference SChatFeature 'CFTimedMessages
SCFTimedMessages Maybe Preferences
rcvPrefs_
        ctUserPrefs' :: Preferences
ctUserPrefs' =
          let userDefault :: FeaturePreference 'CFTimedMessages
userDefault = SChatFeature 'CFTimedMessages
-> FullPreferences -> FeaturePreference 'CFTimedMessages
forall p (f :: ChatFeature).
PreferenceI p =>
SChatFeature f -> p -> FeaturePreference f
forall (f :: ChatFeature).
SChatFeature f -> FullPreferences -> FeaturePreference f
getPreference SChatFeature 'CFTimedMessages
SCFTimedMessages (User -> FullPreferences
fullPreferences User
user)
              userDefaultTTL :: Maybe Int
userDefaultTTL = FeaturePreference 'CFTimedMessages -> Maybe Int
forall (f :: ChatFeature).
FeatureI f =>
FeaturePreference f -> Maybe Int
prefParam FeaturePreference 'CFTimedMessages
userDefault
              ctUserTMPref' :: Maybe TimedMessagesPreference
ctUserTMPref' = case Maybe TimedMessagesPreference
ctUserTMPref of
                Just TimedMessagesPreference
userTM -> TimedMessagesPreference -> Maybe TimedMessagesPreference
forall a. a -> Maybe a
Just (TimedMessagesPreference
userTM :: TimedMessagesPreference) {ttl = rcvTTL}
                Maybe TimedMessagesPreference
_
                  | Maybe Int
rcvTTL Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Int
userDefaultTTL -> TimedMessagesPreference -> Maybe TimedMessagesPreference
forall a. a -> Maybe a
Just (FeaturePreference 'CFTimedMessages
TimedMessagesPreference
userDefault :: TimedMessagesPreference) {ttl = rcvTTL}
                  | Bool
otherwise -> Maybe TimedMessagesPreference
forall a. Maybe a
Nothing
           in SChatFeature 'CFTimedMessages
-> Maybe (FeaturePreference 'CFTimedMessages)
-> Preferences
-> Preferences
forall (f :: ChatFeature).
SChatFeature f
-> Maybe (FeaturePreference f) -> Preferences -> Preferences
setPreference_ SChatFeature 'CFTimedMessages
SCFTimedMessages Maybe (FeaturePreference 'CFTimedMessages)
Maybe TimedMessagesPreference
ctUserTMPref' Preferences
ctUserPrefs
        createProfileUpdatedItem :: Contact -> CM ()
createProfileUpdatedItem Contact
c' =
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
visibleProfileUpdated (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
            let ciContent :: CIContent 'MDRcv
ciContent = RcvDirectEvent -> CIContent 'MDRcv
CIRcvDirectEvent (RcvDirectEvent -> CIContent 'MDRcv)
-> RcvDirectEvent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ Profile -> Profile -> RcvDirectEvent
RDEProfileUpdated Profile
p Profile
p'
            User
-> ChatDirection 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
c') CIContent 'MDRcv
ciContent Maybe UTCTime
forall a. Maybe a
Nothing
          where
            visibleProfileUpdated :: Bool
visibleProfileUpdated =
              Text
n' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
n Bool -> Bool -> Bool
|| Text
fn' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
fn Bool -> Bool -> Bool
|| Maybe Text
sd Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
sd' Bool -> Bool -> Bool
|| Maybe ImageData
i' Maybe ImageData -> Maybe ImageData -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ImageData
i Bool -> Bool -> Bool
|| Maybe ConnLinkContact
cl' Maybe ConnLinkContact -> Maybe ConnLinkContact -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ConnLinkContact
cl
            Profile {displayName :: Profile -> Text
displayName = Text
n, fullName :: Profile -> Text
fullName = Text
fn, shortDescr :: Profile -> Maybe Text
shortDescr = Maybe Text
sd, image :: Profile -> Maybe ImageData
image = Maybe ImageData
i, contactLink :: Profile -> Maybe ConnLinkContact
contactLink = Maybe ConnLinkContact
cl} = Profile
p
            Profile {displayName :: Profile -> Text
displayName = Text
n', fullName :: Profile -> Text
fullName = Text
fn', shortDescr :: Profile -> Maybe Text
shortDescr = Maybe Text
sd', image :: Profile -> Maybe ImageData
image = Maybe ImageData
i', contactLink :: Profile -> Maybe ConnLinkContact
contactLink = Maybe ConnLinkContact
cl'} = Profile
p'

    xInfoMember :: GroupInfo -> GroupMember -> Profile -> UTCTime -> CM (Maybe DeliveryJobScope)
    xInfoMember :: GroupInfo
-> GroupMember
-> Profile
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xInfoMember GroupInfo
gInfo GroupMember
m Profile
p' UTCTime
brokerTs = do
      CM GroupMember -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM GroupMember -> CM ()) -> CM GroupMember -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> Profile
-> Bool
-> Maybe UTCTime
-> CM GroupMember
processMemberProfileUpdate GroupInfo
gInfo GroupMember
m Profile
p' Bool
True (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
brokerTs)
      Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ GroupMember -> Maybe DeliveryJobScope
memberEventDeliveryScope GroupMember
m

    xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM ()
    xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM ()
xGrpLinkMem gInfo :: GroupInfo
gInfo@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership, Maybe BusinessChatInfo
businessChat :: GroupInfo -> Maybe BusinessChatInfo
businessChat :: Maybe BusinessChatInfo
businessChat} m :: GroupMember
m@GroupMember {GroupMemberId
groupMemberId :: GroupMember -> GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId, GroupMemberCategory
memberCategory :: GroupMember -> GroupMemberCategory
memberCategory :: GroupMemberCategory
memberCategory} Connection {Bool
viaGroupLink :: Bool
viaGroupLink :: Connection -> Bool
viaGroupLink} Profile
p' = do
      Bool
xGrpLinkMemReceived <- (Connection -> ExceptT StoreError IO Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO Bool)
 -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> (Connection -> ExceptT StoreError IO Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> GroupMemberId -> ExceptT StoreError IO Bool
getXGrpLinkMemReceived Connection
db GroupMemberId
groupMemberId
      if (Bool
viaGroupLink Bool -> Bool -> Bool
|| Maybe BusinessChatInfo -> Bool
forall a. Maybe a -> Bool
isJust Maybe BusinessChatInfo
businessChat) Bool -> Bool -> Bool
&& Maybe GroupMemberId -> Bool
forall a. Maybe a -> Bool
isNothing (GroupMember -> Maybe GroupMemberId
memberContactId GroupMember
m) Bool -> Bool -> Bool
&& GroupMemberCategory
memberCategory GroupMemberCategory -> GroupMemberCategory -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberCategory
GCHostMember Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
xGrpLinkMemReceived
        then do
          GroupMember
m' <- GroupInfo
-> GroupMember
-> Profile
-> Bool
-> Maybe UTCTime
-> CM GroupMember
processMemberProfileUpdate GroupInfo
gInfo GroupMember
m Profile
p' Bool
False Maybe UTCTime
forall a. Maybe a
Nothing
          (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> GroupMemberId -> Bool -> IO ()
setXGrpLinkMemReceived Connection
db GroupMemberId
groupMemberId Bool
True
          let connectedIncognito :: Bool
connectedIncognito = GroupMember -> Bool
memberIncognito GroupMember
membership
          GroupMember -> Bool -> CM ()
probeMatchingMemberContact GroupMember
m' Bool
connectedIncognito
        else Text -> CM ()
messageError Text
"x.grp.link.mem error: invalid group link host profile update"

    xGrpLinkAcpt :: GroupInfo -> GroupMember -> GroupAcceptance -> GroupMemberRole -> MemberId -> RcvMessage -> UTCTime -> CM ()
    xGrpLinkAcpt :: GroupInfo
-> GroupMember
-> GroupAcceptance
-> GroupMemberRole
-> MemberId
-> RcvMessage
-> UTCTime
-> CM ()
xGrpLinkAcpt gInfo :: GroupInfo
gInfo@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} GroupMember
m GroupAcceptance
acceptance GroupMemberRole
role MemberId
memberId RcvMessage
msg UTCTime
brokerTs
      | MemberId -> GroupMember -> Bool
sameMemberId MemberId
memberId GroupMember
membership = CM ()
processUserAccepted
      | Bool
otherwise =
          (Connection -> IO (Either StoreError GroupMember))
-> CM (Either StoreError GroupMember)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO GroupMember
 -> IO (Either StoreError GroupMember))
-> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall a b. (a -> b) -> a -> b
$ Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo MemberId
memberId) CM (Either StoreError GroupMember)
-> (Either StoreError GroupMember -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left StoreError
_ -> Text -> CM ()
messageError Text
"x.grp.link.acpt error: referenced member does not exist"
            Right GroupMember
referencedMember -> do
              (GroupMember
referencedMember', GroupInfo
gInfo') <- (Connection -> IO (GroupMember, GroupInfo))
-> CM (GroupMember, GroupInfo)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (GroupMember, GroupInfo))
 -> CM (GroupMember, GroupInfo))
-> (Connection -> IO (GroupMember, GroupInfo))
-> CM (GroupMember, GroupInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                GroupMember
referencedMember' <- Connection
-> User
-> GroupMember
-> GroupMemberStatus
-> GroupMemberRole
-> IO GroupMember
updateGroupMemberAccepted Connection
db User
user GroupMember
referencedMember (GroupMember -> GroupMemberStatus
newMemberStatus GroupMember
referencedMember) GroupMemberRole
role
                GroupInfo
gInfo' <- Connection
-> User -> GroupInfo -> GroupMember -> GroupMember -> IO GroupInfo
updateGroupMembersRequireAttention Connection
db User
user GroupInfo
gInfo GroupMember
referencedMember GroupMember
referencedMember'
                (GroupMember, GroupInfo) -> IO (GroupMember, GroupInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMember
referencedMember', GroupInfo
gInfo')
              Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupMember -> GroupMemberCategory
memberCategory GroupMember
referencedMember GroupMemberCategory -> GroupMemberCategory -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberCategory
GCInviteeMember) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMember -> CM ()
introduceToRemainingMembers GroupMember
referencedMember'
              -- create item in both scopes
              GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM ()
memberConnectedChatItem GroupInfo
gInfo' Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing GroupMember
referencedMember'
              let scopeInfo :: Maybe GroupChatScopeInfo
scopeInfo = GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a. a -> Maybe a
Just (GroupChatScopeInfo -> Maybe GroupChatScopeInfo)
-> GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a b. (a -> b) -> a -> b
$ GCSIMemberSupport {groupMember_ :: Maybe GroupMember
groupMember_ = GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
referencedMember'}
                  gEvent :: RcvGroupEvent
gEvent = GroupMemberId -> Profile -> RcvGroupEvent
RGEMemberAccepted (GroupMember -> GroupMemberId
groupMemberId' GroupMember
referencedMember') (LocalProfile -> Profile
fromLocalProfile (LocalProfile -> Profile) -> LocalProfile -> Profile
forall a b. (a -> b) -> a -> b
$ GroupMember -> LocalProfile
memberProfile GroupMember
referencedMember')
              (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- User
-> ChatDirection 'CTGroup 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m) RcvMessage
msg UTCTime
brokerTs (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
gEvent)
              ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> GroupMember -> ChatEvent
CEvtMemberAcceptedByOther User
user GroupInfo
gInfo' GroupMember
m GroupMember
referencedMember'
              where
                newMemberStatus :: GroupMember -> GroupMemberStatus
newMemberStatus GroupMember
refMem = case GroupMember -> Maybe Connection
memberConn GroupMember
refMem of
                  Just Connection
c | Connection -> Bool
connReady Connection
c -> GroupMemberStatus
GSMemConnected
                  Maybe Connection
_ -> GroupMemberStatus
GSMemAnnounced
      where
        processUserAccepted :: CM ()
processUserAccepted = case GroupAcceptance
acceptance of
          GroupAcceptance
GAAccepted -> do
            GroupMember
membership' <- (Connection -> IO GroupMember) -> CM GroupMember
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO GroupMember) -> CM GroupMember)
-> (Connection -> IO GroupMember) -> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupMember
-> GroupMemberStatus
-> GroupMemberRole
-> IO GroupMember
updateGroupMemberAccepted Connection
db User
user GroupMember
membership GroupMemberStatus
GSMemConnected GroupMemberRole
role
            -- create item in both scopes
            let gInfo' :: GroupInfo
gInfo' = GroupInfo
gInfo {membership = membership'}
                cd :: ChatDirection 'CTGroup 'MDRcv
cd = GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing GroupMember
m
            User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user ChatDirection 'CTGroup 'MDRcv
cd (E2EInfo -> CIContent 'MDRcv
CIRcvGroupE2EEInfo E2EInfo {pqEnabled :: Maybe PQEncryption
pqEnabled = PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just PQEncryption
PQEncOff}) Maybe UTCTime
forall a. Maybe a
Nothing
            let prepared :: Maybe PreparedGroup
prepared = GroupInfo -> Maybe PreparedGroup
preparedGroup GroupInfo
gInfo'
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe PreparedGroup -> Bool
forall a. Maybe a -> Bool
isJust Maybe PreparedGroup
prepared) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> ChatDirection 'CTGroup 'MDRcv
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent 'MDRcv)
-> GroupInfo
-> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> ChatDirection 'CTGroup d
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent d)
-> GroupInfo
-> CM ()
createGroupFeatureItems User
user ChatDirection 'CTGroup 'MDRcv
cd GroupFeature
-> GroupPreference
-> Maybe Int
-> Maybe GroupMemberRole
-> CIContent 'MDRcv
CIRcvGroupFeature GroupInfo
gInfo'
            let welcomeMsgId_ :: Maybe (Maybe SharedMsgId)
welcomeMsgId_ = (\PreparedGroup {welcomeSharedMsgId :: PreparedGroup -> Maybe SharedMsgId
welcomeSharedMsgId = Maybe SharedMsgId
mId} -> Maybe SharedMsgId
mId) (PreparedGroup -> Maybe SharedMsgId)
-> Maybe PreparedGroup -> Maybe (Maybe SharedMsgId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GroupInfo -> Maybe PreparedGroup
preparedGroup GroupInfo
gInfo'
            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (Maybe SharedMsgId) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Maybe SharedMsgId)
welcomeMsgId_) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo -> GroupMember -> CM ()
maybeCreateGroupDescrLocal GroupInfo
gInfo' GroupMember
m
            User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user ChatDirection 'CTGroup 'MDRcv
cd (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
RGEUserAccepted) Maybe UTCTime
forall a. Maybe a
Nothing
            let scopeInfo :: Maybe GroupChatScopeInfo
scopeInfo = GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a. a -> Maybe a
Just (GroupChatScopeInfo -> Maybe GroupChatScopeInfo)
-> GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a b. (a -> b) -> a -> b
$ GCSIMemberSupport {groupMember_ :: Maybe GroupMember
groupMember_ = Maybe GroupMember
forall a. Maybe a
Nothing}
            User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m) (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
RGEUserAccepted) Maybe UTCTime
forall a. Maybe a
Nothing
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> ChatEvent
CEvtUserJoinedGroup User
user GroupInfo
gInfo' GroupMember
m
          GroupAcceptance
GAPendingReview -> do
            GroupMember
membership' <- (Connection -> IO GroupMember) -> CM GroupMember
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO GroupMember) -> CM GroupMember)
-> (Connection -> IO GroupMember) -> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupMember
-> GroupMemberStatus
-> GroupMemberRole
-> IO GroupMember
updateGroupMemberAccepted Connection
db User
user GroupMember
membership GroupMemberStatus
GSMemPendingReview GroupMemberRole
role
            let gInfo' :: GroupInfo
gInfo' = GroupInfo
gInfo {membership = membership'}
                scopeInfo :: Maybe GroupChatScopeInfo
scopeInfo = GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a. a -> Maybe a
Just (GroupChatScopeInfo -> Maybe GroupChatScopeInfo)
-> GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a b. (a -> b) -> a -> b
$ GCSIMemberSupport {groupMember_ :: Maybe GroupMember
groupMember_ = Maybe GroupMember
forall a. Maybe a
Nothing}
            User
-> ChatDirection 'CTGroup 'MDSnd
-> CIContent 'MDSnd
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDSnd
CDGroupSnd GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo) (SndGroupEvent -> CIContent 'MDSnd
CISndGroupEvent SndGroupEvent
SGEUserPendingReview) Maybe UTCTime
forall a. Maybe a
Nothing
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> GroupMember -> ChatEvent
CEvtMemberAcceptedByOther User
user GroupInfo
gInfo' GroupMember
m GroupMember
membership'
          GroupAcceptance
GAPendingApproval ->
            Text -> CM ()
messageWarning Text
"x.grp.link.acpt: unexpected group acceptance - pending approval"
        introduceToRemainingMembers :: GroupMember -> CM ()
introduceToRemainingMembers GroupMember
acceptedMember = do
          VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
introduceToRemaining VersionRangeChat
vr User
user GroupInfo
gInfo GroupMember
acceptedMember
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SGroupFeature 'GFHistory -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureNoRoleI f =>
SGroupFeature f -> GroupInfo -> Bool
groupFeatureAllowed SGroupFeature 'GFHistory
SGFHistory GroupInfo
gInfo) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> CM ()
sendHistory User
user GroupInfo
gInfo GroupMember
acceptedMember

    maybeCreateGroupDescrLocal :: GroupInfo -> GroupMember -> CM ()
    maybeCreateGroupDescrLocal :: GroupInfo -> GroupMember -> CM ()
maybeCreateGroupDescrLocal gInfo :: GroupInfo
gInfo@GroupInfo {groupProfile :: GroupInfo -> GroupProfile
groupProfile = GroupProfile {Maybe Text
description :: Maybe Text
description :: GroupProfile -> Maybe Text
description}} GroupMember
m =
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
expectHistory (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Maybe Text -> (Text -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Text
description ((Text -> CM ()) -> CM ()) -> (Text -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Text
descr ->
        User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing GroupMember
m) (MsgContent -> CIContent 'MDRcv
CIRcvMsgContent (MsgContent -> CIContent 'MDRcv) -> MsgContent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ Text -> MsgContent
MCText Text
descr) Maybe UTCTime
forall a. Maybe a
Nothing
      where
        expectHistory :: Bool
expectHistory = SGroupFeature 'GFHistory -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureNoRoleI f =>
SGroupFeature f -> GroupInfo -> Bool
groupFeatureAllowed SGroupFeature 'GFHistory
SGFHistory GroupInfo
gInfo Bool -> Bool -> Bool
&& GroupMember
m GroupMember -> Version ChatVersion -> Bool
`supportsVersion` Version ChatVersion
groupHistoryIncludeWelcomeVersion

    processMemberProfileUpdate :: GroupInfo -> GroupMember -> Profile -> Bool -> Maybe UTCTime -> CM GroupMember
    processMemberProfileUpdate :: GroupInfo
-> GroupMember
-> Profile
-> Bool
-> Maybe UTCTime
-> CM GroupMember
processMemberProfileUpdate GroupInfo
gInfo m :: GroupMember
m@GroupMember {memberProfile :: GroupMember -> LocalProfile
memberProfile = LocalProfile
p, Maybe GroupMemberId
memberContactId :: GroupMember -> Maybe GroupMemberId
memberContactId :: Maybe GroupMemberId
memberContactId} Profile
p' Bool
createItems Maybe UTCTime
itemTs_
      | Bool -> Profile -> Profile
redactedMemberProfile Bool
allowSimplexLinks (LocalProfile -> Profile
fromLocalProfile LocalProfile
p) Profile -> Profile -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Profile -> Profile
redactedMemberProfile Bool
allowSimplexLinks Profile
p' = do
          GroupInfo -> CM ()
updateBusinessChatProfile GroupInfo
gInfo
          case Maybe GroupMemberId
memberContactId of
            Maybe GroupMemberId
Nothing -> do
              GroupMember
m' <- (Connection -> ExceptT StoreError IO GroupMember) -> CM GroupMember
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMember)
 -> CM GroupMember)
-> (Connection -> ExceptT StoreError IO GroupMember)
-> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupMember
-> Profile
-> ExceptT StoreError IO GroupMember
updateMemberProfile Connection
db User
user GroupMember
m Profile
p'
              GroupMember -> CM ()
createProfileUpdatedItem GroupMember
m'
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> GroupMember -> ChatEvent
CEvtGroupMemberUpdated User
user GroupInfo
gInfo GroupMember
m GroupMember
m'
              GroupMember -> CM GroupMember
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupMember
m'
            Just GroupMemberId
mContactId -> do
              Contact
mCt <- (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO Contact) -> CM Contact)
-> (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user GroupMemberId
mContactId
              if Contact -> Bool
canUpdateProfile Contact
mCt
                then do
                  (GroupMember
m', Contact
ct') <- (Connection -> ExceptT StoreError IO (GroupMember, Contact))
-> CM (GroupMember, Contact)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupMember, Contact))
 -> CM (GroupMember, Contact))
-> (Connection -> ExceptT StoreError IO (GroupMember, Contact))
-> CM (GroupMember, Contact)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupMember
-> Contact
-> Profile
-> ExceptT StoreError IO (GroupMember, Contact)
updateContactMemberProfile Connection
db User
user GroupMember
m Contact
mCt Profile
p'
                  GroupMember -> CM ()
createProfileUpdatedItem GroupMember
m'
                  ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> GroupMember -> ChatEvent
CEvtGroupMemberUpdated User
user GroupInfo
gInfo GroupMember
m GroupMember
m'
                  ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> Contact -> ChatEvent
CEvtContactUpdated User
user Contact
mCt Contact
ct'
                  GroupMember -> CM GroupMember
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupMember
m'
                else GroupMember -> CM GroupMember
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupMember
m
              where
                canUpdateProfile :: Contact -> Bool
canUpdateProfile Contact
ct
                  | Bool -> Bool
not (Contact -> Bool
contactActive Contact
ct) = Bool
True
                  | Bool
otherwise = case Contact -> Maybe Connection
contactConn Contact
ct of
                      Maybe Connection
Nothing -> Bool
True
                      Just Connection
conn -> Bool -> Bool
not (Connection -> Bool
connReady Connection
conn) Bool -> Bool -> Bool
|| (Connection -> Int
authErrCounter Connection
conn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1)
      | Bool
otherwise =
          GroupMember -> CM GroupMember
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupMember
m
      where
        allowSimplexLinks :: Bool
allowSimplexLinks = SGroupFeature 'GFSimplexLinks -> GroupMember -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupMember -> GroupInfo -> Bool
groupFeatureMemberAllowed SGroupFeature 'GFSimplexLinks
SGFSimplexLinks GroupMember
m GroupInfo
gInfo
        updateBusinessChatProfile :: GroupInfo -> CM ()
updateBusinessChatProfile g :: GroupInfo
g@GroupInfo {Maybe BusinessChatInfo
businessChat :: GroupInfo -> Maybe BusinessChatInfo
businessChat :: Maybe BusinessChatInfo
businessChat} = case Maybe BusinessChatInfo
businessChat of
          Just BusinessChatInfo
bc | BusinessChatInfo -> GroupMember -> Bool
isMainBusinessMember BusinessChatInfo
bc GroupMember
m -> do
            GroupInfo
g' <- (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo)
-> (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User -> GroupInfo -> Profile -> ExceptT StoreError IO GroupInfo
updateGroupProfileFromMember Connection
db User
user GroupInfo
g Profile
p'
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupInfo -> Maybe GroupMember -> ChatEvent
CEvtGroupUpdated User
user GroupInfo
g GroupInfo
g' (GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
m)
          Maybe BusinessChatInfo
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        isMainBusinessMember :: BusinessChatInfo -> GroupMember -> Bool
isMainBusinessMember BusinessChatInfo {BusinessChatType
chatType :: BusinessChatInfo -> BusinessChatType
chatType :: BusinessChatType
chatType, MemberId
businessId :: MemberId
businessId :: BusinessChatInfo -> MemberId
businessId, MemberId
customerId :: BusinessChatInfo -> MemberId
customerId :: MemberId
customerId} GroupMember {MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId} = case BusinessChatType
chatType of
          BusinessChatType
BCBusiness -> MemberId
businessId MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== MemberId
memberId
          BusinessChatType
BCCustomer -> MemberId
customerId MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== MemberId
memberId
        createProfileUpdatedItem :: GroupMember -> CM ()
createProfileUpdatedItem GroupMember
m' =
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
createItems (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
            (GroupInfo
gInfo', GroupMember
m'', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo GroupMember
m'
            let ciContent :: CIContent 'MDRcv
ciContent = RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent (RcvGroupEvent -> CIContent 'MDRcv)
-> RcvGroupEvent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ Profile -> Profile -> RcvGroupEvent
RGEMemberProfileUpdated (LocalProfile -> Profile
fromLocalProfile LocalProfile
p) Profile
p'
            User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m'') CIContent 'MDRcv
ciContent Maybe UTCTime
itemTs_

    xInfoProbe :: ContactOrMember -> Probe -> CM ()
    xInfoProbe :: ContactOrMember -> Probe -> CM ()
xInfoProbe ContactOrMember
cgm2 Probe
probe = do
      Bool
contactMerge <- TVar Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChatController -> TVar Bool)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar Bool
contactMergeEnabled
      -- [incognito] unless connected incognito
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
contactMerge Bool -> Bool -> Bool
&& Bool -> Bool
not (ContactOrMember -> Bool
contactOrMemberIncognito ContactOrMember
cgm2)) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
        [ContactOrMember]
cgm1s <- (Connection -> IO [ContactOrMember])
-> ExceptT ChatError (ReaderT ChatController IO) [ContactOrMember]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [ContactOrMember])
 -> ExceptT ChatError (ReaderT ChatController IO) [ContactOrMember])
-> (Connection -> IO [ContactOrMember])
-> ExceptT ChatError (ReaderT ChatController IO) [ContactOrMember]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> ContactOrMember
-> Probe
-> IO [ContactOrMember]
matchReceivedProbe Connection
db VersionRangeChat
vr User
user ContactOrMember
cgm2 Probe
probe
        let cgm1s' :: [ContactOrMember]
cgm1s' = (ContactOrMember -> Bool) -> [ContactOrMember] -> [ContactOrMember]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (ContactOrMember -> Bool) -> ContactOrMember -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContactOrMember -> Bool
contactOrMemberIncognito) [ContactOrMember]
cgm1s
        [ContactOrMember] -> ContactOrMember -> CM ()
probeMatches [ContactOrMember]
cgm1s' ContactOrMember
cgm2
      where
        probeMatches :: [ContactOrMember] -> ContactOrMember -> CM ()
        probeMatches :: [ContactOrMember] -> ContactOrMember -> CM ()
probeMatches [] ContactOrMember
_ = () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        probeMatches (ContactOrMember
cgm1' : [ContactOrMember]
cgm1s') ContactOrMember
cgm2' = do
          Maybe ContactOrMember
cgm2''_ <- ContactOrMember
-> ContactOrMember -> Probe -> CM (Maybe ContactOrMember)
probeMatch ContactOrMember
cgm1' ContactOrMember
cgm2' Probe
probe CM (Maybe ContactOrMember)
-> (ChatError -> CM (Maybe ContactOrMember))
-> CM (Maybe ContactOrMember)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
_ -> Maybe ContactOrMember -> CM (Maybe ContactOrMember)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ContactOrMember -> Maybe ContactOrMember
forall a. a -> Maybe a
Just ContactOrMember
cgm2')
          let cgm2'' :: ContactOrMember
cgm2'' = ContactOrMember -> Maybe ContactOrMember -> ContactOrMember
forall a. a -> Maybe a -> a
fromMaybe ContactOrMember
cgm2' Maybe ContactOrMember
cgm2''_
          [ContactOrMember] -> ContactOrMember -> CM ()
probeMatches [ContactOrMember]
cgm1s' ContactOrMember
cgm2''

    xInfoProbeCheck :: ContactOrMember -> ProbeHash -> CM ()
    xInfoProbeCheck :: ContactOrMember -> ProbeHash -> CM ()
xInfoProbeCheck ContactOrMember
cgm1 ProbeHash
probeHash = do
      Bool
contactMerge <- TVar Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar Bool -> ExceptT ChatError (ReaderT ChatController IO) Bool)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar Bool)
-> ExceptT ChatError (ReaderT ChatController IO) Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChatController -> TVar Bool)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar Bool
contactMergeEnabled
      -- [incognito] unless connected incognito
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
contactMerge Bool -> Bool -> Bool
&& Bool -> Bool
not (ContactOrMember -> Bool
contactOrMemberIncognito ContactOrMember
cgm1)) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe (ContactOrMember, Probe)
cgm2Probe_ <- (Connection -> IO (Maybe (ContactOrMember, Probe)))
-> CM (Maybe (ContactOrMember, Probe))
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (Maybe (ContactOrMember, Probe)))
 -> CM (Maybe (ContactOrMember, Probe)))
-> (Connection -> IO (Maybe (ContactOrMember, Probe)))
-> CM (Maybe (ContactOrMember, Probe))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> ContactOrMember
-> ProbeHash
-> IO (Maybe (ContactOrMember, Probe))
matchReceivedProbeHash Connection
db VersionRangeChat
vr User
user ContactOrMember
cgm1 ProbeHash
probeHash
        Maybe (ContactOrMember, Probe)
-> ((ContactOrMember, Probe) -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (ContactOrMember, Probe)
cgm2Probe_ (((ContactOrMember, Probe) -> CM ()) -> CM ())
-> ((ContactOrMember, Probe) -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \(ContactOrMember
cgm2, Probe
probe) ->
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ContactOrMember -> Bool
contactOrMemberIncognito ContactOrMember
cgm2) (CM () -> CM ())
-> (CM (Maybe ContactOrMember) -> CM ())
-> CM (Maybe ContactOrMember)
-> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CM (Maybe ContactOrMember) -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM (Maybe ContactOrMember) -> CM ())
-> CM (Maybe ContactOrMember) -> CM ()
forall a b. (a -> b) -> a -> b
$
            ContactOrMember
-> ContactOrMember -> Probe -> CM (Maybe ContactOrMember)
probeMatch ContactOrMember
cgm1 ContactOrMember
cgm2 Probe
probe

    probeMatch :: ContactOrMember -> ContactOrMember -> Probe -> CM (Maybe ContactOrMember)
    probeMatch :: ContactOrMember
-> ContactOrMember -> Probe -> CM (Maybe ContactOrMember)
probeMatch ContactOrMember
cgm1 ContactOrMember
cgm2 Probe
probe =
      case ContactOrMember
cgm1 of
        COMContact c1 :: Contact
c1@Contact {profile :: Contact -> LocalProfile
profile = LocalProfile
p1} ->
          case ContactOrMember
cgm2 of
            COMGroupMember m2 :: GroupMember
m2@GroupMember {memberProfile :: GroupMember -> LocalProfile
memberProfile = LocalProfile
p2, Maybe GroupMemberId
memberContactId :: GroupMember -> Maybe GroupMemberId
memberContactId :: Maybe GroupMemberId
memberContactId}
              | Maybe GroupMemberId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe GroupMemberId
memberContactId Bool -> Bool -> Bool
&& LocalProfile -> LocalProfile -> Bool
profilesMatch LocalProfile
p1 LocalProfile
p2 -> do
                  ExceptT
  ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
 -> CM ())
-> (ChatMsgEvent 'Json
    -> ExceptT
         ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId))
-> ChatMsgEvent 'Json
-> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User
-> Contact
-> ChatMsgEvent 'Json
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> ChatMsgEvent e
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, GroupMemberId)
sendDirectContactMessage User
user Contact
c1 (ChatMsgEvent 'Json -> CM ()) -> ChatMsgEvent 'Json -> CM ()
forall a b. (a -> b) -> a -> b
$ Probe -> ChatMsgEvent 'Json
XInfoProbeOk Probe
probe
                  Contact -> ContactOrMember
COMContact (Contact -> ContactOrMember)
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
-> CM (Maybe ContactOrMember)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> Contact
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
associateMemberAndContact Contact
c1 GroupMember
m2
              | Bool
otherwise -> Text -> CM ()
messageWarning Text
"probeMatch ignored: profiles don't match or member already has contact" CM () -> CM (Maybe ContactOrMember) -> CM (Maybe ContactOrMember)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ContactOrMember -> CM (Maybe ContactOrMember)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ContactOrMember
forall a. Maybe a
Nothing
            COMContact Contact
_ -> Text -> CM ()
messageWarning Text
"probeMatch ignored: contacts are not merged" CM () -> CM (Maybe ContactOrMember) -> CM (Maybe ContactOrMember)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ContactOrMember -> CM (Maybe ContactOrMember)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ContactOrMember
forall a. Maybe a
Nothing
        COMGroupMember m1 :: GroupMember
m1@GroupMember {GroupMemberId
groupId :: GroupMember -> GroupMemberId
groupId :: GroupMemberId
groupId, memberProfile :: GroupMember -> LocalProfile
memberProfile = LocalProfile
p1, Maybe GroupMemberId
memberContactId :: GroupMember -> Maybe GroupMemberId
memberContactId :: Maybe GroupMemberId
memberContactId} ->
          case ContactOrMember
cgm2 of
            COMContact c2 :: Contact
c2@Contact {profile :: Contact -> LocalProfile
profile = LocalProfile
p2}
              | GroupMember -> Bool
memberCurrent GroupMember
m1 Bool -> Bool -> Bool
&& Maybe GroupMemberId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe GroupMemberId
memberContactId Bool -> Bool -> Bool
&& LocalProfile -> LocalProfile -> Bool
profilesMatch LocalProfile
p1 LocalProfile
p2 ->
                  case GroupMember -> Maybe Connection
memberConn GroupMember
m1 of
                    Just Connection
conn -> do
                      ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, GroupMemberId, PQEncryption)
 -> CM ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
sendDirectMemberMessage Connection
conn (Probe -> ChatMsgEvent 'Json
XInfoProbeOk Probe
probe) GroupMemberId
groupId
                      Contact -> ContactOrMember
COMContact (Contact -> ContactOrMember)
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
-> CM (Maybe ContactOrMember)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> Contact
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
associateMemberAndContact Contact
c2 GroupMember
m1
                    Maybe Connection
_ -> Text -> CM ()
messageWarning Text
"probeMatch ignored: matched member doesn't have connection" CM () -> CM (Maybe ContactOrMember) -> CM (Maybe ContactOrMember)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ContactOrMember -> CM (Maybe ContactOrMember)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ContactOrMember
forall a. Maybe a
Nothing
              | Bool
otherwise -> Text -> CM ()
messageWarning Text
"probeMatch ignored: profiles don't match or member already has contact or member not current" CM () -> CM (Maybe ContactOrMember) -> CM (Maybe ContactOrMember)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ContactOrMember -> CM (Maybe ContactOrMember)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ContactOrMember
forall a. Maybe a
Nothing
            COMGroupMember GroupMember
_ -> Text -> CM ()
messageWarning Text
"probeMatch ignored: members are not matched with members" CM () -> CM (Maybe ContactOrMember) -> CM (Maybe ContactOrMember)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> ExceptT ChatError (ReaderT ChatController IO) b
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ContactOrMember -> CM (Maybe ContactOrMember)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ContactOrMember
forall a. Maybe a
Nothing

    xInfoProbeOk :: ContactOrMember -> Probe -> CM ()
    xInfoProbeOk :: ContactOrMember -> Probe -> CM ()
xInfoProbeOk ContactOrMember
cgm1 Probe
probe = do
      Maybe ContactOrMember
cgm2 <- (Connection -> IO (Maybe ContactOrMember))
-> CM (Maybe ContactOrMember)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (Maybe ContactOrMember))
 -> CM (Maybe ContactOrMember))
-> (Connection -> IO (Maybe ContactOrMember))
-> CM (Maybe ContactOrMember)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> ContactOrMember
-> Probe
-> IO (Maybe ContactOrMember)
matchSentProbe Connection
db VersionRangeChat
vr User
user ContactOrMember
cgm1 Probe
probe
      case ContactOrMember
cgm1 of
        COMContact Contact
c1 ->
          case Maybe ContactOrMember
cgm2 of
            Just (COMGroupMember m2 :: GroupMember
m2@GroupMember {Maybe GroupMemberId
memberContactId :: GroupMember -> Maybe GroupMemberId
memberContactId :: Maybe GroupMemberId
memberContactId})
              | Maybe GroupMemberId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe GroupMemberId
memberContactId -> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
 -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
-> CM ()
forall a b. (a -> b) -> a -> b
$ Contact
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
associateMemberAndContact Contact
c1 GroupMember
m2
              | Bool
otherwise -> Text -> CM ()
messageWarning Text
"xInfoProbeOk ignored: member already has contact"
            Just (COMContact Contact
_) -> Text -> CM ()
messageWarning Text
"xInfoProbeOk ignored: contacts are not merged"
            Maybe ContactOrMember
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        COMGroupMember m1 :: GroupMember
m1@GroupMember {Maybe GroupMemberId
memberContactId :: GroupMember -> Maybe GroupMemberId
memberContactId :: Maybe GroupMemberId
memberContactId} ->
          case Maybe ContactOrMember
cgm2 of
            Just (COMContact Contact
c2)
              | Maybe GroupMemberId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe GroupMemberId
memberContactId -> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
 -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
-> CM ()
forall a b. (a -> b) -> a -> b
$ Contact
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
associateMemberAndContact Contact
c2 GroupMember
m1
              | Bool
otherwise -> Text -> CM ()
messageWarning Text
"xInfoProbeOk ignored: member already has contact"
            Just (COMGroupMember GroupMember
_) -> Text -> CM ()
messageWarning Text
"xInfoProbeOk ignored: members are not matched with members"
            Maybe ContactOrMember
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- to party accepting call
    xCallInv :: Contact -> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> CM ()
    xCallInv :: Contact
-> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> CM ()
xCallInv ct :: Contact
ct@Contact {GroupMemberId
contactId :: Contact -> GroupMemberId
contactId :: GroupMemberId
contactId} CallId
callId CallInvitation {CallType
callType :: CallType
callType :: CallInvitation -> CallType
callType, Maybe PublicKeyX25519
callDhPubKey :: Maybe PublicKeyX25519
callDhPubKey :: CallInvitation -> Maybe PublicKeyX25519
callDhPubKey} msg :: RcvMessage
msg@RcvMessage {Maybe SharedMsgId
sharedMsgId_ :: RcvMessage -> Maybe SharedMsgId
sharedMsgId_ :: Maybe SharedMsgId
sharedMsgId_} MsgMeta
msgMeta = do
      if SChatFeature 'CFCalls -> (PrefEnabled -> Bool) -> Contact -> Bool
forall (f :: ChatFeature).
SChatFeature f -> (PrefEnabled -> Bool) -> Contact -> Bool
featureAllowed SChatFeature 'CFCalls
SCFCalls PrefEnabled -> Bool
forContact Contact
ct
        then do
          TVar ChaChaDRG
g <- (ChatController -> TVar ChaChaDRG)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar ChaChaDRG
random
          Maybe (PublicKeyX25519, PrivateKey 'X25519)
dhKeyPair <- STM (Maybe (PublicKeyX25519, PrivateKey 'X25519))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (PublicKeyX25519, PrivateKey 'X25519))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe (PublicKeyX25519, PrivateKey 'X25519))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Maybe (PublicKeyX25519, PrivateKey 'X25519)))
-> STM (Maybe (PublicKeyX25519, PrivateKey 'X25519))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (PublicKeyX25519, PrivateKey 'X25519))
forall a b. (a -> b) -> a -> b
$ if CallType -> Bool
encryptedCall CallType
callType then (PublicKeyX25519, PrivateKey 'X25519)
-> Maybe (PublicKeyX25519, PrivateKey 'X25519)
forall a. a -> Maybe a
Just ((PublicKeyX25519, PrivateKey 'X25519)
 -> Maybe (PublicKeyX25519, PrivateKey 'X25519))
-> STM (PublicKeyX25519, PrivateKey 'X25519)
-> STM (Maybe (PublicKeyX25519, PrivateKey 'X25519))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g else Maybe (PublicKeyX25519, PrivateKey 'X25519)
-> STM (Maybe (PublicKeyX25519, PrivateKey 'X25519))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (PublicKeyX25519, PrivateKey 'X25519)
forall a. Maybe a
Nothing
          (ChatItem 'CTDirect 'MDRcv
ci, ChatInfo 'CTDirect
cInfo) <- CICallStatus -> CM (ChatItem 'CTDirect 'MDRcv, ChatInfo 'CTDirect)
saveCallItem CICallStatus
CISCallPending
          Text
callUUID <- UUID -> Text
UUID.toText (UUID -> Text)
-> ExceptT ChatError (ReaderT ChatController IO) UUID
-> ExceptT ChatError (ReaderT ChatController IO) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID -> ExceptT ChatError (ReaderT ChatController IO) UUID
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
V4.nextRandom
          let sharedKey :: Maybe Key
sharedKey = ByteString -> Key
C.Key (ByteString -> Key)
-> (DhSecret 'X25519 -> ByteString) -> DhSecret 'X25519 -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DhSecret 'X25519 -> ByteString
forall (a :: Algorithm). DhSecret a -> ByteString
C.dhBytes' (DhSecret 'X25519 -> Key) -> Maybe (DhSecret 'X25519) -> Maybe Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecret 'X25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' (PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecret 'X25519)
-> Maybe PublicKeyX25519
-> Maybe (PrivateKey 'X25519 -> DhSecret 'X25519)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PublicKeyX25519
callDhPubKey Maybe (PrivateKey 'X25519 -> DhSecret 'X25519)
-> Maybe (PrivateKey 'X25519) -> Maybe (DhSecret 'X25519)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((PublicKeyX25519, PrivateKey 'X25519) -> PrivateKey 'X25519
forall a b. (a, b) -> b
snd ((PublicKeyX25519, PrivateKey 'X25519) -> PrivateKey 'X25519)
-> Maybe (PublicKeyX25519, PrivateKey 'X25519)
-> Maybe (PrivateKey 'X25519)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PublicKeyX25519, PrivateKey 'X25519)
dhKeyPair))
              callState :: CallState
callState = CallInvitationReceived {peerCallType :: CallType
peerCallType = CallType
callType, localDhPubKey :: Maybe PublicKeyX25519
localDhPubKey = (PublicKeyX25519, PrivateKey 'X25519) -> PublicKeyX25519
forall a b. (a, b) -> a
fst ((PublicKeyX25519, PrivateKey 'X25519) -> PublicKeyX25519)
-> Maybe (PublicKeyX25519, PrivateKey 'X25519)
-> Maybe PublicKeyX25519
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PublicKeyX25519, PrivateKey 'X25519)
dhKeyPair, Maybe Key
sharedKey :: Maybe Key
sharedKey :: Maybe Key
sharedKey}
              call' :: Call
call' = Call {GroupMemberId
contactId :: GroupMemberId
contactId :: GroupMemberId
contactId, CallId
callId :: CallId
callId :: CallId
callId, Text
callUUID :: Text
callUUID :: Text
callUUID, chatItemId :: GroupMemberId
chatItemId = ChatItem 'CTDirect 'MDRcv -> GroupMemberId
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> GroupMemberId
chatItemId' ChatItem 'CTDirect 'MDRcv
ci, CallState
callState :: CallState
callState :: CallState
callState, callTs :: UTCTime
callTs = ChatItem 'CTDirect 'MDRcv -> UTCTime
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> UTCTime
chatItemTs' ChatItem 'CTDirect 'MDRcv
ci}
          TMap GroupMemberId Call
calls <- (ChatController -> TMap GroupMemberId Call)
-> ExceptT
     ChatError (ReaderT ChatController IO) (TMap GroupMemberId Call)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TMap GroupMemberId Call
currentCalls
          -- theoretically, the new call invitation for the current contact can mark the in-progress call as ended
          -- (and replace it in ChatController)
          -- practically, this should not happen
          (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Call -> UTCTime -> IO ()
createCall Connection
db User
user Call
call' (UTCTime -> IO ()) -> UTCTime -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatItem 'CTDirect 'MDRcv -> UTCTime
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> UTCTime
chatItemTs' ChatItem 'CTDirect 'MDRcv
ci
          Maybe Call
call_ <- STM (Maybe Call)
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Call)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (GroupMemberId
-> Call -> TMap GroupMemberId Call -> STM (Maybe Call)
forall k a. Ord k => k -> a -> TMap k a -> STM (Maybe a)
TM.lookupInsert GroupMemberId
contactId Call
call' TMap GroupMemberId Call
calls)
          Maybe Call -> (Call -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Call
call_ ((Call -> CM ()) -> CM ()) -> (Call -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Call
call -> User
-> Contact
-> Call
-> WebRTCCallStatus
-> Maybe GroupMemberId
-> CM ()
updateCallItemStatus User
user Contact
ct Call
call WebRTCCallStatus
WCSDisconnected Maybe GroupMemberId
forall a. Maybe a
Nothing
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ RcvCallInvitation -> ChatEvent
CEvtCallInvitation RcvCallInvitation {User
user :: User
user :: User
user, contact :: Contact
contact = Contact
ct, CallType
callType :: CallType
callType :: CallType
callType, Maybe Key
sharedKey :: Maybe Key
sharedKey :: Maybe Key
sharedKey, Text
callUUID :: Text
callUUID :: Text
callUUID, callTs :: UTCTime
callTs = ChatItem 'CTDirect 'MDRcv -> UTCTime
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> UTCTime
chatItemTs' ChatItem 'CTDirect 'MDRcv
ci}
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv ChatInfo 'CTDirect
cInfo ChatItem 'CTDirect 'MDRcv
ci]
        else ChatFeature -> CM ()
featureRejected ChatFeature
CFCalls
      where
        brokerTs :: UTCTime
brokerTs = MsgMeta -> UTCTime
metaBrokerTs MsgMeta
msgMeta
        saveCallItem :: CICallStatus -> CM (ChatItem 'CTDirect 'MDRcv, ChatInfo 'CTDirect)
saveCallItem CICallStatus
status = User
-> ChatDirection 'CTDirect 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem 'CTDirect 'MDRcv, ChatInfo 'CTDirect)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct) RcvMessage
msg UTCTime
brokerTs (CICallStatus -> Int -> CIContent 'MDRcv
CIRcvCall CICallStatus
status Int
0)
        featureRejected :: ChatFeature -> CM ()
featureRejected ChatFeature
f = do
          let content :: (CIContent 'MDRcv, (Text, Maybe MarkdownList))
content = CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
ciContentNoParse (CIContent 'MDRcv
 -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)))
-> CIContent 'MDRcv
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
forall a b. (a -> b) -> a -> b
$ ChatFeature -> CIContent 'MDRcv
CIRcvChatFeatureRejected ChatFeature
f
          (ChatItem 'CTDirect 'MDRcv
ci, ChatInfo 'CTDirect
cInfo) <- User
-> ChatDirection 'CTDirect 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem 'CTDirect 'MDRcv, ChatInfo 'CTDirect)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map Text MsgMention
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct) RcvMessage
msg Maybe SharedMsgId
sharedMsgId_ UTCTime
brokerTs (CIContent 'MDRcv, (Text, Maybe MarkdownList))
content Maybe (CIFile 'MDRcv)
forall a. Maybe a
Nothing Maybe CITimed
forall a. Maybe a
Nothing Bool
False Map Text MsgMention
forall k a. Map k a
M.empty
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv ChatInfo 'CTDirect
cInfo ChatItem 'CTDirect 'MDRcv
ci]

    -- to party initiating call
    xCallOffer :: Contact -> CallId -> CallOffer -> RcvMessage -> CM ()
    xCallOffer :: Contact -> CallId -> CallOffer -> RcvMessage -> CM ()
xCallOffer Contact
ct CallId
callId CallOffer {CallType
callType :: CallType
callType :: CallOffer -> CallType
callType, WebRTCSession
rtcSession :: WebRTCSession
rtcSession :: CallOffer -> WebRTCSession
rtcSession, Maybe PublicKeyX25519
callDhPubKey :: Maybe PublicKeyX25519
callDhPubKey :: CallOffer -> Maybe PublicKeyX25519
callDhPubKey} RcvMessage
msg = do
      Contact
-> CallId
-> Text
-> RcvMessage
-> (Call -> CM (Maybe Call, Maybe ACIContent))
-> CM ()
msgCurrentCall Contact
ct CallId
callId Text
"x.call.offer" RcvMessage
msg ((Call -> CM (Maybe Call, Maybe ACIContent)) -> CM ())
-> (Call -> CM (Maybe Call, Maybe ACIContent)) -> CM ()
forall a b. (a -> b) -> a -> b
$
        \Call
call -> case Call -> CallState
callState Call
call of
          CallInvitationSent {CallType
localCallType :: CallType
localCallType :: CallState -> CallType
localCallType, Maybe (PrivateKey 'X25519)
localDhPrivKey :: Maybe (PrivateKey 'X25519)
localDhPrivKey :: CallState -> Maybe (PrivateKey 'X25519)
localDhPrivKey} -> do
            let sharedKey :: Maybe Key
sharedKey = ByteString -> Key
C.Key (ByteString -> Key)
-> (DhSecret 'X25519 -> ByteString) -> DhSecret 'X25519 -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DhSecret 'X25519 -> ByteString
forall (a :: Algorithm). DhSecret a -> ByteString
C.dhBytes' (DhSecret 'X25519 -> Key) -> Maybe (DhSecret 'X25519) -> Maybe Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecret 'X25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' (PublicKeyX25519 -> PrivateKey 'X25519 -> DhSecret 'X25519)
-> Maybe PublicKeyX25519
-> Maybe (PrivateKey 'X25519 -> DhSecret 'X25519)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PublicKeyX25519
callDhPubKey Maybe (PrivateKey 'X25519 -> DhSecret 'X25519)
-> Maybe (PrivateKey 'X25519) -> Maybe (DhSecret 'X25519)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (PrivateKey 'X25519)
localDhPrivKey)
                callState' :: CallState
callState' = CallOfferReceived {CallType
localCallType :: CallType
localCallType :: CallType
localCallType, peerCallType :: CallType
peerCallType = CallType
callType, peerCallSession :: WebRTCSession
peerCallSession = WebRTCSession
rtcSession, Maybe Key
sharedKey :: Maybe Key
sharedKey :: Maybe Key
sharedKey}
                askConfirmation :: Bool
askConfirmation = CallType -> Bool
encryptedCall CallType
localCallType Bool -> Bool -> Bool
&& Bool -> Bool
not (CallType -> Bool
encryptedCall CallType
callType)
            ChatEvent -> CM ()
toView CEvtCallOffer {User
user :: User
user :: User
user, contact :: Contact
contact = Contact
ct, CallType
callType :: CallType
callType :: CallType
callType, offer :: WebRTCSession
offer = WebRTCSession
rtcSession, Maybe Key
sharedKey :: Maybe Key
sharedKey :: Maybe Key
sharedKey, Bool
askConfirmation :: Bool
askConfirmation :: Bool
askConfirmation}
            (Maybe Call, Maybe ACIContent) -> CM (Maybe Call, Maybe ACIContent)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Call -> Maybe Call
forall a. a -> Maybe a
Just Call
call {callState = callState'}, ACIContent -> Maybe ACIContent
forall a. a -> Maybe a
Just (ACIContent -> Maybe ACIContent)
-> (CIContent 'MDSnd -> ACIContent)
-> CIContent 'MDSnd
-> Maybe ACIContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMsgDirection 'MDSnd -> CIContent 'MDSnd -> ACIContent
forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d -> CIContent d -> ACIContent
ACIContent SMsgDirection 'MDSnd
SMDSnd (CIContent 'MDSnd -> Maybe ACIContent)
-> CIContent 'MDSnd -> Maybe ACIContent
forall a b. (a -> b) -> a -> b
$ CICallStatus -> Int -> CIContent 'MDSnd
CISndCall CICallStatus
CISCallAccepted Int
0)
          CallState
_ -> do
            Text -> Call -> CM ()
msgCallStateError Text
"x.call.offer" Call
call
            (Maybe Call, Maybe ACIContent) -> CM (Maybe Call, Maybe ACIContent)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Call -> Maybe Call
forall a. a -> Maybe a
Just Call
call, Maybe ACIContent
forall a. Maybe a
Nothing)

    -- to party accepting call
    xCallAnswer :: Contact -> CallId -> CallAnswer -> RcvMessage -> CM ()
    xCallAnswer :: Contact -> CallId -> CallAnswer -> RcvMessage -> CM ()
xCallAnswer Contact
ct CallId
callId CallAnswer {WebRTCSession
rtcSession :: WebRTCSession
rtcSession :: CallAnswer -> WebRTCSession
rtcSession} RcvMessage
msg = do
      Contact
-> CallId
-> Text
-> RcvMessage
-> (Call -> CM (Maybe Call, Maybe ACIContent))
-> CM ()
msgCurrentCall Contact
ct CallId
callId Text
"x.call.answer" RcvMessage
msg ((Call -> CM (Maybe Call, Maybe ACIContent)) -> CM ())
-> (Call -> CM (Maybe Call, Maybe ACIContent)) -> CM ()
forall a b. (a -> b) -> a -> b
$
        \Call
call -> case Call -> CallState
callState Call
call of
          CallOfferSent {CallType
localCallType :: CallState -> CallType
localCallType :: CallType
localCallType, CallType
peerCallType :: CallState -> CallType
peerCallType :: CallType
peerCallType, WebRTCSession
localCallSession :: WebRTCSession
localCallSession :: CallState -> WebRTCSession
localCallSession, Maybe Key
sharedKey :: CallState -> Maybe Key
sharedKey :: Maybe Key
sharedKey} -> do
            let callState' :: CallState
callState' = CallNegotiated {CallType
localCallType :: CallType
localCallType :: CallType
localCallType, CallType
peerCallType :: CallType
peerCallType :: CallType
peerCallType, WebRTCSession
localCallSession :: WebRTCSession
localCallSession :: WebRTCSession
localCallSession, peerCallSession :: WebRTCSession
peerCallSession = WebRTCSession
rtcSession, Maybe Key
sharedKey :: Maybe Key
sharedKey :: Maybe Key
sharedKey}
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> WebRTCSession -> ChatEvent
CEvtCallAnswer User
user Contact
ct WebRTCSession
rtcSession
            (Maybe Call, Maybe ACIContent) -> CM (Maybe Call, Maybe ACIContent)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Call -> Maybe Call
forall a. a -> Maybe a
Just Call
call {callState = callState'}, ACIContent -> Maybe ACIContent
forall a. a -> Maybe a
Just (ACIContent -> Maybe ACIContent)
-> (CIContent 'MDRcv -> ACIContent)
-> CIContent 'MDRcv
-> Maybe ACIContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMsgDirection 'MDRcv -> CIContent 'MDRcv -> ACIContent
forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d -> CIContent d -> ACIContent
ACIContent SMsgDirection 'MDRcv
SMDRcv (CIContent 'MDRcv -> Maybe ACIContent)
-> CIContent 'MDRcv -> Maybe ACIContent
forall a b. (a -> b) -> a -> b
$ CICallStatus -> Int -> CIContent 'MDRcv
CIRcvCall CICallStatus
CISCallNegotiated Int
0)
          CallState
_ -> do
            Text -> Call -> CM ()
msgCallStateError Text
"x.call.answer" Call
call
            (Maybe Call, Maybe ACIContent) -> CM (Maybe Call, Maybe ACIContent)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Call -> Maybe Call
forall a. a -> Maybe a
Just Call
call, Maybe ACIContent
forall a. Maybe a
Nothing)

    -- to any call party
    xCallExtra :: Contact -> CallId -> CallExtraInfo -> RcvMessage -> CM ()
    xCallExtra :: Contact -> CallId -> CallExtraInfo -> RcvMessage -> CM ()
xCallExtra Contact
ct CallId
callId CallExtraInfo {WebRTCExtraInfo
rtcExtraInfo :: WebRTCExtraInfo
rtcExtraInfo :: CallExtraInfo -> WebRTCExtraInfo
rtcExtraInfo} RcvMessage
msg = do
      Contact
-> CallId
-> Text
-> RcvMessage
-> (Call -> CM (Maybe Call, Maybe ACIContent))
-> CM ()
msgCurrentCall Contact
ct CallId
callId Text
"x.call.extra" RcvMessage
msg ((Call -> CM (Maybe Call, Maybe ACIContent)) -> CM ())
-> (Call -> CM (Maybe Call, Maybe ACIContent)) -> CM ()
forall a b. (a -> b) -> a -> b
$
        \Call
call -> case Call -> CallState
callState Call
call of
          CallOfferReceived {CallType
localCallType :: CallState -> CallType
localCallType :: CallType
localCallType, CallType
peerCallType :: CallState -> CallType
peerCallType :: CallType
peerCallType, WebRTCSession
peerCallSession :: CallState -> WebRTCSession
peerCallSession :: WebRTCSession
peerCallSession, Maybe Key
sharedKey :: CallState -> Maybe Key
sharedKey :: Maybe Key
sharedKey} -> do
            -- TODO update the list of ice servers in peerCallSession
            let callState' :: CallState
callState' = CallOfferReceived {CallType
localCallType :: CallType
localCallType :: CallType
localCallType, CallType
peerCallType :: CallType
peerCallType :: CallType
peerCallType, WebRTCSession
peerCallSession :: WebRTCSession
peerCallSession :: WebRTCSession
peerCallSession, Maybe Key
sharedKey :: Maybe Key
sharedKey :: Maybe Key
sharedKey}
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> WebRTCExtraInfo -> ChatEvent
CEvtCallExtraInfo User
user Contact
ct WebRTCExtraInfo
rtcExtraInfo
            (Maybe Call, Maybe ACIContent) -> CM (Maybe Call, Maybe ACIContent)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Call -> Maybe Call
forall a. a -> Maybe a
Just Call
call {callState = callState'}, Maybe ACIContent
forall a. Maybe a
Nothing)
          CallNegotiated {CallType
localCallType :: CallState -> CallType
localCallType :: CallType
localCallType, CallType
peerCallType :: CallState -> CallType
peerCallType :: CallType
peerCallType, WebRTCSession
localCallSession :: CallState -> WebRTCSession
localCallSession :: WebRTCSession
localCallSession, WebRTCSession
peerCallSession :: CallState -> WebRTCSession
peerCallSession :: WebRTCSession
peerCallSession, Maybe Key
sharedKey :: CallState -> Maybe Key
sharedKey :: Maybe Key
sharedKey} -> do
            -- TODO update the list of ice servers in peerCallSession
            let callState' :: CallState
callState' = CallNegotiated {CallType
localCallType :: CallType
localCallType :: CallType
localCallType, CallType
peerCallType :: CallType
peerCallType :: CallType
peerCallType, WebRTCSession
localCallSession :: WebRTCSession
localCallSession :: WebRTCSession
localCallSession, WebRTCSession
peerCallSession :: WebRTCSession
peerCallSession :: WebRTCSession
peerCallSession, Maybe Key
sharedKey :: Maybe Key
sharedKey :: Maybe Key
sharedKey}
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> WebRTCExtraInfo -> ChatEvent
CEvtCallExtraInfo User
user Contact
ct WebRTCExtraInfo
rtcExtraInfo
            (Maybe Call, Maybe ACIContent) -> CM (Maybe Call, Maybe ACIContent)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Call -> Maybe Call
forall a. a -> Maybe a
Just Call
call {callState = callState'}, Maybe ACIContent
forall a. Maybe a
Nothing)
          CallState
_ -> do
            Text -> Call -> CM ()
msgCallStateError Text
"x.call.extra" Call
call
            (Maybe Call, Maybe ACIContent) -> CM (Maybe Call, Maybe ACIContent)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Call -> Maybe Call
forall a. a -> Maybe a
Just Call
call, Maybe ACIContent
forall a. Maybe a
Nothing)

    -- to any call party
    xCallEnd :: Contact -> CallId -> RcvMessage -> CM ()
    xCallEnd :: Contact -> CallId -> RcvMessage -> CM ()
xCallEnd Contact
ct CallId
callId RcvMessage
msg =
      Contact
-> CallId
-> Text
-> RcvMessage
-> (Call -> CM (Maybe Call, Maybe ACIContent))
-> CM ()
msgCurrentCall Contact
ct CallId
callId Text
"x.call.end" RcvMessage
msg ((Call -> CM (Maybe Call, Maybe ACIContent)) -> CM ())
-> (Call -> CM (Maybe Call, Maybe ACIContent)) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Call {GroupMemberId
chatItemId :: Call -> GroupMemberId
chatItemId :: GroupMemberId
chatItemId} -> do
        ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> ChatEvent
CEvtCallEnded User
user Contact
ct
        (Maybe Call
forall a. Maybe a
Nothing,) (Maybe ACIContent -> (Maybe Call, Maybe ACIContent))
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe ACIContent)
-> CM (Maybe Call, Maybe ACIContent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> User
-> Contact
-> GroupMemberId
-> WebRTCCallStatus
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe ACIContent)
callStatusItemContent User
user Contact
ct GroupMemberId
chatItemId WebRTCCallStatus
WCSDisconnected

    msgCurrentCall :: Contact -> CallId -> Text -> RcvMessage -> (Call -> CM (Maybe Call, Maybe ACIContent)) -> CM ()
    msgCurrentCall :: Contact
-> CallId
-> Text
-> RcvMessage
-> (Call -> CM (Maybe Call, Maybe ACIContent))
-> CM ()
msgCurrentCall ct :: Contact
ct@Contact {contactId :: Contact -> GroupMemberId
contactId = GroupMemberId
ctId'} CallId
callId' Text
eventName RcvMessage {GroupMemberId
msgId :: RcvMessage -> GroupMemberId
msgId :: GroupMemberId
msgId} Call -> CM (Maybe Call, Maybe ACIContent)
action = do
      TMap GroupMemberId Call
calls <- (ChatController -> TMap GroupMemberId Call)
-> ExceptT
     ChatError (ReaderT ChatController IO) (TMap GroupMemberId Call)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TMap GroupMemberId Call
currentCalls
      STM (Maybe Call)
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Call)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (GroupMemberId -> TMap GroupMemberId Call -> STM (Maybe Call)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup GroupMemberId
ctId' TMap GroupMemberId Call
calls) ExceptT ChatError (ReaderT ChatController IO) (Maybe Call)
-> (Maybe Call -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Call
Nothing -> Text -> CM ()
messageError (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
eventName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": no current call"
        Just call :: Call
call@Call {GroupMemberId
contactId :: Call -> GroupMemberId
contactId :: GroupMemberId
contactId, CallId
callId :: Call -> CallId
callId :: CallId
callId, GroupMemberId
chatItemId :: Call -> GroupMemberId
chatItemId :: GroupMemberId
chatItemId}
          | GroupMemberId
contactId GroupMemberId -> GroupMemberId -> Bool
forall a. Eq a => a -> a -> Bool
/= GroupMemberId
ctId' Bool -> Bool -> Bool
|| CallId
callId CallId -> CallId -> Bool
forall a. Eq a => a -> a -> Bool
/= CallId
callId' -> Text -> CM ()
messageError (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
eventName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": wrong contact or callId"
          | Bool
otherwise -> do
              (Maybe Call
call_, Maybe ACIContent
aciContent_) <- Call -> CM (Maybe Call, Maybe ACIContent)
action Call
call
              case Maybe Call
call_ of
                Just Call
call' -> do
                  Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Call -> Bool
isRcvInvitation Call
call') (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> IO ()
deleteCalls Connection
db User
user GroupMemberId
ctId'
                  STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> Call -> TMap GroupMemberId Call -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert GroupMemberId
ctId' Call
call' TMap GroupMemberId Call
calls
                Maybe Call
_ -> do
                  (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMemberId -> IO ()
deleteCalls Connection
db User
user GroupMemberId
ctId'
                  STM () -> CM ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> CM ()) -> STM () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> TMap GroupMemberId Call -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete GroupMemberId
ctId' TMap GroupMemberId Call
calls
              Maybe ACIContent -> (ACIContent -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ACIContent
aciContent_ ((ACIContent -> CM ()) -> CM ()) -> (ACIContent -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \ACIContent
aciContent -> do
                Maybe CITimed
timed_ <- Contact -> ACIContent -> CM (Maybe CITimed)
callTimed Contact
ct ACIContent
aciContent
                User
-> Contact
-> GroupMemberId
-> ACIContent
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe GroupMemberId
-> CM ()
updateDirectChatItemView User
user Contact
ct GroupMemberId
chatItemId ACIContent
aciContent Bool
False Bool
False Maybe CITimed
timed_ (Maybe GroupMemberId -> CM ()) -> Maybe GroupMemberId -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just GroupMemberId
msgId
                Maybe UTCTime -> (UTCTime -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Maybe CITimed
timed_ Maybe CITimed -> (CITimed -> Maybe UTCTime) -> Maybe UTCTime
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CITimed -> Maybe UTCTime
timedDeleteAt') ((UTCTime -> CM ()) -> CM ()) -> (UTCTime -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$
                  User -> (ChatRef, GroupMemberId) -> UTCTime -> CM ()
startProximateTimedItemThread User
user (ChatType -> GroupMemberId -> Maybe GroupChatScope -> ChatRef
ChatRef ChatType
CTDirect GroupMemberId
ctId' Maybe GroupChatScope
forall a. Maybe a
Nothing, GroupMemberId
chatItemId)

    msgCallStateError :: Text -> Call -> CM ()
    msgCallStateError :: Text -> Call -> CM ()
msgCallStateError Text
eventName Call {CallState
callState :: Call -> CallState
callState :: CallState
callState} =
      Text -> CM ()
messageError (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
eventName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": wrong call state " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (CallStateTag -> String
forall a. Show a => a -> String
show (CallStateTag -> String) -> CallStateTag -> String
forall a b. (a -> b) -> a -> b
$ CallState -> CallStateTag
callStateTag CallState
callState)

    associateMemberAndContact :: Contact -> GroupMember -> CM (Maybe Contact)
    associateMemberAndContact :: Contact
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
associateMemberAndContact Contact
c GroupMember
m = do
      let Contact {localDisplayName :: Contact -> Text
localDisplayName = Text
cLDN, profile :: Contact -> LocalProfile
profile = LocalProfile {Text
displayName :: Text
displayName :: LocalProfile -> Text
displayName}} = Contact
c
          GroupMember {localDisplayName :: GroupMember -> Text
localDisplayName = Text
mLDN} = GroupMember
m
      case (Text -> Text -> Maybe Int
suffixOrd Text
displayName Text
cLDN, Text -> Text -> Maybe Int
suffixOrd Text
displayName Text
mLDN) of
        (Just Int
cOrd, Just Int
mOrd)
          | Int
cOrd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
mOrd -> Contact -> Maybe Contact
forall a. a -> Maybe a
Just (Contact -> Maybe Contact)
-> CM Contact
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contact -> GroupMember -> CM Contact
associateMemberWithContact Contact
c GroupMember
m
          | Int
mOrd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
cOrd -> Contact -> Maybe Contact
forall a. a -> Maybe a
Just (Contact -> Maybe Contact)
-> CM Contact
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GroupMember -> Contact -> CM Contact
associateContactWithMember GroupMember
m Contact
c
          | Bool
otherwise -> Maybe Contact
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Contact
forall a. Maybe a
Nothing
        (Maybe Int, Maybe Int)
_ -> Maybe Contact
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Contact)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Contact
forall a. Maybe a
Nothing

    suffixOrd :: ContactName -> ContactName -> Maybe Int
    suffixOrd :: Text -> Text -> Maybe Int
suffixOrd Text
displayName Text
localDisplayName
      | Text
localDisplayName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
displayName = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
      | Bool
otherwise = case Text -> Text -> Maybe Text
T.stripPrefix (Text
displayName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_") Text
localDisplayName of
          Just Text
suffix -> String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
suffix
          Maybe Text
Nothing -> Maybe Int
forall a. Maybe a
Nothing

    associateMemberWithContact :: Contact -> GroupMember -> CM Contact
    associateMemberWithContact :: Contact -> GroupMember -> CM Contact
associateMemberWithContact Contact
c1 m2 :: GroupMember
m2@GroupMember {GroupMemberId
groupId :: GroupMember -> GroupMemberId
groupId :: GroupMemberId
groupId} = do
      (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Contact -> GroupMember -> IO ()
associateMemberWithContactRecord Connection
db User
user Contact
c1 GroupMember
m2
      GroupInfo
g <- (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo)
-> (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO GroupInfo
getGroupInfo Connection
db VersionRangeChat
vr User
user GroupMemberId
groupId
      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> GroupInfo -> GroupMember -> Contact -> ChatEvent
CEvtContactAndMemberAssociated User
user Contact
c1 GroupInfo
g GroupMember
m2 Contact
c1
      Contact -> CM Contact
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Contact
c1

    associateContactWithMember :: GroupMember -> Contact -> CM Contact
    associateContactWithMember :: GroupMember -> Contact -> CM Contact
associateContactWithMember m1 :: GroupMember
m1@GroupMember {GroupMemberId
groupId :: GroupMember -> GroupMemberId
groupId :: GroupMemberId
groupId} Contact
c2 = do
      Contact
c2' <- (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO Contact) -> CM Contact)
-> (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMember
-> Contact
-> ExceptT StoreError IO Contact
associateContactWithMemberRecord Connection
db VersionRangeChat
vr User
user GroupMember
m1 Contact
c2
      GroupInfo
g <- (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo)
-> (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO GroupInfo
getGroupInfo Connection
db VersionRangeChat
vr User
user GroupMemberId
groupId
      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> GroupInfo -> GroupMember -> Contact -> ChatEvent
CEvtContactAndMemberAssociated User
user Contact
c2 GroupInfo
g GroupMember
m1 Contact
c2'
      Contact -> CM Contact
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Contact
c2'

    saveConnInfo :: Connection -> ConnInfo -> CM (Connection, Maybe GroupInfo)
    saveConnInfo :: Connection -> ByteString -> CM (Connection, Maybe GroupInfo)
saveConnInfo Connection
activeConn ByteString
connInfo = do
      ChatMessage {VersionRangeChat
chatVRange :: forall (e :: MsgEncoding). ChatMessage e -> VersionRangeChat
chatVRange :: VersionRangeChat
chatVRange, ChatMsgEvent 'Json
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent 'Json
chatMsgEvent} <- Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage Connection
activeConn ByteString
connInfo
      Connection
conn' <- Connection
-> VersionRangeChat
-> ExceptT ChatError (ReaderT ChatController IO) Connection
updatePeerChatVRange Connection
activeConn VersionRangeChat
chatVRange
      case ChatMsgEvent 'Json
chatMsgEvent of
        XInfo Profile
p -> do
          Contact
ct <- (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO Contact) -> CM Contact)
-> (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> Connection
-> Profile
-> ExceptT StoreError IO Contact
createDirectContact Connection
db VersionRangeChat
vr User
user Connection
conn' Profile
p
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> ChatEvent
CEvtContactConnecting User
user Contact
ct
          (Connection, Maybe GroupInfo) -> CM (Connection, Maybe GroupInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Connection
conn', Maybe GroupInfo
forall a. Maybe a
Nothing)
        XGrpLinkInv GroupLinkInvitation
glInv -> do
          (GroupInfo
gInfo, GroupMember
host) <- (Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
-> CM (GroupInfo, GroupMember)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
 -> CM (GroupInfo, GroupMember))
-> (Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
-> CM (GroupInfo, GroupMember)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> Connection
-> GroupLinkInvitation
-> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupInvitedViaLink Connection
db VersionRangeChat
vr User
user Connection
conn' GroupLinkInvitation
glInv
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> ChatEvent
CEvtGroupLinkConnecting User
user GroupInfo
gInfo GroupMember
host
          (Connection, Maybe GroupInfo) -> CM (Connection, Maybe GroupInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Connection
conn', GroupInfo -> Maybe GroupInfo
forall a. a -> Maybe a
Just GroupInfo
gInfo)
        XGrpLinkReject glRjct :: GroupLinkRejection
glRjct@GroupLinkRejection {GroupRejectionReason
rejectionReason :: GroupLinkRejection -> GroupRejectionReason
rejectionReason :: GroupRejectionReason
rejectionReason} -> do
          (GroupInfo
gInfo, GroupMember
host) <- (Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
-> CM (GroupInfo, GroupMember)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
 -> CM (GroupInfo, GroupMember))
-> (Connection -> ExceptT StoreError IO (GroupInfo, GroupMember))
-> CM (GroupInfo, GroupMember)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> Connection
-> GroupLinkRejection
-> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupRejectedViaLink Connection
db VersionRangeChat
vr User
user Connection
conn' GroupLinkRejection
glRjct
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> ChatEvent
CEvtGroupLinkConnecting User
user GroupInfo
gInfo GroupMember
host
          TerminalEvent -> CM ()
toViewTE (TerminalEvent -> CM ()) -> TerminalEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupRejectionReason -> TerminalEvent
TEGroupLinkRejected User
user GroupInfo
gInfo GroupRejectionReason
rejectionReason
          (Connection, Maybe GroupInfo) -> CM (Connection, Maybe GroupInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Connection
conn', GroupInfo -> Maybe GroupInfo
forall a. a -> Maybe a
Just GroupInfo
gInfo)
        -- TODO show/log error, other events in SMP confirmation
        ChatMsgEvent 'Json
_ -> (Connection, Maybe GroupInfo) -> CM (Connection, Maybe GroupInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Connection
conn', Maybe GroupInfo
forall a. Maybe a
Nothing)

    xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
    xGrpMemNew :: GroupInfo
-> GroupMember
-> MemberInfo
-> Maybe MsgScope
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpMemNew GroupInfo
gInfo GroupMember
m memInfo :: MemberInfo
memInfo@(MemberInfo MemberId
memId GroupMemberRole
memRole Maybe ChatVersionRange
_ Profile
_) Maybe MsgScope
msgScope_ RcvMessage
msg UTCTime
brokerTs = do
      GroupMember -> GroupMemberRole -> CM ()
checkHostRole GroupMember
m GroupMemberRole
memRole
      if MemberId -> GroupMember -> Bool
sameMemberId MemberId
memId (GroupInfo -> GroupMember
membership GroupInfo
gInfo)
        then Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
forall a. Maybe a
Nothing
        else do
          (Connection -> IO (Either StoreError GroupMember))
-> CM (Either StoreError GroupMember)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO GroupMember
 -> IO (Either StoreError GroupMember))
-> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall a b. (a -> b) -> a -> b
$ Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo MemberId
memId) CM (Either StoreError GroupMember)
-> (Either StoreError GroupMember
    -> ExceptT
         ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Right unknownMember :: GroupMember
unknownMember@GroupMember {memberStatus :: GroupMember -> GroupMemberStatus
memberStatus = GroupMemberStatus
GSMemUnknown} -> do
              (GroupMember
updatedMember, GroupInfo
gInfo') <- (Connection -> ExceptT StoreError IO (GroupMember, GroupInfo))
-> CM (GroupMember, GroupInfo)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupMember, GroupInfo))
 -> CM (GroupMember, GroupInfo))
-> (Connection -> ExceptT StoreError IO (GroupMember, GroupInfo))
-> CM (GroupMember, GroupInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                GroupMember
updatedMember <- Connection
-> VersionRangeChat
-> User
-> GroupMember
-> GroupMember
-> MemberInfo
-> GroupMemberStatus
-> ExceptT StoreError IO GroupMember
updateUnknownMemberAnnounced Connection
db VersionRangeChat
vr User
user GroupMember
m GroupMember
unknownMember MemberInfo
memInfo GroupMemberStatus
initialStatus
                GroupInfo
gInfo' <- if GroupMember -> Bool
memberPending GroupMember
updatedMember
                  then IO GroupInfo -> ExceptT StoreError IO GroupInfo
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GroupInfo -> ExceptT StoreError IO GroupInfo)
-> IO GroupInfo -> ExceptT StoreError IO GroupInfo
forall a b. (a -> b) -> a -> b
$ Connection -> User -> GroupInfo -> IO GroupInfo
increaseGroupMembersRequireAttention Connection
db User
user GroupInfo
gInfo
                  else GroupInfo -> ExceptT StoreError IO GroupInfo
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupInfo
gInfo
                (GroupMember, GroupInfo)
-> ExceptT StoreError IO (GroupMember, GroupInfo)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMember
updatedMember, GroupInfo
gInfo')
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> GroupInfo
-> GroupMember
-> GroupMember
-> GroupMember
-> ChatEvent
CEvtUnknownMemberAnnounced User
user GroupInfo
gInfo' GroupMember
m GroupMember
unknownMember GroupMember
updatedMember
              GroupMember -> GroupInfo -> CM ()
memberAnnouncedToView GroupMember
updatedMember GroupInfo
gInfo'
              Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ GroupMember -> Maybe DeliveryJobScope
deliveryJobScope GroupMember
updatedMember
            Right GroupMember
_ -> Text -> CM ()
messageError Text
"x.grp.mem.new error: member already exists" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
            Left StoreError
_ -> do
              (GroupMember
newMember, GroupInfo
gInfo') <- (Connection -> ExceptT StoreError IO (GroupMember, GroupInfo))
-> CM (GroupMember, GroupInfo)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (GroupMember, GroupInfo))
 -> CM (GroupMember, GroupInfo))
-> (Connection -> ExceptT StoreError IO (GroupMember, GroupInfo))
-> CM (GroupMember, GroupInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                GroupMember
newMember <- Connection
-> User
-> GroupInfo
-> GroupMember
-> MemberInfo
-> GroupMemberCategory
-> GroupMemberStatus
-> ExceptT StoreError IO GroupMember
createNewGroupMember Connection
db User
user GroupInfo
gInfo GroupMember
m MemberInfo
memInfo GroupMemberCategory
GCPostMember GroupMemberStatus
initialStatus
                GroupInfo
gInfo' <- if GroupMember -> Bool
memberPending GroupMember
newMember
                  then IO GroupInfo -> ExceptT StoreError IO GroupInfo
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GroupInfo -> ExceptT StoreError IO GroupInfo)
-> IO GroupInfo -> ExceptT StoreError IO GroupInfo
forall a b. (a -> b) -> a -> b
$ Connection -> User -> GroupInfo -> IO GroupInfo
increaseGroupMembersRequireAttention Connection
db User
user GroupInfo
gInfo
                  else GroupInfo -> ExceptT StoreError IO GroupInfo
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupInfo
gInfo
                (GroupMember, GroupInfo)
-> ExceptT StoreError IO (GroupMember, GroupInfo)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMember
newMember, GroupInfo
gInfo')
              GroupMember -> GroupInfo -> CM ()
memberAnnouncedToView GroupMember
newMember GroupInfo
gInfo'
              Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ GroupMember -> Maybe DeliveryJobScope
deliveryJobScope GroupMember
newMember
      where
        initialStatus :: GroupMemberStatus
initialStatus = case Maybe MsgScope
msgScope_ of
          Just (MSMember MemberId
_) -> GroupMemberStatus
GSMemPendingReview
          Maybe MsgScope
_ -> GroupMemberStatus
GSMemAnnounced
        deliveryJobScope :: GroupMember -> Maybe DeliveryJobScope
deliveryJobScope GroupMember {GroupMemberId
groupMemberId :: GroupMember -> GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId, GroupMemberStatus
memberStatus :: GroupMember -> GroupMemberStatus
memberStatus :: GroupMemberStatus
memberStatus}
          | GroupMemberStatus
memberStatus GroupMemberStatus -> GroupMemberStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberStatus
GSMemPendingApproval = Maybe DeliveryJobScope
forall a. Maybe a
Nothing
          | GroupMemberStatus
memberStatus GroupMemberStatus -> GroupMemberStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberStatus
GSMemPendingReview = DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just (DeliveryJobScope -> Maybe DeliveryJobScope)
-> DeliveryJobScope -> Maybe DeliveryJobScope
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> DeliveryJobScope
DJSMemberSupport GroupMemberId
groupMemberId
          | Bool
otherwise = DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just DJSGroup {jobSpec :: DeliveryJobSpec
jobSpec = DJDeliveryJob {includePending :: Bool
includePending = Bool
False}}
        memberAnnouncedToView :: GroupMember -> GroupInfo -> CM ()
memberAnnouncedToView announcedMember :: GroupMember
announcedMember@GroupMember {GroupMemberId
groupMemberId :: GroupMember -> GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId, LocalProfile
memberProfile :: GroupMember -> LocalProfile
memberProfile :: LocalProfile
memberProfile} GroupInfo
gInfo' = do
          (GroupMember
announcedMember', Maybe GroupChatScopeInfo
scopeInfo) <- GroupMember
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (GroupMember, Maybe GroupChatScopeInfo)
getMemNewChatScope GroupMember
announcedMember
          let event :: RcvGroupEvent
event = GroupMemberId -> Profile -> RcvGroupEvent
RGEMemberAdded GroupMemberId
groupMemberId (LocalProfile -> Profile
fromLocalProfile LocalProfile
memberProfile)
          (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- User
-> ChatDirection 'CTGroup 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m) RcvMessage
msg UTCTime
brokerTs (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
event)
          ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci
          case Maybe GroupChatScopeInfo
scopeInfo of
            Just (GCSIMemberSupport Maybe GroupMember
_) -> do
              User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m) (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
RGENewMemberPendingReview) (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
brokerTs)
            Maybe GroupChatScopeInfo
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> GroupMember -> ChatEvent
CEvtJoinedGroupMemberConnecting User
user GroupInfo
gInfo' GroupMember
m GroupMember
announcedMember'
        getMemNewChatScope :: GroupMember
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (GroupMember, Maybe GroupChatScopeInfo)
getMemNewChatScope GroupMember
announcedMember = case Maybe MsgScope
msgScope_ of
          Maybe MsgScope
Nothing -> (GroupMember, Maybe GroupChatScopeInfo)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (GroupMember, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMember
announcedMember, Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing)
          Just (MSMember MemberId
_) -> do
            (GroupMember
announcedMember', GroupChatScopeInfo
scopeInfo) <- GroupMember -> CM (GroupMember, GroupChatScopeInfo)
mkMemberSupportChatInfo GroupMember
announcedMember
            (GroupMember, Maybe GroupChatScopeInfo)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (GroupMember, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMember
announcedMember', GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a. a -> Maybe a
Just GroupChatScopeInfo
scopeInfo)

    xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> CM ()
    xGrpMemIntro :: GroupInfo
-> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> CM ()
xGrpMemIntro gInfo :: GroupInfo
gInfo@GroupInfo {ChatSettings
chatSettings :: GroupInfo -> ChatSettings
chatSettings :: ChatSettings
chatSettings} m :: GroupMember
m@GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole, localDisplayName :: GroupMember -> Text
localDisplayName = Text
c} memInfo :: MemberInfo
memInfo@(MemberInfo MemberId
memId GroupMemberRole
_ Maybe ChatVersionRange
memChatVRange Profile
_) Maybe MemberRestrictions
memRestrictions = do
      case GroupMember -> GroupMemberCategory
memberCategory GroupMember
m of
        GroupMemberCategory
GCHostMember ->
          (Connection -> IO (Either StoreError GroupMember))
-> CM (Either StoreError GroupMember)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO GroupMember
 -> IO (Either StoreError GroupMember))
-> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall a b. (a -> b) -> a -> b
$ Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo MemberId
memId) CM (Either StoreError GroupMember)
-> (Either StoreError GroupMember -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Right GroupMember
_ -> Text -> CM ()
messageError Text
"x.grp.mem.intro ignored: member already exists"
            Left StoreError
_ -> do
              Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GRAdmin) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (Text -> ChatErrorType
CEGroupContactRole Text
c)
              case Maybe ChatVersionRange
memChatVRange of
                Maybe ChatVersionRange
Nothing -> Text -> CM ()
messageError Text
"x.grp.mem.intro: member chat version range incompatible"
                Just (ChatVersionRange VersionRangeChat
mcvr)
                  | VersionRangeChat -> Version ChatVersion
forall v. VersionRange v -> Version v
maxVersion VersionRangeChat
mcvr Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
groupDirectInvVersion -> do
                      SubscriptionMode
subMode <- (ChatController -> TVar SubscriptionMode) -> CM SubscriptionMode
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar SubscriptionMode
subscriptionMode
                      -- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second
                      (GroupMemberId, ByteString)
groupConnIds <- SubscriptionMode -> CM (GroupMemberId, ByteString)
createConn SubscriptionMode
subMode
                      let chatV :: Version ChatVersion
chatV = Version ChatVersion
-> (ChatVersionRange -> Version ChatVersion)
-> Maybe ChatVersionRange
-> Version ChatVersion
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (VersionRangeChat -> Version ChatVersion
forall v. VersionRange v -> Version v
minVersion VersionRangeChat
vr) (\ChatVersionRange
peerVR -> VersionRangeChat
vr VersionRangeChat -> VersionRangeChat -> Version ChatVersion
`peerConnChatVersion` ChatVersionRange -> VersionRangeChat
fromChatVRange ChatVersionRange
peerVR) Maybe ChatVersionRange
memChatVRange
                      CM GroupMember -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM GroupMember -> CM ()) -> CM GroupMember -> CM ()
forall a b. (a -> b) -> a -> b
$ (Connection -> ExceptT StoreError IO GroupMember) -> CM GroupMember
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMember)
 -> CM GroupMember)
-> (Connection -> ExceptT StoreError IO GroupMember)
-> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> GroupMember
-> Version ChatVersion
-> MemberInfo
-> Maybe MemberRestrictions
-> (GroupMemberId, ByteString)
-> SubscriptionMode
-> ExceptT StoreError IO GroupMember
createIntroReMember Connection
db User
user GroupInfo
gInfo GroupMember
m Version ChatVersion
chatV MemberInfo
memInfo Maybe MemberRestrictions
memRestrictions (GroupMemberId, ByteString)
groupConnIds SubscriptionMode
subMode
                  | Bool
otherwise -> Text -> CM ()
messageError Text
"x.grp.mem.intro: member chat version range incompatible"
        GroupMemberCategory
_ -> Text -> CM ()
messageError Text
"x.grp.mem.intro can be only sent by host member"
      where
        createConn :: SubscriptionMode -> CM (GroupMemberId, ByteString)
createConn SubscriptionMode
subMode = User
-> CommandFunction
-> Bool
-> SConnectionMode 'CMInvitation
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
forall (c :: ConnectionMode).
ConnectionModeI c =>
User
-> CommandFunction
-> Bool
-> SConnectionMode c
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
createAgentConnectionAsync User
user CommandFunction
CFCreateConnGrpMemInv (ChatSettings -> Bool
chatHasNtfs ChatSettings
chatSettings) SConnectionMode 'CMInvitation
SCMInvitation SubscriptionMode
subMode

    sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> CM ()
    sendXGrpMemInv :: GroupMemberId
-> Maybe ConnReqInvitation -> XGrpMemIntroCont -> CM ()
sendXGrpMemInv GroupMemberId
hostConnId Maybe ConnReqInvitation
directConnReq XGrpMemIntroCont {GroupMemberId
groupId :: XGrpMemIntroCont -> GroupMemberId
groupId :: GroupMemberId
groupId, GroupMemberId
groupMemberId :: XGrpMemIntroCont -> GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId, MemberId
memberId :: XGrpMemIntroCont -> MemberId
memberId :: MemberId
memberId, ConnReqInvitation
groupConnReq :: XGrpMemIntroCont -> ConnReqInvitation
groupConnReq :: ConnReqInvitation
groupConnReq} = do
      Connection
hostConn <- (Connection -> ExceptT StoreError IO Connection)
-> ExceptT ChatError (ReaderT ChatController IO) Connection
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO Connection)
 -> ExceptT ChatError (ReaderT ChatController IO) Connection)
-> (Connection -> ExceptT StoreError IO Connection)
-> ExceptT ChatError (ReaderT ChatController IO) Connection
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO Connection
getConnectionById Connection
db VersionRangeChat
vr User
user GroupMemberId
hostConnId
      let msg :: ChatMsgEvent 'Json
msg = MemberId -> IntroInvitation -> ChatMsgEvent 'Json
XGrpMemInv MemberId
memberId IntroInvitation {ConnReqInvitation
groupConnReq :: ConnReqInvitation
groupConnReq :: ConnReqInvitation
groupConnReq, Maybe ConnReqInvitation
directConnReq :: Maybe ConnReqInvitation
directConnReq :: Maybe ConnReqInvitation
directConnReq}
      ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, GroupMemberId, PQEncryption)
 -> CM ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
-> CM ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> GroupMemberId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, GroupMemberId, PQEncryption)
sendDirectMemberMessage Connection
hostConn ChatMsgEvent 'Json
msg GroupMemberId
groupId
      (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> GroupMemberId -> GroupMemberStatus -> IO ()
updateGroupMemberStatusById Connection
db GroupMemberId
userId GroupMemberId
groupMemberId GroupMemberStatus
GSMemIntroInvited

    xGrpMemInv :: GroupInfo -> GroupMember -> MemberId -> IntroInvitation -> CM ()
    xGrpMemInv :: GroupInfo -> GroupMember -> MemberId -> IntroInvitation -> CM ()
xGrpMemInv GroupInfo
gInfo GroupMember
m MemberId
memId IntroInvitation
introInv = do
      case GroupMember -> GroupMemberCategory
memberCategory GroupMember
m of
        GroupMemberCategory
GCInviteeMember ->
          (Connection -> IO (Either StoreError GroupMember))
-> CM (Either StoreError GroupMember)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO GroupMember
 -> IO (Either StoreError GroupMember))
-> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall a b. (a -> b) -> a -> b
$ Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo MemberId
memId) CM (Either StoreError GroupMember)
-> (Either StoreError GroupMember -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left StoreError
_ -> Text -> CM ()
messageError Text
"x.grp.mem.inv error: referenced member does not exist"
            Right GroupMember
reMember -> GroupInfo -> GroupMember -> ChatMsgEvent 'Json -> CM ()
forall (e :: MsgEncoding).
MsgEncodingI e =>
GroupInfo -> GroupMember -> ChatMsgEvent e -> CM ()
sendGroupMemberMessage GroupInfo
gInfo GroupMember
reMember (ChatMsgEvent 'Json -> CM ()) -> ChatMsgEvent 'Json -> CM ()
forall a b. (a -> b) -> a -> b
$ MemberInfo -> IntroInvitation -> ChatMsgEvent 'Json
XGrpMemFwd (GroupInfo -> GroupMember -> MemberInfo
memberInfo GroupInfo
gInfo GroupMember
m) IntroInvitation
introInv
        GroupMemberCategory
_ -> Text -> CM ()
messageError Text
"x.grp.mem.inv can be only sent by invitee member"

    xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> CM ()
    xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> CM ()
xGrpMemFwd gInfo :: GroupInfo
gInfo@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership, ChatSettings
chatSettings :: GroupInfo -> ChatSettings
chatSettings :: ChatSettings
chatSettings} GroupMember
m memInfo :: MemberInfo
memInfo@(MemberInfo MemberId
memId GroupMemberRole
memRole Maybe ChatVersionRange
memChatVRange Profile
_) IntroInvitation {ConnReqInvitation
groupConnReq :: IntroInvitation -> ConnReqInvitation
groupConnReq :: ConnReqInvitation
groupConnReq, Maybe ConnReqInvitation
directConnReq :: IntroInvitation -> Maybe ConnReqInvitation
directConnReq :: Maybe ConnReqInvitation
directConnReq} = do
      let GroupMember {memberId :: GroupMember -> MemberId
memberId = MemberId
membershipMemId} = GroupMember
membership
      GroupMember -> GroupMemberRole -> CM ()
checkHostRole GroupMember
m GroupMemberRole
memRole
      GroupMember
toMember <-
        (Connection -> IO (Either StoreError GroupMember))
-> CM (Either StoreError GroupMember)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO GroupMember
 -> IO (Either StoreError GroupMember))
-> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall a b. (a -> b) -> a -> b
$ Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo MemberId
memId) CM (Either StoreError GroupMember)
-> (Either StoreError GroupMember -> CM GroupMember)
-> CM GroupMember
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          -- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent
          -- the situation when member does not exist is an error
          -- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that.
          -- For now, this branch compensates for the lack of delayed message delivery.
          Left StoreError
_ -> (Connection -> ExceptT StoreError IO GroupMember) -> CM GroupMember
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMember)
 -> CM GroupMember)
-> (Connection -> ExceptT StoreError IO GroupMember)
-> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> GroupMember
-> MemberInfo
-> GroupMemberCategory
-> GroupMemberStatus
-> ExceptT StoreError IO GroupMember
createNewGroupMember Connection
db User
user GroupInfo
gInfo GroupMember
m MemberInfo
memInfo GroupMemberCategory
GCPostMember GroupMemberStatus
GSMemAnnounced
          Right GroupMember
m' -> GroupMember -> CM GroupMember
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupMember
m'
      -- TODO [knocking] separate pending statuses from GroupMemberStatus?
      -- TODO            add GSMemIntroInvitedPending, GSMemConnectedPending, etc.?
      -- TODO            keep as is? (GSMemIntroInvited has no purpose)
      let newMemberStatus :: GroupMemberStatus
newMemberStatus = if GroupMember -> Bool
memberPending GroupMember
toMember then GroupMember -> GroupMemberStatus
memberStatus GroupMember
toMember else GroupMemberStatus
GSMemIntroInvited
      (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> GroupMember -> GroupMemberStatus -> IO ()
updateGroupMemberStatus Connection
db GroupMemberId
userId GroupMember
toMember GroupMemberStatus
newMemberStatus
      SubscriptionMode
subMode <- (ChatController -> TVar SubscriptionMode) -> CM SubscriptionMode
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar SubscriptionMode
subscriptionMode
      -- [incognito] send membership incognito profile, create direct connection as incognito
      let membershipProfile :: Profile
membershipProfile = Bool -> Profile -> Profile
redactedMemberProfile Bool
allowSimplexLinks (Profile -> Profile) -> Profile -> Profile
forall a b. (a -> b) -> a -> b
$ LocalProfile -> Profile
fromLocalProfile (LocalProfile -> Profile) -> LocalProfile -> Profile
forall a b. (a -> b) -> a -> b
$ GroupMember -> LocalProfile
memberProfile GroupMember
membership
          allowSimplexLinks :: Bool
allowSimplexLinks = SGroupFeature 'GFSimplexLinks -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupInfo -> Bool
groupFeatureUserAllowed SGroupFeature 'GFSimplexLinks
SGFSimplexLinks GroupInfo
gInfo
      ByteString
dm <- ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall (e :: MsgEncoding).
MsgEncodingI e =>
ChatMsgEvent e
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
encodeConnInfo (ChatMsgEvent 'Json
 -> ExceptT ChatError (ReaderT ChatController IO) ByteString)
-> ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall a b. (a -> b) -> a -> b
$ MemberId -> Profile -> ChatMsgEvent 'Json
XGrpMemInfo MemberId
membershipMemId Profile
membershipProfile
      -- [async agent commands] no continuation needed, but commands should be asynchronous for stability
      (GroupMemberId, ByteString)
groupConnIds <- User
-> Bool
-> ConnReqInvitation
-> ByteString
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
forall (c :: ConnectionMode).
User
-> Bool
-> ConnectionRequestUri c
-> ByteString
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
joinAgentConnectionAsync User
user (ChatSettings -> Bool
chatHasNtfs ChatSettings
chatSettings) ConnReqInvitation
groupConnReq ByteString
dm SubscriptionMode
subMode
      Maybe (GroupMemberId, ByteString)
directConnIds <- Maybe ConnReqInvitation
-> (ConnReqInvitation -> CM (GroupMemberId, ByteString))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (GroupMemberId, ByteString))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe ConnReqInvitation
directConnReq ((ConnReqInvitation -> CM (GroupMemberId, ByteString))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Maybe (GroupMemberId, ByteString)))
-> (ConnReqInvitation -> CM (GroupMemberId, ByteString))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (GroupMemberId, ByteString))
forall a b. (a -> b) -> a -> b
$ \ConnReqInvitation
dcr -> User
-> Bool
-> ConnReqInvitation
-> ByteString
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
forall (c :: ConnectionMode).
User
-> Bool
-> ConnectionRequestUri c
-> ByteString
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
joinAgentConnectionAsync User
user Bool
True ConnReqInvitation
dcr ByteString
dm SubscriptionMode
subMode
      let customUserProfileId :: Maybe GroupMemberId
customUserProfileId = LocalProfile -> GroupMemberId
localProfileId (LocalProfile -> GroupMemberId)
-> Maybe LocalProfile -> Maybe GroupMemberId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GroupInfo -> Maybe LocalProfile
incognitoMembershipProfile GroupInfo
gInfo
          mcvr :: VersionRangeChat
mcvr = VersionRangeChat
-> (ChatVersionRange -> VersionRangeChat)
-> Maybe ChatVersionRange
-> VersionRangeChat
forall b a. b -> (a -> b) -> Maybe a -> b
maybe VersionRangeChat
chatInitialVRange ChatVersionRange -> VersionRangeChat
fromChatVRange Maybe ChatVersionRange
memChatVRange
          chatV :: Version ChatVersion
chatV = VersionRangeChat
vr VersionRangeChat -> VersionRangeChat -> Version ChatVersion
`peerConnChatVersion` VersionRangeChat
mcvr
      (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupMember
-> GroupMember
-> Version ChatVersion
-> VersionRangeChat
-> (GroupMemberId, ByteString)
-> Maybe (GroupMemberId, ByteString)
-> Maybe GroupMemberId
-> SubscriptionMode
-> IO ()
createIntroToMemberContact Connection
db User
user GroupMember
m GroupMember
toMember Version ChatVersion
chatV VersionRangeChat
mcvr (GroupMemberId, ByteString)
groupConnIds Maybe (GroupMemberId, ByteString)
directConnIds Maybe GroupMemberId
customUserProfileId SubscriptionMode
subMode

    xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
    xGrpMemRole :: GroupInfo
-> GroupMember
-> MemberId
-> GroupMemberRole
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpMemRole gInfo :: GroupInfo
gInfo@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} m :: GroupMember
m@GroupMember {memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
senderRole} MemberId
memId GroupMemberRole
memRole RcvMessage
msg UTCTime
brokerTs
      | MemberId
membershipMemId MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== MemberId
memId =
          let gInfo' :: GroupInfo
gInfo' = GroupInfo
gInfo {membership = membership {memberRole = memRole}}
           in GroupInfo
-> GroupMember
-> RcvGroupEvent
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
changeMemberRole GroupInfo
gInfo' GroupMember
membership (RcvGroupEvent
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> RcvGroupEvent
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ GroupMemberRole -> RcvGroupEvent
RGEUserRole GroupMemberRole
memRole
      | Bool
otherwise =
          (Connection -> IO (Either StoreError GroupMember))
-> CM (Either StoreError GroupMember)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO GroupMember
 -> IO (Either StoreError GroupMember))
-> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall a b. (a -> b) -> a -> b
$ Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo MemberId
memId) CM (Either StoreError GroupMember)
-> (Either StoreError GroupMember
    -> ExceptT
         ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Right GroupMember
member -> GroupInfo
-> GroupMember
-> RcvGroupEvent
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
changeMemberRole GroupInfo
gInfo GroupMember
member (RcvGroupEvent
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> RcvGroupEvent
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> Profile -> GroupMemberRole -> RcvGroupEvent
RGEMemberRole (GroupMember -> GroupMemberId
groupMemberId' GroupMember
member) (LocalProfile -> Profile
fromLocalProfile (LocalProfile -> Profile) -> LocalProfile -> Profile
forall a b. (a -> b) -> a -> b
$ GroupMember -> LocalProfile
memberProfile GroupMember
member) GroupMemberRole
memRole
            Left StoreError
_ -> Text -> CM ()
messageError Text
"x.grp.mem.role with unknown member ID" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
      where
        GroupMember {memberId :: GroupMember -> MemberId
memberId = MemberId
membershipMemId} = GroupMember
membership
        changeMemberRole :: GroupInfo
-> GroupMember
-> RcvGroupEvent
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
changeMemberRole GroupInfo
gInfo' member :: GroupMember
member@GroupMember {memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
fromRole} RcvGroupEvent
gEvent
          | GroupMemberRole
senderRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GRAdmin Bool -> Bool -> Bool
|| GroupMemberRole
senderRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
fromRole =
              Text -> CM ()
messageError Text
"x.grp.mem.role with insufficient member permissions" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
          | Bool
otherwise = do
              (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupMember -> GroupMemberRole -> IO ()
updateGroupMemberRole Connection
db User
user GroupMember
member GroupMemberRole
memRole
              (GroupInfo
gInfo'', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo' GroupMember
m
              (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- User
-> ChatDirection 'CTGroup 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo'' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') RcvMessage
msg UTCTime
brokerTs (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
gEvent)
              ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci
              ChatEvent -> CM ()
toView CEvtMemberRole {User
user :: User
user :: User
user, groupInfo :: GroupInfo
groupInfo = GroupInfo
gInfo'', byMember :: GroupMember
byMember = GroupMember
m', member :: GroupMember
member = GroupMember
member {memberRole = memRole}, GroupMemberRole
fromRole :: GroupMemberRole
fromRole :: GroupMemberRole
fromRole, toRole :: GroupMemberRole
toRole = GroupMemberRole
memRole}
              Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ GroupMember -> Maybe DeliveryJobScope
memberEventDeliveryScope GroupMember
member

    checkHostRole :: GroupMember -> GroupMemberRole -> CM ()
    checkHostRole :: GroupMember -> GroupMemberRole -> CM ()
checkHostRole GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole, Text
localDisplayName :: GroupMember -> Text
localDisplayName :: Text
localDisplayName} GroupMemberRole
memRole =
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GRAdmin Bool -> Bool -> Bool
|| GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
memRole) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (Text -> ChatErrorType
CEGroupContactRole Text
localDisplayName)

    xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
    xGrpMemRestrict :: GroupInfo
-> GroupMember
-> MemberId
-> MemberRestrictions
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpMemRestrict
      gInfo :: GroupInfo
gInfo@GroupInfo {membership :: GroupInfo -> GroupMember
membership = GroupMember {memberId :: GroupMember -> MemberId
memberId = MemberId
membershipMemId}}
      m :: GroupMember
m@GroupMember {memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
senderRole}
      MemberId
memId
      MemberRestrictions {MemberRestrictionStatus
restriction :: MemberRestrictionStatus
restriction :: MemberRestrictions -> MemberRestrictionStatus
restriction}
      RcvMessage
msg
      UTCTime
brokerTs
        | MemberId
membershipMemId MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== MemberId
memId = Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
forall a. Maybe a
Nothing -- ignore - XGrpMemRestrict can be sent to restricted member for efficiency
        | Bool
otherwise =
            (Connection -> IO (Either StoreError GroupMember))
-> CM (Either StoreError GroupMember)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO GroupMember
 -> IO (Either StoreError GroupMember))
-> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall a b. (a -> b) -> a -> b
$ Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo MemberId
memId) CM (Either StoreError GroupMember)
-> (Either StoreError GroupMember
    -> ExceptT
         ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Right bm :: GroupMember
bm@GroupMember {groupMemberId :: GroupMember -> GroupMemberId
groupMemberId = GroupMemberId
bmId, GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole, Bool
blockedByAdmin :: GroupMember -> Bool
blockedByAdmin :: Bool
blockedByAdmin, memberProfile :: GroupMember -> LocalProfile
memberProfile = LocalProfile
bmp}
                | Bool
blockedByAdmin Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== MemberRestrictionStatus -> Bool
mrsBlocked MemberRestrictionStatus
restriction -> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
forall a. Maybe a
Nothing
                | GroupMemberRole
senderRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GRModerator Bool -> Bool -> Bool
|| GroupMemberRole
senderRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
memberRole ->
                    Text -> CM ()
messageError Text
"x.grp.mem.restrict with insufficient member permissions" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
                | Bool
otherwise -> do
                    GroupMember
bm' <- GroupMember -> CM GroupMember
setMemberBlocked GroupMember
bm
                    GroupMember -> Bool -> CM ()
toggleNtf GroupMember
bm' (Bool -> Bool
not Bool
blocked)
                    let ciContent :: CIContent 'MDRcv
ciContent = RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent (RcvGroupEvent -> CIContent 'MDRcv)
-> RcvGroupEvent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> Profile -> Bool -> RcvGroupEvent
RGEMemberBlocked GroupMemberId
bmId (LocalProfile -> Profile
fromLocalProfile LocalProfile
bmp) Bool
blocked
                    (GroupInfo
gInfo', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo GroupMember
m
                    (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- User
-> ChatDirection 'CTGroup 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') RcvMessage
msg UTCTime
brokerTs CIContent 'MDRcv
ciContent
                    ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci
                    ChatEvent -> CM ()
toView CEvtMemberBlockedForAll {User
user :: User
user :: User
user, groupInfo :: GroupInfo
groupInfo = GroupInfo
gInfo', byMember :: GroupMember
byMember = GroupMember
m', member :: GroupMember
member = GroupMember
bm', Bool
blocked :: Bool
blocked :: Bool
blocked}
                    Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ GroupMember -> Maybe DeliveryJobScope
memberEventDeliveryScope GroupMember
bm
              Left (SEGroupMemberNotFoundByMemberId MemberId
_) -> do
                GroupMember
bm <- GroupInfo -> MemberId -> Maybe Text -> CM GroupMember
createUnknownMember GroupInfo
gInfo MemberId
memId Maybe Text
forall a. Maybe a
Nothing
                GroupMember
bm' <- GroupMember -> CM GroupMember
setMemberBlocked GroupMember
bm
                ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> GroupMember -> ChatEvent
CEvtUnknownMemberBlocked User
user GroupInfo
gInfo GroupMember
m GroupMember
bm'
                Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just DJSGroup {jobSpec :: DeliveryJobSpec
jobSpec = DJDeliveryJob {includePending :: Bool
includePending = Bool
False}}
              Left StoreError
e -> ChatError
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ChatError
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ StoreError -> ChatError
ChatErrorStore StoreError
e
        where
          setMemberBlocked :: GroupMember -> CM GroupMember
setMemberBlocked GroupMember
bm = (Connection -> IO GroupMember) -> CM GroupMember
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO GroupMember) -> CM GroupMember)
-> (Connection -> IO GroupMember) -> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> MemberRestrictionStatus
-> GroupMember
-> IO GroupMember
updateGroupMemberBlocked Connection
db User
user GroupInfo
gInfo MemberRestrictionStatus
restriction GroupMember
bm
          blocked :: Bool
blocked = MemberRestrictionStatus -> Bool
mrsBlocked MemberRestrictionStatus
restriction

    xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> CM ()
    xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> CM ()
xGrpMemCon GroupInfo
gInfo GroupMember
sendingMem MemberId
memId = do
      GroupMember
refMem <- (Connection -> ExceptT StoreError IO GroupMember) -> CM GroupMember
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMember)
 -> CM GroupMember)
-> (Connection -> ExceptT StoreError IO GroupMember)
-> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo MemberId
memId
      -- Updating vectors in separate transactions to avoid deadlocks.
      (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO ()) -> CM ())
-> (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMember
-> GroupMember
-> MemberRelation
-> ExceptT StoreError IO ()
setMemberVectorRelationConnected Connection
db GroupMember
sendingMem GroupMember
refMem MemberRelation
MRSubjectConnected
      (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO ()) -> CM ())
-> (Connection -> ExceptT StoreError IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMember
-> GroupMember
-> MemberRelation
-> ExceptT StoreError IO ()
setMemberVectorRelationConnected Connection
db GroupMember
refMem GroupMember
sendingMem MemberRelation
MRReferencedConnected

    xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> ChatMessage 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope)
    xGrpMemDel :: GroupInfo
-> GroupMember
-> MemberId
-> Bool
-> ChatMessage 'Json
-> RcvMessage
-> UTCTime
-> Bool
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpMemDel gInfo :: GroupInfo
gInfo@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} m :: GroupMember
m@GroupMember {memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
senderRole} MemberId
memId Bool
withMessages ChatMessage 'Json
chatMsg RcvMessage
msg UTCTime
brokerTs Bool
forwarded = do
      let GroupMember {memberId :: GroupMember -> MemberId
memberId = MemberId
membershipMemId} = GroupMember
membership
      if MemberId
membershipMemId MemberId -> MemberId -> Bool
forall a. Eq a => a -> a -> Bool
== MemberId
memId
        then GroupMember
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
checkRole GroupMember
membership (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ do
          User -> GroupInfo -> CM ()
deleteGroupLinkIfExists User
user GroupInfo
gInfo
          -- TODO [channels fwd] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupInfo -> Bool
isUserGrpFwdRelay GroupInfo
gInfo) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> Bool -> CM ()
deleteGroupConnections User
user GroupInfo
gInfo Bool
False
          (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> GroupMember -> GroupMemberStatus -> IO ()
updateGroupMemberStatus Connection
db GroupMemberId
userId GroupMember
membership GroupMemberStatus
GSMemRemoved
          let membership' :: GroupMember
membership' = GroupMember
membership {memberStatus = GSMemRemoved}
          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
withMessages (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo -> GroupMember -> SMsgDirection 'MDSnd -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
GroupInfo -> GroupMember -> SMsgDirection d -> CM ()
deleteMessages GroupInfo
gInfo GroupMember
membership' SMsgDirection 'MDSnd
SMDSnd
          GroupInfo -> RcvGroupEvent -> CM ()
deleteMemberItem GroupInfo
gInfo RcvGroupEvent
RGEUserDeleted
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> Bool -> ChatEvent
CEvtDeletedMemberUser User
user GroupInfo
gInfo {membership = membership'} GroupMember
m Bool
withMessages
          Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just DJSGroup {jobSpec :: DeliveryJobSpec
jobSpec = DeliveryJobSpec
DJRelayRemoved}
        else
          (Connection -> IO (Either StoreError GroupMember))
-> CM (Either StoreError GroupMember)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO GroupMember
 -> IO (Either StoreError GroupMember))
-> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall a b. (a -> b) -> a -> b
$ Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo MemberId
memId) CM (Either StoreError GroupMember)
-> (Either StoreError GroupMember
    -> ExceptT
         ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left StoreError
_ -> do
              Text -> CM ()
messageError Text
"x.grp.mem.del with unknown member ID"
              Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just DJSGroup {jobSpec :: DeliveryJobSpec
jobSpec = DJDeliveryJob {includePending :: Bool
includePending = Bool
True}}
            Right deletedMember :: GroupMember
deletedMember@GroupMember {GroupMemberId
groupMemberId :: GroupMember -> GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId, LocalProfile
memberProfile :: GroupMember -> LocalProfile
memberProfile :: LocalProfile
memberProfile, GroupMemberStatus
memberStatus :: GroupMember -> GroupMemberStatus
memberStatus :: GroupMemberStatus
memberStatus} ->
              GroupMember
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
checkRole GroupMember
deletedMember (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ do
                -- ? prohibit deleting member if it's the sender - sender should use x.grp.leave
                let shouldForward :: Bool
shouldForward = GroupInfo -> Bool
isUserGrpFwdRelay GroupInfo
gInfo Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
forwarded
                if Bool
shouldForward
                  then do
                    -- Special case: forward before deleting connection.
                    GroupMember -> CM ()
forwardToMember GroupMember
deletedMember
                    GroupMember -> Bool -> CM ()
deleteMemberConnection' GroupMember
deletedMember Bool
True
                  else GroupMember -> CM ()
deleteMemberConnection GroupMember
deletedMember
                let deliveryScope :: Maybe DeliveryJobScope
deliveryScope = GroupMember -> Maybe DeliveryJobScope
memberEventDeliveryScope GroupMember
deletedMember
                GroupInfo
gInfo' <- case Maybe DeliveryJobScope
deliveryScope of
                  -- Keep member record if it's support scope - it will be required for forwarding inside that scope.
                  Just (DJSMemberSupport GroupMemberId
_) | Bool
shouldForward -> User
-> GroupInfo -> GroupMember -> GroupMemberStatus -> CM GroupInfo
updateMemberRecordDeleted User
user GroupInfo
gInfo GroupMember
deletedMember GroupMemberStatus
GSMemRemoved
                  -- Undeleted "member connected" chat item will prevent deletion of member record.
                  Maybe DeliveryJobScope
_ -> User -> GroupInfo -> GroupMember -> CM GroupInfo
deleteOrUpdateMemberRecord User
user GroupInfo
gInfo GroupMember
deletedMember
                let wasDeleted :: Bool
wasDeleted = GroupMemberStatus
memberStatus GroupMemberStatus -> GroupMemberStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberStatus
GSMemRemoved Bool -> Bool -> Bool
|| GroupMemberStatus
memberStatus GroupMemberStatus -> GroupMemberStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberStatus
GSMemLeft
                    deletedMember' :: GroupMember
deletedMember' = GroupMember
deletedMember {memberStatus = GSMemRemoved}
                Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
withMessages (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo -> GroupMember -> SMsgDirection 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
GroupInfo -> GroupMember -> SMsgDirection d -> CM ()
deleteMessages GroupInfo
gInfo' GroupMember
deletedMember' SMsgDirection 'MDRcv
SMDRcv
                Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
wasDeleted (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo -> RcvGroupEvent -> CM ()
deleteMemberItem GroupInfo
gInfo' (RcvGroupEvent -> CM ()) -> RcvGroupEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> Profile -> RcvGroupEvent
RGEMemberDeleted GroupMemberId
groupMemberId (LocalProfile -> Profile
fromLocalProfile LocalProfile
memberProfile)
                ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User
-> GroupInfo -> GroupMember -> GroupMember -> Bool -> ChatEvent
CEvtDeletedMember User
user GroupInfo
gInfo' GroupMember
m GroupMember
deletedMember' Bool
withMessages
                Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DeliveryJobScope
deliveryScope
      where
        checkRole :: GroupMember
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
checkRole GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole} ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
a
          | GroupMemberRole
senderRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GRAdmin Bool -> Bool -> Bool
|| GroupMemberRole
senderRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
memberRole =
              Text -> CM ()
messageError Text
"x.grp.mem.del with insufficient member permissions" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
          | Bool
otherwise = ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
a
        deleteMemberItem :: GroupInfo -> RcvGroupEvent -> CM ()
deleteMemberItem GroupInfo
gi RcvGroupEvent
gEvent = do
          (GroupInfo
gi', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gi GroupMember
m
          (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- User
-> ChatDirection 'CTGroup 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gi' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') RcvMessage
msg UTCTime
brokerTs (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
gEvent)
          ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci
        deleteMessages :: MsgDirectionI d => GroupInfo -> GroupMember -> SMsgDirection d -> CM ()
        deleteMessages :: forall (d :: MsgDirection).
MsgDirectionI d =>
GroupInfo -> GroupMember -> SMsgDirection d -> CM ()
deleteMessages GroupInfo
gInfo' GroupMember
delMem SMsgDirection d
msgDir
          | SGroupFeature 'GFFullDelete -> GroupMember -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupMember -> GroupInfo -> Bool
groupFeatureMemberAllowed SGroupFeature 'GFFullDelete
SGFFullDelete GroupMember
m GroupInfo
gInfo' = User
-> GroupInfo
-> GroupMember
-> GroupMember
-> SMsgDirection d
-> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> GroupInfo
-> GroupMember
-> GroupMember
-> SMsgDirection d
-> CM ()
deleteGroupMemberCIs User
user GroupInfo
gInfo' GroupMember
delMem GroupMember
m SMsgDirection d
msgDir
          | Bool
otherwise = User -> GroupInfo -> GroupMember -> GroupMember -> CM ()
markGroupMemberCIsDeleted User
user GroupInfo
gInfo' GroupMember
delMem GroupMember
m
        forwardToMember :: GroupMember -> CM ()
        forwardToMember :: GroupMember -> CM ()
forwardToMember GroupMember
member = do
          let GroupMember {MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId} = GroupMember
m
              memberName :: Maybe Text
memberName = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ GroupMember -> Text
memberShortenedName GroupMember
m
              event :: ChatMsgEvent 'Json
event = MemberId
-> Maybe Text -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json
XGrpMsgForward MemberId
memberId Maybe Text
memberName ChatMessage 'Json
chatMsg UTCTime
brokerTs
          GroupInfo -> GroupMember -> ChatMsgEvent 'Json -> CM ()
forall (e :: MsgEncoding).
MsgEncodingI e =>
GroupInfo -> GroupMember -> ChatMsgEvent e -> CM ()
sendGroupMemberMessage GroupInfo
gInfo GroupMember
member ChatMsgEvent 'Json
event

    -- TODO [channels fwd] base on differentiation between groups and channels
    isUserGrpFwdRelay :: GroupInfo -> Bool
    isUserGrpFwdRelay :: GroupInfo -> Bool
isUserGrpFwdRelay GroupInfo {BoolDef
useRelays :: GroupInfo -> BoolDef
useRelays :: BoolDef
useRelays, membership :: GroupInfo -> GroupMember
membership = membership :: GroupMember
membership@GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole}}
      | BoolDef -> Bool
isTrue BoolDef
useRelays = GroupMember -> Bool
isMemberRelay GroupMember
membership
      | Bool
otherwise = GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
>= GroupMemberRole
GRAdmin

    xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
    xGrpLeave :: GroupInfo
-> GroupMember
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpLeave GroupInfo
gInfo GroupMember
m RcvMessage
msg UTCTime
brokerTs = do
      GroupMember -> CM ()
deleteMemberConnection GroupMember
m
      -- member record is not deleted to allow creation of "member left" chat item
      GroupInfo
gInfo' <- User
-> GroupInfo -> GroupMember -> GroupMemberStatus -> CM GroupInfo
updateMemberRecordDeleted User
user GroupInfo
gInfo GroupMember
m GroupMemberStatus
GSMemLeft
      (GroupInfo
gInfo'', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo' GroupMember
m
      (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- User
-> ChatDirection 'CTGroup 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo'' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') RcvMessage
msg UTCTime
brokerTs (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
RGEMemberLeft)
      ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci
      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> ChatEvent
CEvtLeftMember User
user GroupInfo
gInfo'' GroupMember
m' {memberStatus = GSMemLeft}
      Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ GroupMember -> Maybe DeliveryJobScope
memberEventDeliveryScope GroupMember
m

    xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
    xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
xGrpDel gInfo :: GroupInfo
gInfo@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} m :: GroupMember
m@GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole} RcvMessage
msg UTCTime
brokerTs = do
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Eq a => a -> a -> Bool
/= GroupMemberRole
GROwner) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo -> GroupMemberRole -> ChatErrorType
CEGroupUserRole GroupInfo
gInfo GroupMemberRole
GROwner
      (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> GroupMember -> GroupMemberStatus -> IO ()
updateGroupMemberStatus Connection
db GroupMemberId
userId GroupMember
membership GroupMemberStatus
GSMemGroupDeleted
      -- TODO [channels fwd] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupInfo -> Bool
isUserGrpFwdRelay GroupInfo
gInfo) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> Bool -> CM ()
deleteGroupConnections User
user GroupInfo
gInfo Bool
False
      (GroupInfo
gInfo'', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo GroupMember
m
      (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- User
-> ChatDirection 'CTGroup 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo'' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') RcvMessage
msg UTCTime
brokerTs (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
RGEGroupDeleted)
      ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci
      ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> ChatEvent
CEvtGroupDeleted User
user GroupInfo
gInfo'' {membership = membership {memberStatus = GSMemGroupDeleted}} GroupMember
m'

    xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
    xGrpInfo :: GroupInfo
-> GroupMember
-> GroupProfile
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpInfo g :: GroupInfo
g@GroupInfo {groupProfile :: GroupInfo -> GroupProfile
groupProfile = GroupProfile
p, Maybe BusinessChatInfo
businessChat :: GroupInfo -> Maybe BusinessChatInfo
businessChat :: Maybe BusinessChatInfo
businessChat} m :: GroupMember
m@GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole} GroupProfile
p' RcvMessage
msg UTCTime
brokerTs
      | GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GROwner = Text -> CM ()
messageError Text
"x.grp.info with insufficient member permissions" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
      | Bool
otherwise = do
          case Maybe BusinessChatInfo
businessChat of
            Maybe BusinessChatInfo
Nothing -> Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupProfile
p GroupProfile -> GroupProfile -> Bool
forall a. Eq a => a -> a -> Bool
== GroupProfile
p') (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
              GroupInfo
g' <- (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo)
-> (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> GroupProfile
-> ExceptT StoreError IO GroupInfo
updateGroupProfile Connection
db User
user GroupInfo
g GroupProfile
p'
              (GroupInfo
g'', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
g' GroupMember
m
              ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupInfo -> Maybe GroupMember -> ChatEvent
CEvtGroupUpdated User
user GroupInfo
g GroupInfo
g'' (GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
m')
              let cd :: ChatDirection 'CTGroup 'MDRcv
cd = GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
g'' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m'
              Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupProfile -> GroupProfile -> Bool
sameGroupProfileInfo GroupProfile
p GroupProfile
p') (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
                (ChatItem 'CTGroup 'MDRcv
ci, ChatInfo 'CTGroup
cInfo) <- User
-> ChatDirection 'CTGroup 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem 'CTGroup 'MDRcv, ChatInfo 'CTGroup)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse User
user ChatDirection 'CTGroup 'MDRcv
cd RcvMessage
msg UTCTime
brokerTs (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent (RcvGroupEvent -> CIContent 'MDRcv)
-> RcvGroupEvent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ GroupProfile -> RcvGroupEvent
RGEGroupUpdated GroupProfile
p')
                ChatInfo 'CTGroup -> ChatItem 'CTGroup 'MDRcv -> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView ChatInfo 'CTGroup
cInfo ChatItem 'CTGroup 'MDRcv
ci
              User
-> ChatDirection 'CTGroup 'MDRcv
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent 'MDRcv)
-> GroupInfo
-> GroupInfo
-> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> ChatDirection 'CTGroup d
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent d)
-> GroupInfo
-> GroupInfo
-> CM ()
createGroupFeatureChangedItems User
user ChatDirection 'CTGroup 'MDRcv
cd GroupFeature
-> GroupPreference
-> Maybe Int
-> Maybe GroupMemberRole
-> CIContent 'MDRcv
CIRcvGroupFeature GroupInfo
g GroupInfo
g''
              ExceptT ChatError (ReaderT ChatController IO) ThreadId -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) ThreadId -> CM ())
-> ExceptT ChatError (ReaderT ChatController IO) ThreadId -> CM ()
forall a b. (a -> b) -> a -> b
$ CM () -> ExceptT ChatError (ReaderT ChatController IO) ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (CM () -> ExceptT ChatError (ReaderT ChatController IO) ThreadId)
-> CM () -> ExceptT ChatError (ReaderT ChatController IO) ThreadId
forall a b. (a -> b) -> a -> b
$ NetworkRequestMode -> User -> GroupInfo -> CM ()
setGroupLinkData' NetworkRequestMode
NRMBackground User
user GroupInfo
g''
            Just BusinessChatInfo
_ -> GroupInfo -> GroupMember -> GroupPreferences -> CM ()
updateGroupPrefs_ GroupInfo
g GroupMember
m (GroupPreferences -> CM ()) -> GroupPreferences -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupPreferences -> Maybe GroupPreferences -> GroupPreferences
forall a. a -> Maybe a -> a
fromMaybe GroupPreferences
defaultBusinessGroupPrefs (Maybe GroupPreferences -> GroupPreferences)
-> Maybe GroupPreferences -> GroupPreferences
forall a b. (a -> b) -> a -> b
$ GroupProfile -> Maybe GroupPreferences
groupPreferences GroupProfile
p'
          Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeliveryJobScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just DJSGroup {jobSpec :: DeliveryJobSpec
jobSpec = DJDeliveryJob {includePending :: Bool
includePending = Bool
True}}

    xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> CM (Maybe DeliveryJobScope)
    xGrpPrefs :: GroupInfo
-> GroupMember
-> GroupPreferences
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpPrefs GroupInfo
g m :: GroupMember
m@GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole} GroupPreferences
ps'
      | GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GROwner = Text -> CM ()
messageError Text
"x.grp.prefs with insufficient member permissions" CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe DeliveryJobScope
forall a. Maybe a
Nothing
      | Bool
otherwise = GroupInfo -> GroupMember -> GroupPreferences -> CM ()
updateGroupPrefs_ GroupInfo
g GroupMember
m GroupPreferences
ps' CM ()
-> Maybe DeliveryJobScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DeliveryJobScope -> Maybe DeliveryJobScope
forall a. a -> Maybe a
Just DJSGroup {jobSpec :: DeliveryJobSpec
jobSpec = DJDeliveryJob {includePending :: Bool
includePending = Bool
True}}

    updateGroupPrefs_ :: GroupInfo -> GroupMember -> GroupPreferences -> CM ()
    updateGroupPrefs_ :: GroupInfo -> GroupMember -> GroupPreferences -> CM ()
updateGroupPrefs_ g :: GroupInfo
g@GroupInfo {groupProfile :: GroupInfo -> GroupProfile
groupProfile = GroupProfile
p} GroupMember
m GroupPreferences
ps' =
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupProfile -> Maybe GroupPreferences
groupPreferences GroupProfile
p Maybe GroupPreferences -> Maybe GroupPreferences -> Bool
forall a. Eq a => a -> a -> Bool
== GroupPreferences -> Maybe GroupPreferences
forall a. a -> Maybe a
Just GroupPreferences
ps') (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
        GroupInfo
g' <- (Connection -> IO GroupInfo) -> CM GroupInfo
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO GroupInfo) -> CM GroupInfo)
-> (Connection -> IO GroupInfo) -> CM GroupInfo
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupInfo -> GroupPreferences -> IO GroupInfo
updateGroupPreferences Connection
db User
user GroupInfo
g GroupPreferences
ps'
        ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupInfo -> Maybe GroupMember -> ChatEvent
CEvtGroupUpdated User
user GroupInfo
g GroupInfo
g' (GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
m)
        (GroupInfo
g'', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
g' GroupMember
m
        let cd :: ChatDirection 'CTGroup 'MDRcv
cd = GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
g'' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m'
        User
-> ChatDirection 'CTGroup 'MDRcv
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent 'MDRcv)
-> GroupInfo
-> GroupInfo
-> CM ()
forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> ChatDirection 'CTGroup d
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent d)
-> GroupInfo
-> GroupInfo
-> CM ()
createGroupFeatureChangedItems User
user ChatDirection 'CTGroup 'MDRcv
cd GroupFeature
-> GroupPreference
-> Maybe Int
-> Maybe GroupMemberRole
-> CIContent 'MDRcv
CIRcvGroupFeature GroupInfo
g GroupInfo
g''

    xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> UTCTime -> CM ()
    xGrpDirectInv :: GroupInfo
-> GroupMember
-> Connection
-> ConnReqInvitation
-> Maybe MsgContent
-> RcvMessage
-> UTCTime
-> CM ()
xGrpDirectInv g :: GroupInfo
g@GroupInfo {GroupMemberId
groupId :: GroupInfo -> GroupMemberId
groupId :: GroupMemberId
groupId, groupProfile :: GroupInfo -> GroupProfile
groupProfile = GroupProfile
gp} GroupMember
m mConn :: Connection
mConn@Connection {connId :: Connection -> GroupMemberId
connId = GroupMemberId
mConnId} ConnReqInvitation
connReq Maybe MsgContent
mContent_ RcvMessage
msg UTCTime
brokerTs
      | Bool -> Bool
not (SGroupFeature 'GFDirectMessages -> GroupMember -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupMember -> GroupInfo -> Bool
groupFeatureMemberAllowed SGroupFeature 'GFDirectMessages
SGFDirectMessages GroupMember
m GroupInfo
g) = Text -> CM ()
messageError Text
"x.grp.direct.inv: direct messages not allowed"
      | GroupMember -> Bool
memberBlocked GroupMember
m = Text -> CM ()
messageWarning Text
"x.grp.direct.inv: member is blocked (ignoring)"
      | Bool
otherwise = do
          let GroupMember {Maybe GroupMemberId
memberContactId :: GroupMember -> Maybe GroupMemberId
memberContactId :: Maybe GroupMemberId
memberContactId} = GroupMember
m
          SubscriptionMode
subMode <- (ChatController -> TVar SubscriptionMode) -> CM SubscriptionMode
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar SubscriptionMode
subscriptionMode
          case Maybe GroupMemberId
memberContactId of
            Maybe GroupMemberId
Nothing -> SubscriptionMode -> CM ()
createNewContact SubscriptionMode
subMode
            Just GroupMemberId
mContactId -> do
              Contact
mCt <- (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO Contact) -> CM Contact)
-> (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user GroupMemberId
mContactId
              let Contact {Maybe Connection
activeConn :: Contact -> Maybe Connection
activeConn :: Maybe Connection
activeConn, Bool
contactGrpInvSent :: Bool
contactGrpInvSent :: Contact -> Bool
contactGrpInvSent} = Contact
mCt
              Maybe Connection -> (Connection -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Connection
activeConn ((Connection -> CM ()) -> CM ()) -> (Connection -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection {GroupMemberId
connId :: Connection -> GroupMemberId
connId :: GroupMemberId
connId} ->
                if Bool
contactGrpInvSent
                  then do
                    ConnReqInvitation
ownConnReq <- (Connection -> ExceptT StoreError IO ConnReqInvitation)
-> CM ConnReqInvitation
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO ConnReqInvitation)
 -> CM ConnReqInvitation)
-> (Connection -> ExceptT StoreError IO ConnReqInvitation)
-> CM ConnReqInvitation
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId -> ExceptT StoreError IO ConnReqInvitation
getConnReqInv Connection
db GroupMemberId
connId
                    -- in case both members sent x.grp.direct.inv before receiving other's for processing,
                    -- only the one who received greater connReq joins, the other creates items and waits for confirmation
                    if ConnReqInvitation -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ConnReqInvitation
connReq ByteString -> ByteString -> Bool
forall a. Ord a => a -> a -> Bool
> ConnReqInvitation -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ConnReqInvitation
ownConnReq
                      then SubscriptionMode -> Contact -> CM ()
joinExistingContact SubscriptionMode
subMode Contact
mCt
                      else Contact -> GroupMember -> CM ()
createItems Contact
mCt GroupMember
m
                  else SubscriptionMode -> Contact -> CM ()
joinExistingContact SubscriptionMode
subMode Contact
mCt
      where
        groupDirectInv :: GroupDirectInvitation
groupDirectInv =
          GroupDirectInvitation {
            groupDirectInvLink :: ConnReqInvitation
groupDirectInvLink = ConnReqInvitation
connReq,
            fromGroupId_ :: Maybe GroupMemberId
fromGroupId_ = GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just GroupMemberId
groupId,
            fromGroupMemberId_ :: Maybe GroupMemberId
fromGroupMemberId_ = GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just (GroupMember -> GroupMemberId
groupMemberId' GroupMember
m),
            fromGroupMemberConnId_ :: Maybe GroupMemberId
fromGroupMemberConnId_ = GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just GroupMemberId
mConnId,
            groupDirectInvStartedConnection :: Bool
groupDirectInvStartedConnection = BoolDef -> Bool
isTrue (BoolDef -> Bool) -> BoolDef -> Bool
forall a b. (a -> b) -> a -> b
$ User -> BoolDef
autoAcceptMemberContacts User
user
          }
        joinExistingContact :: SubscriptionMode -> Contact -> CM ()
joinExistingContact SubscriptionMode
subMode mCt :: Contact
mCt@Contact {contactId :: Contact -> GroupMemberId
contactId = GroupMemberId
mContactId}
          | BoolDef -> Bool
isTrue (User -> BoolDef
autoAcceptMemberContacts User
user) = do
              (GroupMemberId
cmdId, ByteString
acId) <- SubscriptionMode -> CM (GroupMemberId, ByteString)
joinConn SubscriptionMode
subMode
              Contact
mCt' <- (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO Contact) -> CM Contact)
-> (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                Connection
-> User
-> Contact
-> GroupDirectInvitation
-> ExceptT StoreError IO ()
updateMemberContactInvited Connection
db User
user Contact
mCt GroupDirectInvitation
groupDirectInv
                ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ())
-> ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ IO GroupMemberId -> ExceptT StoreError IO GroupMemberId
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GroupMemberId -> ExceptT StoreError IO GroupMemberId)
-> IO GroupMemberId -> ExceptT StoreError IO GroupMemberId
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> ByteString
-> Maybe GroupMemberId
-> GroupInfo
-> Connection
-> ConnStatus
-> GroupMemberId
-> SubscriptionMode
-> IO GroupMemberId
createMemberContactConn Connection
db User
user ByteString
acId (GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just GroupMemberId
cmdId) GroupInfo
g Connection
mConn ConnStatus
ConnJoined GroupMemberId
mContactId SubscriptionMode
subMode
                Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user GroupMemberId
mContactId
              Contact -> CM ()
securityCodeChanged Contact
mCt'
              Contact -> GroupMember -> CM ()
createItems Contact
mCt' GroupMember
m
          | Bool
otherwise = do
              ByteString
acId <- (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ByteString)
 -> ExceptT ChatError (ReaderT ChatController IO) ByteString)
-> (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> GroupMemberId
-> Bool
-> ConnReqInvitation
-> PQSupport
-> ExceptT AgentErrorType IO ByteString
forall (c :: ConnectionMode).
AgentClient
-> GroupMemberId
-> Bool
-> ConnectionRequestUri c
-> PQSupport
-> ExceptT AgentErrorType IO ByteString
prepareConnectionToJoin AgentClient
a (User -> GroupMemberId
aUserId User
user) Bool
True ConnReqInvitation
connReq PQSupport
PQSupportOff
              Contact
mCt' <- (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO Contact) -> CM Contact)
-> (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                Connection
-> User
-> Contact
-> GroupDirectInvitation
-> ExceptT StoreError IO ()
updateMemberContactInvited Connection
db User
user Contact
mCt GroupDirectInvitation
groupDirectInv
                ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ())
-> ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ IO GroupMemberId -> ExceptT StoreError IO GroupMemberId
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GroupMemberId -> ExceptT StoreError IO GroupMemberId)
-> IO GroupMemberId -> ExceptT StoreError IO GroupMemberId
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> ByteString
-> Maybe GroupMemberId
-> GroupInfo
-> Connection
-> ConnStatus
-> GroupMemberId
-> SubscriptionMode
-> IO GroupMemberId
createMemberContactConn Connection
db User
user ByteString
acId Maybe GroupMemberId
forall a. Maybe a
Nothing GroupInfo
g Connection
mConn ConnStatus
ConnPrepared GroupMemberId
mContactId SubscriptionMode
subMode
                Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user GroupMemberId
mContactId
              Contact -> CM ()
securityCodeChanged Contact
mCt'
              User
-> ChatDirection 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
mCt') (RcvDirectEvent -> CIContent 'MDRcv
CIRcvDirectEvent (RcvDirectEvent -> CIContent 'MDRcv)
-> RcvDirectEvent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ GroupProfile -> RcvDirectEvent
RDEGroupInvLinkReceived GroupProfile
gp) Maybe UTCTime
forall a. Maybe a
Nothing
              Contact -> GroupMember -> CM ()
createItems Contact
mCt' GroupMember
m
        createNewContact :: SubscriptionMode -> CM ()
createNewContact SubscriptionMode
subMode
          | BoolDef -> Bool
isTrue (User -> BoolDef
autoAcceptMemberContacts User
user) = do
              (GroupMemberId
cmdId, ByteString
acId) <- SubscriptionMode -> CM (GroupMemberId, ByteString)
joinConn SubscriptionMode
subMode
              -- [incognito] reuse membership incognito profile
              (Contact
mCt, GroupMember
m') <- (Connection -> ExceptT StoreError IO (Contact, GroupMember))
-> CM (Contact, GroupMember)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Contact, GroupMember))
 -> CM (Contact, GroupMember))
-> (Connection -> ExceptT StoreError IO (Contact, GroupMember))
-> CM (Contact, GroupMember)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                (GroupMemberId
mContactId, GroupMember
m') <- IO (GroupMemberId, GroupMember)
-> ExceptT StoreError IO (GroupMemberId, GroupMember)
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (GroupMemberId, GroupMember)
 -> ExceptT StoreError IO (GroupMemberId, GroupMember))
-> IO (GroupMemberId, GroupMember)
-> ExceptT StoreError IO (GroupMemberId, GroupMember)
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupDirectInvitation
-> IO (GroupMemberId, GroupMember)
createMemberContactInvited Connection
db User
user GroupInfo
g GroupMember
m GroupDirectInvitation
groupDirectInv
                ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ())
-> ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ IO GroupMemberId -> ExceptT StoreError IO GroupMemberId
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GroupMemberId -> ExceptT StoreError IO GroupMemberId)
-> IO GroupMemberId -> ExceptT StoreError IO GroupMemberId
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> ByteString
-> Maybe GroupMemberId
-> GroupInfo
-> Connection
-> ConnStatus
-> GroupMemberId
-> SubscriptionMode
-> IO GroupMemberId
createMemberContactConn Connection
db User
user ByteString
acId (GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just GroupMemberId
cmdId) GroupInfo
g Connection
mConn ConnStatus
ConnJoined GroupMemberId
mContactId SubscriptionMode
subMode
                Contact
mCt <- Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user GroupMemberId
mContactId
                (Contact, GroupMember)
-> ExceptT StoreError IO (Contact, GroupMember)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact
mCt, GroupMember
m')
              User
-> ChatDirection 'CTDirect 'MDSnd
-> CIContent 'MDSnd
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectSnd Contact
mCt) CIContent 'MDSnd
CIChatBanner (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
epochStart)
              Contact -> GroupMember -> CM ()
createItems Contact
mCt GroupMember
m'
          | Bool
otherwise = do
              ByteString
acId <- (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ByteString)
 -> ExceptT ChatError (ReaderT ChatController IO) ByteString)
-> (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> GroupMemberId
-> Bool
-> ConnReqInvitation
-> PQSupport
-> ExceptT AgentErrorType IO ByteString
forall (c :: ConnectionMode).
AgentClient
-> GroupMemberId
-> Bool
-> ConnectionRequestUri c
-> PQSupport
-> ExceptT AgentErrorType IO ByteString
prepareConnectionToJoin AgentClient
a (User -> GroupMemberId
aUserId User
user) Bool
True ConnReqInvitation
connReq PQSupport
PQSupportOff
              (Contact
mCt, GroupMember
m') <- (Connection -> ExceptT StoreError IO (Contact, GroupMember))
-> CM (Contact, GroupMember)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Contact, GroupMember))
 -> CM (Contact, GroupMember))
-> (Connection -> ExceptT StoreError IO (Contact, GroupMember))
-> CM (Contact, GroupMember)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                (GroupMemberId
mContactId, GroupMember
m') <- IO (GroupMemberId, GroupMember)
-> ExceptT StoreError IO (GroupMemberId, GroupMember)
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (GroupMemberId, GroupMember)
 -> ExceptT StoreError IO (GroupMemberId, GroupMember))
-> IO (GroupMemberId, GroupMember)
-> ExceptT StoreError IO (GroupMemberId, GroupMember)
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupDirectInvitation
-> IO (GroupMemberId, GroupMember)
createMemberContactInvited Connection
db User
user GroupInfo
g GroupMember
m GroupDirectInvitation
groupDirectInv
                ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ())
-> ExceptT StoreError IO GroupMemberId -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ IO GroupMemberId -> ExceptT StoreError IO GroupMemberId
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GroupMemberId -> ExceptT StoreError IO GroupMemberId)
-> IO GroupMemberId -> ExceptT StoreError IO GroupMemberId
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> ByteString
-> Maybe GroupMemberId
-> GroupInfo
-> Connection
-> ConnStatus
-> GroupMemberId
-> SubscriptionMode
-> IO GroupMemberId
createMemberContactConn Connection
db User
user ByteString
acId Maybe GroupMemberId
forall a. Maybe a
Nothing GroupInfo
g Connection
mConn ConnStatus
ConnPrepared GroupMemberId
mContactId SubscriptionMode
subMode
                Contact
mCt <- Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user GroupMemberId
mContactId
                (Contact, GroupMember)
-> ExceptT StoreError IO (Contact, GroupMember)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact
mCt, GroupMember
m')
              User
-> ChatDirection 'CTDirect 'MDSnd
-> CIContent 'MDSnd
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectSnd Contact
mCt) CIContent 'MDSnd
CIChatBanner (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
epochStart)
              User
-> ChatDirection 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
mCt) (RcvDirectEvent -> CIContent 'MDRcv
CIRcvDirectEvent (RcvDirectEvent -> CIContent 'MDRcv)
-> RcvDirectEvent -> CIContent 'MDRcv
forall a b. (a -> b) -> a -> b
$ GroupProfile -> RcvDirectEvent
RDEGroupInvLinkReceived GroupProfile
gp) Maybe UTCTime
forall a. Maybe a
Nothing
              Contact -> GroupMember -> CM ()
createItems Contact
mCt GroupMember
m'
        joinConn :: SubscriptionMode -> CM (GroupMemberId, ByteString)
joinConn SubscriptionMode
subMode = do
          -- [incognito] send membership incognito profile
          let p :: Profile
p = User -> Maybe Profile -> Maybe Contact -> Bool -> Profile
userProfileDirect User
user (LocalProfile -> Profile
fromLocalProfile (LocalProfile -> Profile) -> Maybe LocalProfile -> Maybe Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GroupInfo -> Maybe LocalProfile
incognitoMembershipProfile GroupInfo
g) Maybe Contact
forall a. Maybe a
Nothing Bool
True
          -- TODO PQ should negotitate contact connection with PQSupportOn? (use encodeConnInfoPQ)
          ByteString
dm <- ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall (e :: MsgEncoding).
MsgEncodingI e =>
ChatMsgEvent e
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
encodeConnInfo (ChatMsgEvent 'Json
 -> ExceptT ChatError (ReaderT ChatController IO) ByteString)
-> ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall a b. (a -> b) -> a -> b
$ Profile -> ChatMsgEvent 'Json
XInfo Profile
p
          User
-> Bool
-> ConnReqInvitation
-> ByteString
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
forall (c :: ConnectionMode).
User
-> Bool
-> ConnectionRequestUri c
-> ByteString
-> SubscriptionMode
-> CM (GroupMemberId, ByteString)
joinAgentConnectionAsync User
user Bool
True ConnReqInvitation
connReq ByteString
dm SubscriptionMode
subMode
        createItems :: Contact -> GroupMember -> CM ()
createItems Contact
mCt' GroupMember
m' = do
          (GroupInfo
g', GroupMember
m'', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
g GroupMember
m'
          User
-> ChatDirection 'CTGroup 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
g' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m'') (RcvGroupEvent -> CIContent 'MDRcv
CIRcvGroupEvent RcvGroupEvent
RGEMemberCreatedContact) Maybe UTCTime
forall a. Maybe a
Nothing
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> GroupInfo -> GroupMember -> ChatEvent
CEvtNewMemberContactReceivedInv User
user Contact
mCt' GroupInfo
g' GroupMember
m''
          Maybe MsgContent -> (MsgContent -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe MsgContent
mContent_ ((MsgContent -> CM ()) -> CM ()) -> (MsgContent -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \MsgContent
mc -> do
            (ChatItem 'CTDirect 'MDRcv
ci, ChatInfo 'CTDirect
cInfo) <- User
-> ChatDirection 'CTDirect 'MDRcv
-> RcvMessage
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> CM (ChatItem 'CTDirect 'MDRcv, ChatInfo 'CTDirect)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
mCt') RcvMessage
msg UTCTime
brokerTs (MsgContent -> CIContent 'MDRcv
CIRcvMsgContent MsgContent
mc, MsgContent -> (Text, Maybe MarkdownList)
msgContentTexts MsgContent
mc)
            ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [SChatType 'CTDirect
-> SMsgDirection 'MDRcv
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDRcv
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDRcv
SMDRcv ChatInfo 'CTDirect
cInfo ChatItem 'CTDirect 'MDRcv
ci]

    securityCodeChanged :: Contact -> CM ()
    securityCodeChanged :: Contact -> CM ()
securityCodeChanged Contact
ct = do
      TerminalEvent -> CM ()
toViewTE (TerminalEvent -> CM ()) -> TerminalEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> TerminalEvent
TEContactVerificationReset User
user Contact
ct
      User
-> ChatDirection 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> CM ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct) (RcvConnEvent -> CIContent 'MDRcv
CIRcvConnEvent RcvConnEvent
RCEVerificationCodeReset) Maybe UTCTime
forall a. Maybe a
Nothing

    xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> UTCTime -> CM ()
    xGrpMsgForward :: GroupInfo
-> GroupMember
-> MemberId
-> Maybe Text
-> ChatMessage 'Json
-> UTCTime
-> UTCTime
-> CM ()
xGrpMsgForward GroupInfo
gInfo m :: GroupMember
m@GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole, Text
localDisplayName :: GroupMember -> Text
localDisplayName :: Text
localDisplayName} MemberId
memberId Maybe Text
memberName ChatMessage 'Json
chatMsg UTCTime
msgTs UTCTime
brokerTs = do
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GRAdmin) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (Text -> ChatErrorType
CEGroupContactRole Text
localDisplayName)
      (Connection -> IO (Either StoreError GroupMember))
-> CM (Either StoreError GroupMember)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO GroupMember
 -> IO (Either StoreError GroupMember))
-> ExceptT StoreError IO GroupMember
-> IO (Either StoreError GroupMember)
forall a b. (a -> b) -> a -> b
$ Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo MemberId
memberId) CM (Either StoreError GroupMember)
-> (Either StoreError GroupMember -> CM ()) -> CM ()
forall a b.
ExceptT ChatError (ReaderT ChatController IO) a
-> (a -> ExceptT ChatError (ReaderT ChatController IO) b)
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right GroupMember
author -> GroupMember -> CM ()
processForwardedMsg GroupMember
author
        Left (SEGroupMemberNotFoundByMemberId MemberId
_) -> do
          GroupMember
unknownAuthor <- GroupInfo -> MemberId -> Maybe Text -> CM GroupMember
createUnknownMember GroupInfo
gInfo MemberId
memberId Maybe Text
memberName
          ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> GroupInfo -> GroupMember -> GroupMember -> ChatEvent
CEvtUnknownMemberCreated User
user GroupInfo
gInfo GroupMember
m GroupMember
unknownAuthor
          GroupMember -> CM ()
processForwardedMsg GroupMember
unknownAuthor
        Left StoreError
e -> ChatError -> CM ()
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> CM ()) -> ChatError -> CM ()
forall a b. (a -> b) -> a -> b
$ StoreError -> ChatError
ChatErrorStore StoreError
e
      where
        -- ! see isForwardedGroupMsg: forwarded group events should include msgId to be deduplicated
        processForwardedMsg :: GroupMember -> CM ()
        processForwardedMsg :: GroupMember -> CM ()
processForwardedMsg GroupMember
author = do
          let body :: ByteString
body = ChatMessage 'Json -> ByteString
forall (e :: MsgEncoding).
MsgEncodingI e =>
ChatMessage e -> ByteString
chatMsgToBody ChatMessage 'Json
chatMsg
          Maybe RcvMessage
rcvMsg_ <- User
-> GroupInfo
-> GroupMember
-> GroupMember
-> ByteString
-> ChatMessage 'Json
-> UTCTime
-> CM (Maybe RcvMessage)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupInfo
-> GroupMember
-> GroupMember
-> ByteString
-> ChatMessage e
-> UTCTime
-> CM (Maybe RcvMessage)
saveGroupFwdRcvMsg User
user GroupInfo
gInfo GroupMember
m GroupMember
author ByteString
body ChatMessage 'Json
chatMsg UTCTime
brokerTs
          Maybe RcvMessage -> (RcvMessage -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe RcvMessage
rcvMsg_ ((RcvMessage -> CM ()) -> CM ()) -> (RcvMessage -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \rcvMsg :: RcvMessage
rcvMsg@RcvMessage {chatMsgEvent :: RcvMessage -> AChatMsgEvent
chatMsgEvent = ACME SMsgEncoding e
_ ChatMsgEvent e
event} -> case ChatMsgEvent e
event of
            XMsgNew MsgContainer
mc -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMember
-> Maybe MsgScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
memberCanSend GroupMember
author Maybe MsgScope
scope (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ (Maybe DeliveryJobScope
-> Maybe DeliveryJobScope -> Maybe DeliveryJobScope
forall a b. a -> b -> a
const Maybe DeliveryJobScope
forall a. Maybe a
Nothing) (Maybe DeliveryJobScope -> Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GroupInfo
-> GroupMember
-> MsgContainer
-> RcvMessage
-> UTCTime
-> Bool
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
newGroupContentMessage GroupInfo
gInfo GroupMember
author MsgContainer
mc RcvMessage
rcvMsg UTCTime
msgTs Bool
True
              where ExtMsgContent {Maybe MsgScope
scope :: ExtMsgContent -> Maybe MsgScope
scope :: Maybe MsgScope
scope} = MsgContainer -> ExtMsgContent
mcExtMsgContent MsgContainer
mc
            -- file description is always allowed, to allow sending files to support scope
            XMsgFileDescr SharedMsgId
sharedMsgId FileDescr
fileDescr -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> SharedMsgId
-> FileDescr
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMessageFileDescription GroupInfo
gInfo GroupMember
author SharedMsgId
sharedMsgId FileDescr
fileDescr
            XMsgUpdate SharedMsgId
sharedMsgId MsgContent
mContent Map Text MsgMention
mentions Maybe Int
ttl Maybe Bool
live Maybe MsgScope
msgScope -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMember
-> Maybe MsgScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
memberCanSend GroupMember
author Maybe MsgScope
msgScope (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall a b. (a -> b) -> a -> b
$ (Maybe DeliveryJobScope
-> Maybe DeliveryJobScope -> Maybe DeliveryJobScope
forall a b. a -> b -> a
const Maybe DeliveryJobScope
forall a. Maybe a
Nothing) (Maybe DeliveryJobScope -> Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GroupInfo
-> GroupMember
-> SharedMsgId
-> MsgContent
-> Map Text MsgMention
-> Maybe MsgScope
-> RcvMessage
-> UTCTime
-> Maybe Int
-> Maybe Bool
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMessageUpdate GroupInfo
gInfo GroupMember
author SharedMsgId
sharedMsgId MsgContent
mContent Map Text MsgMention
mentions Maybe MsgScope
msgScope RcvMessage
rcvMsg UTCTime
msgTs Maybe Int
ttl Maybe Bool
live
            XMsgDel SharedMsgId
sharedMsgId Maybe MemberId
memId Maybe MsgScope
scope_ -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> SharedMsgId
-> Maybe MemberId
-> Maybe MsgScope
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMessageDelete GroupInfo
gInfo GroupMember
author SharedMsgId
sharedMsgId Maybe MemberId
memId Maybe MsgScope
scope_ RcvMessage
rcvMsg UTCTime
msgTs
            XMsgReact SharedMsgId
sharedMsgId (Just MemberId
memId) Maybe MsgScope
scope_ MsgReaction
reaction Bool
add -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> SharedMsgId
-> MemberId
-> Maybe MsgScope
-> MsgReaction
-> Bool
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
groupMsgReaction GroupInfo
gInfo GroupMember
author SharedMsgId
sharedMsgId MemberId
memId Maybe MsgScope
scope_ MsgReaction
reaction Bool
add RcvMessage
rcvMsg UTCTime
msgTs
            XFileCancel SharedMsgId
sharedMsgId -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> SharedMsgId
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xFileCancelGroup GroupInfo
gInfo GroupMember
author SharedMsgId
sharedMsgId
            XInfo Profile
p -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> Profile
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xInfoMember GroupInfo
gInfo GroupMember
author Profile
p UTCTime
msgTs
            XGrpMemNew MemberInfo
memInfo Maybe MsgScope
msgScope -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> MemberInfo
-> Maybe MsgScope
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpMemNew GroupInfo
gInfo GroupMember
author MemberInfo
memInfo Maybe MsgScope
msgScope RcvMessage
rcvMsg UTCTime
msgTs
            XGrpMemRole MemberId
memId GroupMemberRole
memRole -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> MemberId
-> GroupMemberRole
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpMemRole GroupInfo
gInfo GroupMember
author MemberId
memId GroupMemberRole
memRole RcvMessage
rcvMsg UTCTime
msgTs
            XGrpMemDel MemberId
memId Bool
withMessages -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> MemberId
-> Bool
-> ChatMessage 'Json
-> RcvMessage
-> UTCTime
-> Bool
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpMemDel GroupInfo
gInfo GroupMember
author MemberId
memId Bool
withMessages ChatMessage 'Json
chatMsg RcvMessage
rcvMsg UTCTime
msgTs Bool
True
            ChatMsgEvent e
XGrpLeave -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpLeave GroupInfo
gInfo GroupMember
author RcvMessage
rcvMsg UTCTime
msgTs
            ChatMsgEvent e
XGrpDel -> CM () -> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
xGrpDel GroupInfo
gInfo GroupMember
author RcvMessage
rcvMsg UTCTime
msgTs
            XGrpInfo GroupProfile
p' -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> GroupProfile
-> RcvMessage
-> UTCTime
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpInfo GroupInfo
gInfo GroupMember
author GroupProfile
p' RcvMessage
rcvMsg UTCTime
msgTs
            XGrpPrefs GroupPreferences
ps' -> ExceptT
  ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
 -> CM ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
-> CM ()
forall a b. (a -> b) -> a -> b
$ GroupInfo
-> GroupMember
-> GroupPreferences
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe DeliveryJobScope)
xGrpPrefs GroupInfo
gInfo GroupMember
author GroupPreferences
ps'
            ChatMsgEvent e
_ -> Text -> CM ()
messageError (Text -> CM ()) -> Text -> CM ()
forall a b. (a -> b) -> a -> b
$ Text
"x.grp.msg.forward: unsupported forwarded event " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (CMEventTag e -> String
forall a. Show a => a -> String
show (CMEventTag e -> String) -> CMEventTag e -> String
forall a b. (a -> b) -> a -> b
$ ChatMsgEvent e -> CMEventTag e
forall (e :: MsgEncoding). ChatMsgEvent e -> CMEventTag e
toCMEventTag ChatMsgEvent e
event)

    createUnknownMember :: GroupInfo -> MemberId -> Maybe ContactName -> CM GroupMember
    createUnknownMember :: GroupInfo -> MemberId -> Maybe Text -> CM GroupMember
createUnknownMember GroupInfo
gInfo MemberId
memberId Maybe Text
memberName = do
      let name :: Text
name = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (MemberId -> Text
nameFromMemberId MemberId
memberId) Maybe Text
memberName
      (Connection -> ExceptT StoreError IO GroupMember) -> CM GroupMember
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMember)
 -> CM GroupMember)
-> (Connection -> ExceptT StoreError IO GroupMember)
-> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> MemberId
-> Text
-> ExceptT StoreError IO GroupMember
createNewUnknownGroupMember Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo MemberId
memberId Text
name

    directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
    directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
directMsgReceived Contact
ct conn :: Connection
conn@Connection {GroupMemberId
connId :: Connection -> GroupMemberId
connId :: GroupMemberId
connId} MsgMeta
msgMeta NonEmpty MsgReceipt
msgRcpts = do
      ChatDirection 'CTDirect 'MDRcv -> MsgMeta -> CM ()
forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv -> MsgMeta -> CM ()
checkIntegrityCreateItem (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct) MsgMeta
msgMeta CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      NonEmpty MsgReceipt -> (MsgReceipt -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty MsgReceipt
msgRcpts ((MsgReceipt -> CM ()) -> CM ()) -> (MsgReceipt -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \MsgReceipt {GroupMemberId
agentMsgId :: GroupMemberId
agentMsgId :: MsgReceipt -> GroupMemberId
agentMsgId, MsgReceiptStatus
msgRcptStatus :: MsgReceiptStatus
msgRcptStatus :: MsgReceipt -> MsgReceiptStatus
msgRcptStatus} -> do
        (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> MsgDeliveryStatus 'MDSnd
-> IO ()
updateSndMsgDeliveryStatus Connection
db GroupMemberId
connId GroupMemberId
agentMsgId (MsgDeliveryStatus 'MDSnd -> IO ())
-> MsgDeliveryStatus 'MDSnd -> IO ()
forall a b. (a -> b) -> a -> b
$ MsgReceiptStatus -> MsgDeliveryStatus 'MDSnd
MDSSndRcvd MsgReceiptStatus
msgRcptStatus
        Contact -> Connection -> GroupMemberId -> CIStatus 'MDSnd -> CM ()
updateDirectItemStatus Contact
ct Connection
conn GroupMemberId
agentMsgId (CIStatus 'MDSnd -> CM ()) -> CIStatus 'MDSnd -> CM ()
forall a b. (a -> b) -> a -> b
$ MsgReceiptStatus -> SndCIStatusProgress -> CIStatus 'MDSnd
CISSndRcvd MsgReceiptStatus
msgRcptStatus SndCIStatusProgress
SSPComplete

    groupMsgReceived :: GroupInfo -> GroupMember -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
    groupMsgReceived :: GroupInfo
-> GroupMember
-> Connection
-> MsgMeta
-> NonEmpty MsgReceipt
-> CM ()
groupMsgReceived GroupInfo
gInfo GroupMember
m conn :: Connection
conn@Connection {GroupMemberId
connId :: Connection -> GroupMemberId
connId :: GroupMemberId
connId} MsgMeta
msgMeta NonEmpty MsgReceipt
msgRcpts = do
      (GroupInfo
gInfo', GroupMember
m', Maybe GroupChatScopeInfo
scopeInfo) <- GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo GroupMember
m
      ChatDirection 'CTGroup 'MDRcv -> MsgMeta -> CM ()
forall (c :: ChatType).
ChatTypeI c =>
ChatDirection c 'MDRcv -> MsgMeta -> CM ()
checkIntegrityCreateItem (GroupInfo
-> Maybe GroupChatScopeInfo
-> GroupMember
-> ChatDirection 'CTGroup 'MDRcv
CDGroupRcv GroupInfo
gInfo' Maybe GroupChatScopeInfo
scopeInfo GroupMember
m') MsgMeta
msgMeta CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
_ -> () -> CM ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      NonEmpty MsgReceipt -> (MsgReceipt -> CM ()) -> CM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty MsgReceipt
msgRcpts ((MsgReceipt -> CM ()) -> CM ()) -> (MsgReceipt -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \MsgReceipt {GroupMemberId
agentMsgId :: MsgReceipt -> GroupMemberId
agentMsgId :: GroupMemberId
agentMsgId, MsgReceiptStatus
msgRcptStatus :: MsgReceipt -> MsgReceiptStatus
msgRcptStatus :: MsgReceiptStatus
msgRcptStatus} -> do
        (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMemberId
-> GroupMemberId
-> MsgDeliveryStatus 'MDSnd
-> IO ()
updateSndMsgDeliveryStatus Connection
db GroupMemberId
connId GroupMemberId
agentMsgId (MsgDeliveryStatus 'MDSnd -> IO ())
-> MsgDeliveryStatus 'MDSnd -> IO ()
forall a b. (a -> b) -> a -> b
$ MsgReceiptStatus -> MsgDeliveryStatus 'MDSnd
MDSSndRcvd MsgReceiptStatus
msgRcptStatus
        GroupInfo
-> GroupMember
-> Connection
-> GroupMemberId
-> GroupSndStatus
-> Maybe Bool
-> CM ()
updateGroupItemsStatus GroupInfo
gInfo' GroupMember
m' Connection
conn GroupMemberId
agentMsgId (MsgReceiptStatus -> GroupSndStatus
GSSRcvd MsgReceiptStatus
msgRcptStatus) Maybe Bool
forall a. Maybe a
Nothing

    -- Searches chat items for many agent message IDs and updates their status
    updateDirectItemsStatusMsgs :: Contact -> Connection -> [AgentMsgId] -> CIStatus 'MDSnd -> CM ()
    updateDirectItemsStatusMsgs :: Contact
-> Connection -> [GroupMemberId] -> CIStatus 'MDSnd -> CM ()
updateDirectItemsStatusMsgs Contact
ct Connection
conn [GroupMemberId]
msgIds CIStatus 'MDSnd
newStatus = do
      [Either StoreError [ChatItem 'CTDirect 'MDSnd]]
cis <- (Connection -> IO [Either StoreError [ChatItem 'CTDirect 'MDSnd]])
-> CM [Either StoreError [ChatItem 'CTDirect 'MDSnd]]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [Either StoreError [ChatItem 'CTDirect 'MDSnd]])
 -> CM [Either StoreError [ChatItem 'CTDirect 'MDSnd]])
-> (Connection
    -> IO [Either StoreError [ChatItem 'CTDirect 'MDSnd]])
-> CM [Either StoreError [ChatItem 'CTDirect 'MDSnd]]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> [GroupMemberId]
-> (GroupMemberId
    -> IO (Either StoreError [ChatItem 'CTDirect 'MDSnd]))
-> IO [Either StoreError [ChatItem 'CTDirect 'MDSnd]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GroupMemberId]
msgIds ((GroupMemberId
  -> IO (Either StoreError [ChatItem 'CTDirect 'MDSnd]))
 -> IO [Either StoreError [ChatItem 'CTDirect 'MDSnd]])
-> (GroupMemberId
    -> IO (Either StoreError [ChatItem 'CTDirect 'MDSnd]))
-> IO [Either StoreError [ChatItem 'CTDirect 'MDSnd]]
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
msgId -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
-> IO (Either StoreError [ChatItem 'CTDirect 'MDSnd])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
 -> IO (Either StoreError [ChatItem 'CTDirect 'MDSnd]))
-> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
-> IO (Either StoreError [ChatItem 'CTDirect 'MDSnd])
forall a b. (a -> b) -> a -> b
$ Connection
-> Contact
-> Connection
-> GroupMemberId
-> CIStatus 'MDSnd
-> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
updateDirectItemsStatus' Connection
db Contact
ct Connection
conn GroupMemberId
msgId CIStatus 'MDSnd
newStatus
      let acis :: [AChatItem]
acis = (ChatItem 'CTDirect 'MDSnd -> AChatItem)
-> [ChatItem 'CTDirect 'MDSnd] -> [AChatItem]
forall a b. (a -> b) -> [a] -> [b]
map ChatItem 'CTDirect 'MDSnd -> AChatItem
ctItem ([ChatItem 'CTDirect 'MDSnd] -> [AChatItem])
-> [ChatItem 'CTDirect 'MDSnd] -> [AChatItem]
forall a b. (a -> b) -> a -> b
$ [[ChatItem 'CTDirect 'MDSnd]] -> [ChatItem 'CTDirect 'MDSnd]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ChatItem 'CTDirect 'MDSnd]] -> [ChatItem 'CTDirect 'MDSnd])
-> [[ChatItem 'CTDirect 'MDSnd]] -> [ChatItem 'CTDirect 'MDSnd]
forall a b. (a -> b) -> a -> b
$ [Either StoreError [ChatItem 'CTDirect 'MDSnd]]
-> [[ChatItem 'CTDirect 'MDSnd]]
forall a b. [Either a b] -> [b]
rights [Either StoreError [ChatItem 'CTDirect 'MDSnd]]
cis
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([AChatItem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AChatItem]
acis) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtChatItemsStatusesUpdated User
user [AChatItem]
acis
      where
        ctItem :: ChatItem 'CTDirect 'MDSnd -> AChatItem
ctItem = SChatType 'CTDirect
-> SMsgDirection 'MDSnd
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDSnd
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDSnd
SMDSnd (Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct)

    updateDirectItemStatus :: Contact -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> CM ()
    updateDirectItemStatus :: Contact -> Connection -> GroupMemberId -> CIStatus 'MDSnd -> CM ()
updateDirectItemStatus Contact
ct Connection
conn GroupMemberId
msgId CIStatus 'MDSnd
newStatus = do
      [ChatItem 'CTDirect 'MDSnd]
cis <- (Connection -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd])
-> CM [ChatItem 'CTDirect 'MDSnd]
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd])
 -> CM [ChatItem 'CTDirect 'MDSnd])
-> (Connection
    -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd])
-> CM [ChatItem 'CTDirect 'MDSnd]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> Contact
-> Connection
-> GroupMemberId
-> CIStatus 'MDSnd
-> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
updateDirectItemsStatus' Connection
db Contact
ct Connection
conn GroupMemberId
msgId CIStatus 'MDSnd
newStatus
      let acis :: [AChatItem]
acis = (ChatItem 'CTDirect 'MDSnd -> AChatItem)
-> [ChatItem 'CTDirect 'MDSnd] -> [AChatItem]
forall a b. (a -> b) -> [a] -> [b]
map ChatItem 'CTDirect 'MDSnd -> AChatItem
ctItem [ChatItem 'CTDirect 'MDSnd]
cis
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([AChatItem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AChatItem]
acis) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtChatItemsStatusesUpdated User
user [AChatItem]
acis
      where
        ctItem :: ChatItem 'CTDirect 'MDSnd -> AChatItem
ctItem = SChatType 'CTDirect
-> SMsgDirection 'MDSnd
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect 'MDSnd
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTDirect
SCTDirect SMsgDirection 'MDSnd
SMDSnd (Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct)

    updateDirectItemsStatus' :: DB.Connection -> Contact -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
    updateDirectItemsStatus' :: Connection
-> Contact
-> Connection
-> GroupMemberId
-> CIStatus 'MDSnd
-> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
updateDirectItemsStatus' Connection
db ct :: Contact
ct@Contact {GroupMemberId
contactId :: Contact -> GroupMemberId
contactId :: GroupMemberId
contactId} Connection {GroupMemberId
connId :: Connection -> GroupMemberId
connId :: GroupMemberId
connId} GroupMemberId
msgId CIStatus 'MDSnd
newStatus = do
      [CChatItem 'CTDirect]
items <- IO [CChatItem 'CTDirect]
-> ExceptT StoreError IO [CChatItem 'CTDirect]
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CChatItem 'CTDirect]
 -> ExceptT StoreError IO [CChatItem 'CTDirect])
-> IO [CChatItem 'CTDirect]
-> ExceptT StoreError IO [CChatItem 'CTDirect]
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> GroupMemberId
-> GroupMemberId
-> GroupMemberId
-> IO [CChatItem 'CTDirect]
getDirectChatItemsByAgentMsgId Connection
db User
user GroupMemberId
contactId GroupMemberId
connId GroupMemberId
msgId
      [Maybe (ChatItem 'CTDirect 'MDSnd)] -> [ChatItem 'CTDirect 'MDSnd]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ChatItem 'CTDirect 'MDSnd)]
 -> [ChatItem 'CTDirect 'MDSnd])
-> ExceptT StoreError IO [Maybe (ChatItem 'CTDirect 'MDSnd)]
-> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CChatItem 'CTDirect
 -> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDSnd)))
-> [CChatItem 'CTDirect]
-> ExceptT StoreError IO [Maybe (ChatItem 'CTDirect 'MDSnd)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CChatItem 'CTDirect
-> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDSnd))
updateItem [CChatItem 'CTDirect]
items
      where
        updateItem :: CChatItem 'CTDirect -> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDSnd))
        updateItem :: CChatItem 'CTDirect
-> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDSnd))
updateItem = \case
          (CChatItem SMsgDirection d
SMDSnd ChatItem {meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta = CIMeta {itemStatus :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> CIStatus d
itemStatus = CISSndRcvd MsgReceiptStatus
_ SndCIStatusProgress
_}}) -> Maybe (ChatItem 'CTDirect 'MDSnd)
-> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDSnd))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ChatItem 'CTDirect 'MDSnd)
forall a. Maybe a
Nothing
          (CChatItem SMsgDirection d
SMDSnd ChatItem {meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta = CIMeta {GroupMemberId
itemId :: GroupMemberId
itemId :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> GroupMemberId
itemId, CIStatus d
itemStatus :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> CIStatus d
itemStatus :: CIStatus d
itemStatus}})
            | CIStatus d
itemStatus CIStatus d -> CIStatus d -> Bool
forall a. Eq a => a -> a -> Bool
== CIStatus d
CIStatus 'MDSnd
newStatus -> Maybe (ChatItem 'CTDirect 'MDSnd)
-> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDSnd))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ChatItem 'CTDirect 'MDSnd)
forall a. Maybe a
Nothing
            | Bool
otherwise -> ChatItem 'CTDirect 'MDSnd -> Maybe (ChatItem 'CTDirect 'MDSnd)
forall a. a -> Maybe a
Just (ChatItem 'CTDirect 'MDSnd -> Maybe (ChatItem 'CTDirect 'MDSnd))
-> ExceptT StoreError IO (ChatItem 'CTDirect 'MDSnd)
-> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDSnd))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> User
-> Contact
-> GroupMemberId
-> CIStatus 'MDSnd
-> ExceptT StoreError IO (ChatItem 'CTDirect 'MDSnd)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> Contact
-> GroupMemberId
-> CIStatus d
-> ExceptT StoreError IO (ChatItem 'CTDirect d)
updateDirectChatItemStatus Connection
db User
user Contact
ct GroupMemberId
itemId CIStatus 'MDSnd
newStatus
          CChatItem 'CTDirect
_ -> Maybe (ChatItem 'CTDirect 'MDSnd)
-> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDSnd))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ChatItem 'CTDirect 'MDSnd)
forall a. Maybe a
Nothing

    updateGroupMemSndStatus' :: DB.Connection -> ChatItemId -> GroupMemberId -> GroupSndStatus -> IO Bool
    updateGroupMemSndStatus' :: Connection
-> GroupMemberId -> GroupMemberId -> GroupSndStatus -> IO Bool
updateGroupMemSndStatus' Connection
db GroupMemberId
itemId GroupMemberId
groupMemberId GroupSndStatus
newStatus =
      ExceptT StoreError IO GroupSndStatus
-> IO (Either StoreError GroupSndStatus)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Connection
-> GroupMemberId
-> GroupMemberId
-> ExceptT StoreError IO GroupSndStatus
getGroupSndStatus Connection
db GroupMemberId
itemId GroupMemberId
groupMemberId) IO (Either StoreError GroupSndStatus)
-> (Either StoreError GroupSndStatus -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right (GSSRcvd MsgReceiptStatus
_) -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Right GroupSndStatus
memStatus
          | GroupSndStatus
memStatus GroupSndStatus -> GroupSndStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GroupSndStatus
newStatus -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          | Bool
otherwise -> Connection
-> GroupMemberId -> GroupMemberId -> GroupSndStatus -> IO ()
updateGroupSndStatus Connection
db GroupMemberId
itemId GroupMemberId
groupMemberId GroupSndStatus
newStatus IO () -> Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
        Either StoreError GroupSndStatus
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

    updateGroupItemsStatus :: GroupInfo -> GroupMember -> Connection -> AgentMsgId -> GroupSndStatus -> Maybe Bool -> CM ()
    updateGroupItemsStatus :: GroupInfo
-> GroupMember
-> Connection
-> GroupMemberId
-> GroupSndStatus
-> Maybe Bool
-> CM ()
updateGroupItemsStatus gInfo :: GroupInfo
gInfo@GroupInfo {GroupMemberId
groupId :: GroupInfo -> GroupMemberId
groupId :: GroupMemberId
groupId} GroupMember {GroupMemberId
groupMemberId :: GroupMember -> GroupMemberId
groupMemberId :: GroupMemberId
groupMemberId} Connection {GroupMemberId
connId :: Connection -> GroupMemberId
connId :: GroupMemberId
connId} GroupMemberId
msgId GroupSndStatus
newMemStatus Maybe Bool
viaProxy_ = do
      [CChatItem 'CTGroup]
items <- (Connection -> IO [CChatItem 'CTGroup]) -> CM [CChatItem 'CTGroup]
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> Connection
-> User
-> GroupMemberId
-> GroupMemberId
-> GroupMemberId
-> IO [CChatItem 'CTGroup]
getGroupChatItemsByAgentMsgId Connection
db User
user GroupMemberId
groupId GroupMemberId
connId GroupMemberId
msgId)
      [ChatItem 'CTGroup 'MDSnd]
cis <- [Maybe (ChatItem 'CTGroup 'MDSnd)] -> [ChatItem 'CTGroup 'MDSnd]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ChatItem 'CTGroup 'MDSnd)] -> [ChatItem 'CTGroup 'MDSnd])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Maybe (ChatItem 'CTGroup 'MDSnd)]
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatItem 'CTGroup 'MDSnd]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection
 -> ExceptT StoreError IO [Maybe (ChatItem 'CTGroup 'MDSnd)])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Maybe (ChatItem 'CTGroup 'MDSnd)]
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> (CChatItem 'CTGroup
 -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd)))
-> [CChatItem 'CTGroup]
-> ExceptT StoreError IO [Maybe (ChatItem 'CTGroup 'MDSnd)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Connection
-> CChatItem 'CTGroup
-> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd))
updateItem Connection
db) [CChatItem 'CTGroup]
items)
      -- SENT and RCVD events are received for messages that may be batched in single scope,
      -- so we can look up scope of first item
      Maybe GroupChatScopeInfo
scopeInfo <- case [ChatItem 'CTGroup 'MDSnd]
cis of
        (ChatItem 'CTGroup 'MDSnd
ci : [ChatItem 'CTGroup 'MDSnd]
_) -> (Connection -> ExceptT StoreError IO (Maybe GroupChatScopeInfo))
-> CM (Maybe GroupChatScopeInfo)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (Maybe GroupChatScopeInfo))
 -> CM (Maybe GroupChatScopeInfo))
-> (Connection -> ExceptT StoreError IO (Maybe GroupChatScopeInfo))
-> CM (Maybe GroupChatScopeInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> GroupMemberId
-> ExceptT StoreError IO (Maybe GroupChatScopeInfo)
getGroupChatScopeInfoForItem Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo (ChatItem 'CTGroup 'MDSnd -> GroupMemberId
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> GroupMemberId
chatItemId' ChatItem 'CTGroup 'MDSnd
ci)
        [ChatItem 'CTGroup 'MDSnd]
_ -> Maybe GroupChatScopeInfo -> CM (Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing
      let acis :: [AChatItem]
acis = (ChatItem 'CTGroup 'MDSnd -> AChatItem)
-> [ChatItem 'CTGroup 'MDSnd] -> [AChatItem]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe GroupChatScopeInfo -> ChatItem 'CTGroup 'MDSnd -> AChatItem
gItem Maybe GroupChatScopeInfo
scopeInfo) [ChatItem 'CTGroup 'MDSnd]
cis
      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([AChatItem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AChatItem]
acis) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> CM ()
toView (ChatEvent -> CM ()) -> ChatEvent -> CM ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtChatItemsStatusesUpdated User
user [AChatItem]
acis
      where
        gItem :: Maybe GroupChatScopeInfo -> ChatItem 'CTGroup 'MDSnd -> AChatItem
gItem Maybe GroupChatScopeInfo
scopeInfo ChatItem 'CTGroup 'MDSnd
ci = SChatType 'CTGroup
-> SMsgDirection 'MDSnd
-> ChatInfo 'CTGroup
-> ChatItem 'CTGroup 'MDSnd
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTGroup
SCTGroup SMsgDirection 'MDSnd
SMDSnd (GroupInfo -> Maybe GroupChatScopeInfo -> ChatInfo 'CTGroup
GroupChat GroupInfo
gInfo Maybe GroupChatScopeInfo
scopeInfo) ChatItem 'CTGroup 'MDSnd
ci
        updateItem :: DB.Connection -> CChatItem 'CTGroup -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd))
        updateItem :: Connection
-> CChatItem 'CTGroup
-> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd))
updateItem Connection
db = \case
          (CChatItem SMsgDirection d
SMDSnd ChatItem {meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta = CIMeta {itemStatus :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> CIStatus d
itemStatus = CISSndRcvd MsgReceiptStatus
_ SndCIStatusProgress
SSPComplete}}) -> Maybe (ChatItem 'CTGroup 'MDSnd)
-> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ChatItem 'CTGroup 'MDSnd)
forall a. Maybe a
Nothing
          (CChatItem SMsgDirection d
SMDSnd ChatItem {meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta = CIMeta {GroupMemberId
itemId :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> GroupMemberId
itemId :: GroupMemberId
itemId, CIStatus d
itemStatus :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> CIStatus d
itemStatus :: CIStatus d
itemStatus}}) -> do
            Maybe Bool
-> (Bool -> ExceptT StoreError IO ()) -> ExceptT StoreError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Bool
viaProxy_ ((Bool -> ExceptT StoreError IO ()) -> ExceptT StoreError IO ())
-> (Bool -> ExceptT StoreError IO ()) -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ \Bool
viaProxy -> IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> GroupMemberId -> GroupMemberId -> Bool -> IO ()
setGroupSndViaProxy Connection
db GroupMemberId
itemId GroupMemberId
groupMemberId Bool
viaProxy
            Bool
memStatusChanged <- IO Bool -> ExceptT StoreError IO Bool
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT StoreError IO Bool)
-> IO Bool -> ExceptT StoreError IO Bool
forall a b. (a -> b) -> a -> b
$ Connection
-> GroupMemberId -> GroupMemberId -> GroupSndStatus -> IO Bool
updateGroupMemSndStatus' Connection
db GroupMemberId
itemId GroupMemberId
groupMemberId GroupSndStatus
newMemStatus
            if Bool
memStatusChanged
              then do
                [(GroupSndStatus, Int)]
memStatusCounts <- IO [(GroupSndStatus, Int)]
-> ExceptT StoreError IO [(GroupSndStatus, Int)]
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(GroupSndStatus, Int)]
 -> ExceptT StoreError IO [(GroupSndStatus, Int)])
-> IO [(GroupSndStatus, Int)]
-> ExceptT StoreError IO [(GroupSndStatus, Int)]
forall a b. (a -> b) -> a -> b
$ Connection -> GroupMemberId -> IO [(GroupSndStatus, Int)]
getGroupSndStatusCounts Connection
db GroupMemberId
itemId
                let newStatus :: CIStatus 'MDSnd
newStatus = [(GroupSndStatus, Int)] -> CIStatus 'MDSnd
membersGroupItemStatus [(GroupSndStatus, Int)]
memStatusCounts
                if CIStatus 'MDSnd
newStatus CIStatus 'MDSnd -> CIStatus 'MDSnd -> Bool
forall a. Eq a => a -> a -> Bool
/= CIStatus d
CIStatus 'MDSnd
itemStatus
                  then ChatItem 'CTGroup 'MDSnd -> Maybe (ChatItem 'CTGroup 'MDSnd)
forall a. a -> Maybe a
Just (ChatItem 'CTGroup 'MDSnd -> Maybe (ChatItem 'CTGroup 'MDSnd))
-> ExceptT StoreError IO (ChatItem 'CTGroup 'MDSnd)
-> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> User
-> GroupInfo
-> GroupMemberId
-> CIStatus 'MDSnd
-> ExceptT StoreError IO (ChatItem 'CTGroup 'MDSnd)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupInfo
-> GroupMemberId
-> CIStatus d
-> ExceptT StoreError IO (ChatItem 'CTGroup d)
updateGroupChatItemStatus Connection
db User
user GroupInfo
gInfo GroupMemberId
itemId CIStatus 'MDSnd
newStatus
                  else Maybe (ChatItem 'CTGroup 'MDSnd)
-> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ChatItem 'CTGroup 'MDSnd)
forall a. Maybe a
Nothing
              else Maybe (ChatItem 'CTGroup 'MDSnd)
-> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ChatItem 'CTGroup 'MDSnd)
forall a. Maybe a
Nothing
          CChatItem 'CTGroup
_ -> Maybe (ChatItem 'CTGroup 'MDSnd)
-> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ChatItem 'CTGroup 'MDSnd)
forall a. Maybe a
Nothing

deleteGroupConnections :: User -> GroupInfo -> Bool -> CM ()
deleteGroupConnections :: User -> GroupInfo -> Bool -> CM ()
deleteGroupConnections User
user GroupInfo
gInfo Bool
waitDelivery = do
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  -- member records are not deleted to keep history
  [GroupMember]
members <- VersionRangeChat -> CM [GroupMember]
getMembers VersionRangeChat
vr
  User -> [GroupMember] -> Bool -> CM ()
deleteMembersConnections' User
user [GroupMember]
members Bool
waitDelivery
  where
    getMembers :: VersionRangeChat -> CM [GroupMember]
getMembers VersionRangeChat
vr
      | BoolDef -> Bool
isTrue (GroupInfo -> BoolDef
useRelays GroupInfo
gInfo) = (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [GroupMember]) -> CM [GroupMember])
-> (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
getGroupRelays Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo
      | Bool
otherwise = (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [GroupMember]) -> CM [GroupMember])
-> (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
getGroupMembers Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo

startDeliveryTaskWorkers :: CM ()
startDeliveryTaskWorkers :: CM ()
startDeliveryTaskWorkers = do
  [DeliveryWorkerKey]
workerScopes <- (Connection -> IO [DeliveryWorkerKey]) -> CM [DeliveryWorkerKey]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [DeliveryWorkerKey]) -> CM [DeliveryWorkerKey])
-> (Connection -> IO [DeliveryWorkerKey]) -> CM [DeliveryWorkerKey]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> IO [DeliveryWorkerKey]
getPendingDeliveryTaskScopes Connection
db
  ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ [DeliveryWorkerKey]
-> (DeliveryWorkerKey -> ReaderT ChatController IO ())
-> ReaderT ChatController IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DeliveryWorkerKey]
workerScopes DeliveryWorkerKey -> ReaderT ChatController IO ()
resumeDeliveryTaskWork

resumeDeliveryTaskWork :: DeliveryWorkerKey -> CM' ()
resumeDeliveryTaskWork :: DeliveryWorkerKey -> ReaderT ChatController IO ()
resumeDeliveryTaskWork = ReaderT ChatController IO Worker -> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO Worker -> ReaderT ChatController IO ())
-> (DeliveryWorkerKey -> ReaderT ChatController IO Worker)
-> DeliveryWorkerKey
-> ReaderT ChatController IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> DeliveryWorkerKey -> ReaderT ChatController IO Worker
getDeliveryTaskWorker Bool
False

getDeliveryTaskWorker :: Bool -> DeliveryWorkerKey -> CM' Worker
getDeliveryTaskWorker :: Bool -> DeliveryWorkerKey -> ReaderT ChatController IO Worker
getDeliveryTaskWorker Bool
hasWork DeliveryWorkerKey
deliveryKey = do
  TMap DeliveryWorkerKey Worker
ws <- (ChatController -> TMap DeliveryWorkerKey Worker)
-> ReaderT ChatController IO (TMap DeliveryWorkerKey Worker)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TMap DeliveryWorkerKey Worker
deliveryTaskWorkers
  AgentClient
a <- (ChatController -> AgentClient)
-> ReaderT ChatController IO AgentClient
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> AgentClient
smpAgent
  String
-> Bool
-> AgentClient
-> DeliveryWorkerKey
-> TMap DeliveryWorkerKey Worker
-> (Worker -> CM ())
-> ReaderT ChatController IO Worker
forall k e (m :: * -> *).
(Ord k, Show k, AnyError e, MonadUnliftIO m) =>
String
-> Bool
-> AgentClient
-> k
-> TMap k Worker
-> (Worker -> ExceptT e m ())
-> m Worker
getAgentWorker String
"delivery_task" Bool
hasWork AgentClient
a DeliveryWorkerKey
deliveryKey TMap DeliveryWorkerKey Worker
ws ((Worker -> CM ()) -> ReaderT ChatController IO Worker)
-> (Worker -> CM ()) -> ReaderT ChatController IO Worker
forall a b. (a -> b) -> a -> b
$
    AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
runDeliveryTaskWorker AgentClient
a DeliveryWorkerKey
deliveryKey

runDeliveryTaskWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
runDeliveryTaskWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
runDeliveryTaskWorker AgentClient
a DeliveryWorkerKey
deliveryKey Worker {TMVar ()
doWork :: TMVar ()
doWork :: Worker -> TMVar ()
doWork} = do
  GroupMemberId
delay <- (ChatController -> GroupMemberId) -> CM GroupMemberId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ChatController -> GroupMemberId) -> CM GroupMemberId)
-> (ChatController -> GroupMemberId) -> CM GroupMemberId
forall a b. (a -> b) -> a -> b
$ ChatConfig -> GroupMemberId
deliveryWorkerDelay (ChatConfig -> GroupMemberId)
-> (ChatController -> ChatConfig)
-> ChatController
-> GroupMemberId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  -- TODO [channels fwd] in future may be required to read groupInfo and user on each iteration for up to date state
  -- TODO   - same for delivery jobs (runDeliveryJobWorker)
  GroupInfo
gInfo <- (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo)
-> (Connection -> ExceptT StoreError IO GroupInfo) -> CM GroupInfo
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
    User
user <- Connection -> GroupMemberId -> ExceptT StoreError IO User
getUserByGroupId Connection
db GroupMemberId
groupId
    Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO GroupInfo
getGroupInfo Connection
db VersionRangeChat
vr User
user GroupMemberId
groupId
  CM () -> CM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupMemberId
delay GroupMemberId -> GroupMemberId -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberId
0) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ IO () -> CM ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CM ()) -> IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> IO ()
threadDelay' GroupMemberId
delay
    ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> ReaderT ChatController IO ()
forall (m :: * -> *). MonadIO m => TMVar () -> m ()
waitForWork TMVar ()
doWork
    VersionRangeChat -> GroupInfo -> CM ()
runDeliveryTaskOperation VersionRangeChat
vr GroupInfo
gInfo
  where
    (GroupMemberId
groupId, DeliveryWorkerScope
workerScope) = DeliveryWorkerKey
deliveryKey
    runDeliveryTaskOperation :: VersionRangeChat -> GroupInfo -> CM ()
    runDeliveryTaskOperation :: VersionRangeChat -> GroupInfo -> CM ()
runDeliveryTaskOperation VersionRangeChat
vr GroupInfo
gInfo = do
      AgentClient
-> TMVar ()
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either StoreError (Maybe MessageDeliveryTask))
-> (MessageDeliveryTask -> CM ())
-> CM ()
forall e' (m :: * -> *) e a.
(AnyStoreError e', MonadIO m) =>
AgentClient
-> TMVar ()
-> ExceptT e m (Either e' (Maybe a))
-> (a -> ExceptT e m ())
-> ExceptT e m ()
withWork_ AgentClient
a TMVar ()
doWork ((Connection -> IO (Either StoreError (Maybe MessageDeliveryTask)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either StoreError (Maybe MessageDeliveryTask))
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (Either StoreError (Maybe MessageDeliveryTask)))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Either StoreError (Maybe MessageDeliveryTask)))
-> (Connection
    -> IO (Either StoreError (Maybe MessageDeliveryTask)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either StoreError (Maybe MessageDeliveryTask))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> DeliveryWorkerKey
-> IO (Either StoreError (Maybe MessageDeliveryTask))
getNextDeliveryTask Connection
db DeliveryWorkerKey
deliveryKey) ((MessageDeliveryTask -> CM ()) -> CM ())
-> (MessageDeliveryTask -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \MessageDeliveryTask
task ->
        MessageDeliveryTask -> CM ()
processDeliveryTask MessageDeliveryTask
task
          CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
e -> do
            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> GroupMemberId -> Text -> IO ()
setDeliveryTaskErrStatus Connection
db (MessageDeliveryTask -> GroupMemberId
deliveryTaskId MessageDeliveryTask
task) (ChatError -> Text
forall a. Show a => a -> Text
tshow ChatError
e)
            ChatError -> CM ()
eToView ChatError
e
      where
        processDeliveryTask :: MessageDeliveryTask -> CM ()
        processDeliveryTask :: MessageDeliveryTask -> CM ()
processDeliveryTask task :: MessageDeliveryTask
task@MessageDeliveryTask {DeliveryJobScope
jobScope :: DeliveryJobScope
jobScope :: MessageDeliveryTask -> DeliveryJobScope
jobScope} =
          case DeliveryJobScope -> DeliveryJobSpec
jobScopeImpliedSpec DeliveryJobScope
jobScope of
            DJDeliveryJob Bool
_includePending ->
              AgentClient
-> TMVar ()
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either StoreError [Either StoreError MessageDeliveryTask])
-> (NonEmpty MessageDeliveryTask -> CM ())
-> CM ()
forall e' (m :: * -> *) e a.
(AnyStoreError e', MonadIO m) =>
AgentClient
-> TMVar ()
-> ExceptT e m (Either e' [Either e' a])
-> (NonEmpty a -> ExceptT e m ())
-> ExceptT e m ()
withWorkItems AgentClient
a TMVar ()
doWork ((Connection
 -> IO (Either StoreError [Either StoreError MessageDeliveryTask]))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either StoreError [Either StoreError MessageDeliveryTask])
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection
  -> IO (Either StoreError [Either StoreError MessageDeliveryTask]))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Either StoreError [Either StoreError MessageDeliveryTask]))
-> (Connection
    -> IO (Either StoreError [Either StoreError MessageDeliveryTask]))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either StoreError [Either StoreError MessageDeliveryTask])
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupInfo
-> MessageDeliveryTask
-> IO (Either StoreError [Either StoreError MessageDeliveryTask])
getNextDeliveryTasks Connection
db GroupInfo
gInfo MessageDeliveryTask
task) ((NonEmpty MessageDeliveryTask -> CM ()) -> CM ())
-> (NonEmpty MessageDeliveryTask -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty MessageDeliveryTask
nextTasks -> do
                let (ByteString
body, [GroupMemberId]
taskIds, [GroupMemberId]
largeTaskIds) = VersionRangeChat
-> Int
-> NonEmpty MessageDeliveryTask
-> (ByteString, [GroupMemberId], [GroupMemberId])
batchDeliveryTasks1 VersionRangeChat
vr Int
maxEncodedMsgLength NonEmpty MessageDeliveryTask
nextTasks
                (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                  Connection
-> GroupInfo
-> DeliveryJobScope
-> Maybe GroupMemberId
-> ByteString
-> IO ()
createMsgDeliveryJob Connection
db GroupInfo
gInfo DeliveryJobScope
jobScope (NonEmpty MessageDeliveryTask -> Maybe GroupMemberId
singleSenderGMId_ NonEmpty MessageDeliveryTask
nextTasks) ByteString
body
                  [GroupMemberId] -> (GroupMemberId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GroupMemberId]
taskIds ((GroupMemberId -> IO ()) -> IO ())
-> (GroupMemberId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
taskId -> Connection -> GroupMemberId -> DeliveryTaskStatus -> IO ()
updateDeliveryTaskStatus Connection
db GroupMemberId
taskId DeliveryTaskStatus
DTSProcessed
                  [GroupMemberId] -> (GroupMemberId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GroupMemberId]
largeTaskIds ((GroupMemberId -> IO ()) -> IO ())
-> (GroupMemberId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GroupMemberId
taskId -> Connection -> GroupMemberId -> Text -> IO ()
setDeliveryTaskErrStatus Connection
db GroupMemberId
taskId Text
"large"
                ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> (ReaderT ChatController IO Worker
    -> ReaderT ChatController IO ())
-> ReaderT ChatController IO Worker
-> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ChatController IO Worker -> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO Worker -> CM ())
-> ReaderT ChatController IO Worker -> CM ()
forall a b. (a -> b) -> a -> b
$ Bool -> DeliveryWorkerKey -> ReaderT ChatController IO Worker
getDeliveryJobWorker Bool
True DeliveryWorkerKey
deliveryKey
              where
                singleSenderGMId_ :: NonEmpty MessageDeliveryTask -> Maybe GroupMemberId
                singleSenderGMId_ :: NonEmpty MessageDeliveryTask -> Maybe GroupMemberId
singleSenderGMId_ (MessageDeliveryTask {senderGMId :: MessageDeliveryTask -> GroupMemberId
senderGMId = GroupMemberId
senderGMId'} :| [MessageDeliveryTask]
ts)
                  | (MessageDeliveryTask -> Bool) -> [MessageDeliveryTask] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\MessageDeliveryTask {GroupMemberId
senderGMId :: MessageDeliveryTask -> GroupMemberId
senderGMId :: GroupMemberId
senderGMId} -> GroupMemberId
senderGMId GroupMemberId -> GroupMemberId -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberId
senderGMId') [MessageDeliveryTask]
ts = GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just GroupMemberId
senderGMId'
                  | Bool
otherwise = Maybe GroupMemberId
forall a. Maybe a
Nothing
            DeliveryJobSpec
DJRelayRemoved
              | DeliveryWorkerScope
workerScope DeliveryWorkerScope -> DeliveryWorkerScope -> Bool
forall a. Eq a => a -> a -> Bool
/= DeliveryWorkerScope
DWSGroup ->
                  ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError String
"delivery task worker: relay removed task in wrong worker scope"
              | Bool
otherwise -> do
                  let MessageDeliveryTask {GroupMemberId
senderGMId :: MessageDeliveryTask -> GroupMemberId
senderGMId :: GroupMemberId
senderGMId, MemberId
senderMemberId :: MemberId
senderMemberId :: MessageDeliveryTask -> MemberId
senderMemberId, Text
senderMemberName :: Text
senderMemberName :: MessageDeliveryTask -> Text
senderMemberName, UTCTime
brokerTs :: UTCTime
brokerTs :: MessageDeliveryTask -> UTCTime
brokerTs, ChatMessage 'Json
chatMessage :: ChatMessage 'Json
chatMessage :: MessageDeliveryTask -> ChatMessage 'Json
chatMessage} = MessageDeliveryTask
task
                      fwdEvt :: ChatMsgEvent 'Json
fwdEvt = MemberId
-> Maybe Text -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json
XGrpMsgForward MemberId
senderMemberId (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
senderMemberName) ChatMessage 'Json
chatMessage UTCTime
brokerTs
                      cm :: ChatMessage 'Json
cm = ChatMessage {chatVRange :: VersionRangeChat
chatVRange = VersionRangeChat
vr, msgId :: Maybe SharedMsgId
msgId = Maybe SharedMsgId
forall a. Maybe a
Nothing, chatMsgEvent :: ChatMsgEvent 'Json
chatMsgEvent = ChatMsgEvent 'Json
fwdEvt}
                      body :: ByteString
body = ChatMessage 'Json -> ByteString
forall (e :: MsgEncoding).
MsgEncodingI e =>
ChatMessage e -> ByteString
chatMsgToBody ChatMessage 'Json
cm
                  (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
                    Connection
-> GroupInfo
-> DeliveryJobScope
-> Maybe GroupMemberId
-> ByteString
-> IO ()
createMsgDeliveryJob Connection
db GroupInfo
gInfo DeliveryJobScope
jobScope (GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just GroupMemberId
senderGMId) ByteString
body
                    Connection -> GroupMemberId -> DeliveryTaskStatus -> IO ()
updateDeliveryTaskStatus Connection
db (MessageDeliveryTask -> GroupMemberId
deliveryTaskId MessageDeliveryTask
task) DeliveryTaskStatus
DTSProcessed
                  ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> (ReaderT ChatController IO Worker
    -> ReaderT ChatController IO ())
-> ReaderT ChatController IO Worker
-> CM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ChatController IO Worker -> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO Worker -> CM ())
-> ReaderT ChatController IO Worker -> CM ()
forall a b. (a -> b) -> a -> b
$ Bool -> DeliveryWorkerKey -> ReaderT ChatController IO Worker
getDeliveryJobWorker Bool
True DeliveryWorkerKey
deliveryKey

startDeliveryJobWorkers :: CM ()
startDeliveryJobWorkers :: CM ()
startDeliveryJobWorkers = do
  [DeliveryWorkerKey]
workerScopes <- (Connection -> IO [DeliveryWorkerKey]) -> CM [DeliveryWorkerKey]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [DeliveryWorkerKey]) -> CM [DeliveryWorkerKey])
-> (Connection -> IO [DeliveryWorkerKey]) -> CM [DeliveryWorkerKey]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> IO [DeliveryWorkerKey]
getPendingDeliveryJobScopes Connection
db
  ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ [DeliveryWorkerKey]
-> (DeliveryWorkerKey -> ReaderT ChatController IO ())
-> ReaderT ChatController IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DeliveryWorkerKey]
workerScopes DeliveryWorkerKey -> ReaderT ChatController IO ()
resumeDeliveryJobWork

resumeDeliveryJobWork :: DeliveryWorkerKey -> CM' ()
resumeDeliveryJobWork :: DeliveryWorkerKey -> ReaderT ChatController IO ()
resumeDeliveryJobWork = ReaderT ChatController IO Worker -> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO Worker -> ReaderT ChatController IO ())
-> (DeliveryWorkerKey -> ReaderT ChatController IO Worker)
-> DeliveryWorkerKey
-> ReaderT ChatController IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> DeliveryWorkerKey -> ReaderT ChatController IO Worker
getDeliveryJobWorker Bool
False

getDeliveryJobWorker :: Bool -> DeliveryWorkerKey -> CM' Worker
getDeliveryJobWorker :: Bool -> DeliveryWorkerKey -> ReaderT ChatController IO Worker
getDeliveryJobWorker Bool
hasWork DeliveryWorkerKey
deliveryKey = do
  TMap DeliveryWorkerKey Worker
ws <- (ChatController -> TMap DeliveryWorkerKey Worker)
-> ReaderT ChatController IO (TMap DeliveryWorkerKey Worker)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TMap DeliveryWorkerKey Worker
deliveryJobWorkers
  AgentClient
a <- (ChatController -> AgentClient)
-> ReaderT ChatController IO AgentClient
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> AgentClient
smpAgent
  String
-> Bool
-> AgentClient
-> DeliveryWorkerKey
-> TMap DeliveryWorkerKey Worker
-> (Worker -> CM ())
-> ReaderT ChatController IO Worker
forall k e (m :: * -> *).
(Ord k, Show k, AnyError e, MonadUnliftIO m) =>
String
-> Bool
-> AgentClient
-> k
-> TMap k Worker
-> (Worker -> ExceptT e m ())
-> m Worker
getAgentWorker String
"delivery_job" Bool
hasWork AgentClient
a DeliveryWorkerKey
deliveryKey TMap DeliveryWorkerKey Worker
ws ((Worker -> CM ()) -> ReaderT ChatController IO Worker)
-> (Worker -> CM ()) -> ReaderT ChatController IO Worker
forall a b. (a -> b) -> a -> b
$
    AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
runDeliveryJobWorker AgentClient
a DeliveryWorkerKey
deliveryKey

runDeliveryJobWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
runDeliveryJobWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
runDeliveryJobWorker AgentClient
a DeliveryWorkerKey
deliveryKey Worker {TMVar ()
doWork :: Worker -> TMVar ()
doWork :: TMVar ()
doWork} = do
  GroupMemberId
delay <- (ChatController -> GroupMemberId) -> CM GroupMemberId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ChatController -> GroupMemberId) -> CM GroupMemberId)
-> (ChatController -> GroupMemberId) -> CM GroupMemberId
forall a b. (a -> b) -> a -> b
$ ChatConfig -> GroupMemberId
deliveryWorkerDelay (ChatConfig -> GroupMemberId)
-> (ChatController -> ChatConfig)
-> ChatController
-> GroupMemberId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  (User
user, GroupInfo
gInfo) <- (Connection -> ExceptT StoreError IO (User, GroupInfo))
-> CM (User, GroupInfo)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (User, GroupInfo))
 -> CM (User, GroupInfo))
-> (Connection -> ExceptT StoreError IO (User, GroupInfo))
-> CM (User, GroupInfo)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
    User
user <- Connection -> GroupMemberId -> ExceptT StoreError IO User
getUserByGroupId Connection
db GroupMemberId
groupId
    GroupInfo
gInfo <- Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO GroupInfo
getGroupInfo Connection
db VersionRangeChat
vr User
user GroupMemberId
groupId
    (User, GroupInfo) -> ExceptT StoreError IO (User, GroupInfo)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (User
user, GroupInfo
gInfo)
  CM () -> CM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupMemberId
delay GroupMemberId -> GroupMemberId -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberId
0) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ IO () -> CM ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CM ()) -> IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ GroupMemberId -> IO ()
threadDelay' GroupMemberId
delay
    ReaderT ChatController IO () -> CM ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ChatError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT ChatController IO () -> CM ())
-> ReaderT ChatController IO () -> CM ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> ReaderT ChatController IO ()
forall (m :: * -> *). MonadIO m => TMVar () -> m ()
waitForWork TMVar ()
doWork
    VersionRangeChat -> User -> GroupInfo -> CM ()
runDeliveryJobOperation VersionRangeChat
vr User
user GroupInfo
gInfo
  where
    (GroupMemberId
groupId, DeliveryWorkerScope
workerScope) = DeliveryWorkerKey
deliveryKey
    runDeliveryJobOperation :: VersionRangeChat -> User -> GroupInfo -> CM ()
    runDeliveryJobOperation :: VersionRangeChat -> User -> GroupInfo -> CM ()
runDeliveryJobOperation VersionRangeChat
vr User
user GroupInfo
gInfo = do
      AgentClient
-> TMVar ()
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either StoreError (Maybe MessageDeliveryJob))
-> (MessageDeliveryJob -> CM ())
-> CM ()
forall e' (m :: * -> *) e a.
(AnyStoreError e', MonadIO m) =>
AgentClient
-> TMVar ()
-> ExceptT e m (Either e' (Maybe a))
-> (a -> ExceptT e m ())
-> ExceptT e m ()
withWork_ AgentClient
a TMVar ()
doWork ((Connection -> IO (Either StoreError (Maybe MessageDeliveryJob)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either StoreError (Maybe MessageDeliveryJob))
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (Either StoreError (Maybe MessageDeliveryJob)))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Either StoreError (Maybe MessageDeliveryJob)))
-> (Connection
    -> IO (Either StoreError (Maybe MessageDeliveryJob)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either StoreError (Maybe MessageDeliveryJob))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> DeliveryWorkerKey
-> IO (Either StoreError (Maybe MessageDeliveryJob))
getNextDeliveryJob Connection
db DeliveryWorkerKey
deliveryKey) ((MessageDeliveryJob -> CM ()) -> CM ())
-> (MessageDeliveryJob -> CM ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \MessageDeliveryJob
job ->
        MessageDeliveryJob -> CM ()
processDeliveryJob MessageDeliveryJob
job
          CM () -> (ChatError -> CM ()) -> CM ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
e -> do
            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> GroupMemberId -> Text -> IO ()
setDeliveryJobErrStatus Connection
db (MessageDeliveryJob -> GroupMemberId
deliveryJobId MessageDeliveryJob
job) (ChatError -> Text
forall a. Show a => a -> Text
tshow ChatError
e)
            ChatError -> CM ()
eToView ChatError
e
      where
        processDeliveryJob :: MessageDeliveryJob -> CM ()
        processDeliveryJob :: MessageDeliveryJob -> CM ()
processDeliveryJob MessageDeliveryJob
job =
          case DeliveryJobScope -> DeliveryJobSpec
jobScopeImpliedSpec DeliveryJobScope
jobScope of
            DJDeliveryJob Bool
_includePending -> do
              CM ()
sendBodyToMembers
              (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> GroupMemberId -> DeliveryJobStatus -> IO ()
updateDeliveryJobStatus Connection
db GroupMemberId
jobId DeliveryJobStatus
DJSComplete
            DeliveryJobSpec
DJRelayRemoved
              | DeliveryWorkerScope
workerScope DeliveryWorkerScope -> DeliveryWorkerScope -> Bool
forall a. Eq a => a -> a -> Bool
/= DeliveryWorkerScope
DWSGroup ->
                  ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError String
"delivery job worker: relay removed job in wrong worker scope"
              | Bool
otherwise -> do
                  CM ()
sendBodyToMembers
                  User -> GroupInfo -> Bool -> CM ()
deleteGroupConnections User
user GroupInfo
gInfo Bool
True
                  (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> GroupMemberId -> DeliveryJobStatus -> IO ()
updateDeliveryJobStatus Connection
db GroupMemberId
jobId DeliveryJobStatus
DJSComplete
          where
            MessageDeliveryJob {GroupMemberId
jobId :: GroupMemberId
jobId :: MessageDeliveryJob -> GroupMemberId
jobId, DeliveryJobScope
jobScope :: DeliveryJobScope
jobScope :: MessageDeliveryJob -> DeliveryJobScope
jobScope, Maybe GroupMemberId
singleSenderGMId_ :: Maybe GroupMemberId
singleSenderGMId_ :: MessageDeliveryJob -> Maybe GroupMemberId
singleSenderGMId_, ByteString
body :: ByteString
body :: MessageDeliveryJob -> ByteString
body, cursorGMId_ :: MessageDeliveryJob -> Maybe GroupMemberId
cursorGMId_ = Maybe GroupMemberId
startingCursor} = MessageDeliveryJob
job
            sendBodyToMembers :: CM ()
            sendBodyToMembers :: CM ()
sendBodyToMembers
              | BoolDef -> Bool
isTrue (GroupInfo -> BoolDef
useRelays GroupInfo
gInfo) = -- channel
                  case DeliveryJobScope
jobScope of
                    -- there's no member review in channels, so job spec includePending is ignored
                    DJSGroup {} -> do
                      Int
bucketSize <- (ChatController -> Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ChatController -> Int)
 -> ExceptT ChatError (ReaderT ChatController IO) Int)
-> (ChatController -> Int)
-> ExceptT ChatError (ReaderT ChatController IO) Int
forall a b. (a -> b) -> a -> b
$ ChatConfig -> Int
deliveryBucketSize (ChatConfig -> Int)
-> (ChatController -> ChatConfig) -> ChatController -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config
                      Int -> Maybe GroupMemberId -> CM ()
sendLoop Int
bucketSize Maybe GroupMemberId
startingCursor
                      where
                        sendLoop :: Int -> Maybe GroupMemberId -> CM ()
                        sendLoop :: Int -> Maybe GroupMemberId -> CM ()
sendLoop Int
bucketSize Maybe GroupMemberId
cursorGMId_ = do
                          [GroupMember]
mems <- (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [GroupMember]) -> CM [GroupMember])
-> (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> Maybe GroupMemberId
-> Maybe GroupMemberId
-> Int
-> IO [GroupMember]
getGroupMembersByCursor Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo Maybe GroupMemberId
cursorGMId_ Maybe GroupMemberId
singleSenderGMId_ Int
bucketSize
                          Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GroupMember] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GroupMember]
mems) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ do
                            ByteString -> [GroupMember] -> CM ()
deliver ByteString
body [GroupMember]
mems
                            let cursorGMId' :: GroupMemberId
cursorGMId' = GroupMember -> GroupMemberId
groupMemberId' (GroupMember -> GroupMemberId) -> GroupMember -> GroupMemberId
forall a b. (a -> b) -> a -> b
$ [GroupMember] -> GroupMember
forall a. HasCallStack => [a] -> a
last [GroupMember]
mems
                            (Connection -> IO ()) -> CM ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ()) -> CM ()) -> (Connection -> IO ()) -> CM ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> GroupMemberId -> GroupMemberId -> IO ()
updateDeliveryJobCursor Connection
db GroupMemberId
jobId GroupMemberId
cursorGMId'
                            Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GroupMember] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GroupMember]
mems Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bucketSize) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ Int -> Maybe GroupMemberId -> CM ()
sendLoop Int
bucketSize (GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just GroupMemberId
cursorGMId')
                    DJSMemberSupport GroupMemberId
scopeGMId -> do
                      -- for member support scope we just load all recipients in one go, without cursor
                      [GroupMember]
modMs <- (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [GroupMember]) -> CM [GroupMember])
-> (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
getGroupModerators Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo
                      let moderatorFilter :: GroupMember -> Bool
moderatorFilter GroupMember
m =
                            GroupMember -> Bool
memberCurrent GroupMember
m
                              Bool -> Bool -> Bool
&& VersionRangeChat -> Version ChatVersion
forall v. VersionRange v -> Version v
maxVersion (GroupMember -> VersionRangeChat
memberChatVRange GroupMember
m) Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
groupKnockingVersion
                              Bool -> Bool -> Bool
&& GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just (GroupMember -> GroupMemberId
groupMemberId' GroupMember
m) Maybe GroupMemberId -> Maybe GroupMemberId -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe GroupMemberId
singleSenderGMId_
                          modMs' :: [GroupMember]
modMs' = (GroupMember -> Bool) -> [GroupMember] -> [GroupMember]
forall a. (a -> Bool) -> [a] -> [a]
filter GroupMember -> Bool
moderatorFilter [GroupMember]
modMs
                      [GroupMember]
mems <-
                        if GroupMemberId -> Maybe GroupMemberId
forall a. a -> Maybe a
Just GroupMemberId
scopeGMId Maybe GroupMemberId -> Maybe GroupMemberId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe GroupMemberId
singleSenderGMId_
                          then [GroupMember] -> CM [GroupMember]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [GroupMember]
modMs'
                          else do
                            GroupMember
scopeMem <- (Connection -> ExceptT StoreError IO GroupMember) -> CM GroupMember
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMember)
 -> CM GroupMember)
-> (Connection -> ExceptT StoreError IO GroupMember)
-> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberById Connection
db VersionRangeChat
vr User
user GroupMemberId
scopeGMId
                            [GroupMember] -> CM [GroupMember]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GroupMember] -> CM [GroupMember])
-> [GroupMember] -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ GroupMember
scopeMem GroupMember -> [GroupMember] -> [GroupMember]
forall a. a -> [a] -> [a]
: [GroupMember]
modMs'
                      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GroupMember] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GroupMember]
mems) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [GroupMember] -> CM ()
deliver ByteString
body [GroupMember]
mems
              | Bool
otherwise = -- fully connected group
                  case Maybe GroupMemberId
singleSenderGMId_ of
                    Maybe GroupMemberId
Nothing -> ChatErrorType -> CM ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ()) -> ChatErrorType -> CM ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError String
"delivery job worker: singleSenderGMId is required when not using relays"
                    Just GroupMemberId
singleSenderGMId -> do
                      GroupMember
sender <- (Connection -> ExceptT StoreError IO GroupMember) -> CM GroupMember
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO GroupMember)
 -> CM GroupMember)
-> (Connection -> ExceptT StoreError IO GroupMember)
-> CM GroupMember
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupMemberId
-> ExceptT StoreError IO GroupMember
getGroupMemberById Connection
db VersionRangeChat
vr User
user GroupMemberId
singleSenderGMId
                      [GroupMember]
ms <- GroupMember -> CM [GroupMember]
buildMemberList GroupMember
sender
                      Bool -> CM () -> CM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GroupMember] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GroupMember]
ms) (CM () -> CM ()) -> CM () -> CM ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [GroupMember] -> CM ()
deliver ByteString
body [GroupMember]
ms
                      where
                        buildMemberList :: GroupMember -> CM [GroupMember]
buildMemberList GroupMember
sender = do
                          ByteString
vec <- (Connection -> ExceptT StoreError IO ByteString)
-> ExceptT ChatError (ReaderT ChatController IO) ByteString
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (Connection -> GroupMember -> ExceptT StoreError IO ByteString
`getMemberRelationsVector` GroupMember
sender)
                          -- this excludes the sender
                          let introducedMemsIdxs :: [GroupMemberId]
introducedMemsIdxs = MemberRelation -> ByteString -> [GroupMemberId]
getRelationsIndexes MemberRelation
MRIntroduced ByteString
vec
                          case DeliveryJobScope
jobScope of
                            DJSGroup {DeliveryJobSpec
jobSpec :: DeliveryJobScope -> DeliveryJobSpec
jobSpec :: DeliveryJobSpec
jobSpec} -> do
                              [GroupMember]
ms <- (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [GroupMember]) -> CM [GroupMember])
-> (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> [GroupMemberId]
-> IO [GroupMember]
getGroupMembersByIndexes Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo [GroupMemberId]
introducedMemsIdxs
                              [GroupMember] -> CM [GroupMember]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GroupMember] -> CM [GroupMember])
-> [GroupMember] -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ (GroupMember -> Bool) -> [GroupMember] -> [GroupMember]
forall a. (a -> Bool) -> [a] -> [a]
filter GroupMember -> Bool
shouldForwardTo [GroupMember]
ms
                              where
                                shouldForwardTo :: GroupMember -> Bool
shouldForwardTo GroupMember
m
                                  | DeliveryJobSpec -> Bool
jobSpecImpliedPending DeliveryJobSpec
jobSpec = GroupMember -> Bool
memberCurrentOrPending GroupMember
m
                                  | Bool
otherwise = GroupMember -> Bool
memberCurrent GroupMember
m
                            DJSMemberSupport GroupMemberId
scopeGMId -> do
                              [GroupMember]
ms <- (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [GroupMember]) -> CM [GroupMember])
-> (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> GroupMemberId
-> [GroupMemberId]
-> IO [GroupMember]
getSupportScopeMembersByIndexes Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo GroupMemberId
scopeGMId [GroupMemberId]
introducedMemsIdxs
                              [GroupMember] -> CM [GroupMember]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GroupMember] -> CM [GroupMember])
-> [GroupMember] -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ (GroupMember -> Bool) -> [GroupMember] -> [GroupMember]
forall a. (a -> Bool) -> [a] -> [a]
filter GroupMember -> Bool
shouldForwardTo [GroupMember]
ms
                              where
                                shouldForwardTo :: GroupMember -> Bool
shouldForwardTo GroupMember
m = GroupMember -> GroupMemberId
groupMemberId' GroupMember
m GroupMemberId -> GroupMemberId -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberId
scopeGMId Bool -> Bool -> Bool
|| GroupMember -> Bool
currentModerator GroupMember
m
                                currentModerator :: GroupMember -> Bool
currentModerator m :: GroupMember
m@GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole} =
                                  GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
>= GroupMemberRole
GRModerator
                                    Bool -> Bool -> Bool
&& GroupMember -> Bool
memberCurrent GroupMember
m
                                    Bool -> Bool -> Bool
&& VersionRangeChat -> Version ChatVersion
forall v. VersionRange v -> Version v
maxVersion (GroupMember -> VersionRangeChat
memberChatVRange GroupMember
m) Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
groupKnockingVersion
              where
                deliver :: ByteString -> [GroupMember] -> CM ()
                deliver :: ByteString -> [GroupMember] -> CM ()
deliver ByteString
msgBody [GroupMember]
mems =
                  let mConns :: [Connection]
mConns = (GroupMember -> Maybe Connection) -> [GroupMember] -> [Connection]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((GroupMemberId, Connection) -> Connection)
-> Maybe (GroupMemberId, Connection) -> Maybe Connection
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GroupMemberId, Connection) -> Connection
forall a b. (a, b) -> b
snd (Maybe (GroupMemberId, Connection) -> Maybe Connection)
-> (GroupMember -> Maybe (GroupMemberId, Connection))
-> GroupMember
-> Maybe Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupMember -> Maybe (GroupMemberId, Connection)
readyMemberConn) [GroupMember]
mems
                      msgReqs :: [MsgReq]
msgReqs = [Connection] -> [MsgReq]
foldMemConns [Connection]
mConns
                   in ExceptT
  ChatError
  (ReaderT ChatController IO)
  [Either AgentErrorType (GroupMemberId, PQEncryption)]
-> CM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   [Either AgentErrorType (GroupMemberId, PQEncryption)]
 -> CM ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Either AgentErrorType (GroupMemberId, PQEncryption)]
-> CM ()
forall a b. (a -> b) -> a -> b
$ (AgentClient
 -> ExceptT
      AgentErrorType
      IO
      [Either AgentErrorType (GroupMemberId, PQEncryption)])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Either AgentErrorType (GroupMemberId, PQEncryption)]
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent (AgentClient
-> [MsgReq]
-> ExceptT
     AgentErrorType
     IO
     [Either AgentErrorType (GroupMemberId, PQEncryption)]
`sendMessages` [MsgReq]
msgReqs)
                  where
                    foldMemConns :: [Connection] -> [MsgReq]
                    foldMemConns :: [Connection] -> [MsgReq]
foldMemConns [Connection]
mConns = (Maybe Int, [MsgReq]) -> [MsgReq]
forall a b. (a, b) -> b
snd ((Maybe Int, [MsgReq]) -> [MsgReq])
-> (Maybe Int, [MsgReq]) -> [MsgReq]
forall a b. (a -> b) -> a -> b
$ (Connection -> (Maybe Int, [MsgReq]) -> (Maybe Int, [MsgReq]))
-> (Maybe Int, [MsgReq]) -> [Connection] -> (Maybe Int, [MsgReq])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' Connection -> (Maybe Int, [MsgReq]) -> (Maybe Int, [MsgReq])
addReq (Maybe Int
lastMemIdx_, []) [Connection]
mConns
                      where
                        lastMemIdx_ :: Maybe Int
lastMemIdx_ = let len :: Int
len = [Connection] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Connection]
mConns in if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
len else Maybe Int
forall a. Maybe a
Nothing
                        addReq :: Connection -> (Maybe Int, [MsgReq]) -> (Maybe Int, [MsgReq])
                        addReq :: Connection -> (Maybe Int, [MsgReq]) -> (Maybe Int, [MsgReq])
addReq Connection
conn (Maybe Int
memIdx_, [MsgReq]
reqs) =
                          (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
memIdx_, MsgReq
req MsgReq -> [MsgReq] -> [MsgReq]
forall a. a -> [a] -> [a]
: [MsgReq]
reqs)
                          where
                            req :: MsgReq
req = (Connection -> ByteString
aConnId Connection
conn, PQEncryption
PQEncOff, Bool -> MsgFlags
MsgFlags Bool
False, ValueOrRef ByteString
vrValue_)
                            vrValue_ :: ValueOrRef ByteString
vrValue_ = case Maybe Int
memIdx_ of
                              Maybe Int
Nothing -> Maybe Int -> ByteString -> ValueOrRef ByteString
forall a. Maybe Int -> a -> ValueOrRef a
VRValue Maybe Int
forall a. Maybe a
Nothing ByteString
msgBody -- sending to one member, do not reference body
                              Just Int
1 -> Maybe Int -> ByteString -> ValueOrRef ByteString
forall a. Maybe Int -> a -> ValueOrRef a
VRValue (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) ByteString
msgBody
                              Just Int
_ -> Int -> ValueOrRef ByteString
forall a. Int -> ValueOrRef a
VRRef Int
1