{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

module Simplex.Chat.Library.Internal where

import qualified Codec.Compression.Zstd as Z1
import Control.Applicative ((<|>))
import Control.Concurrent.STM (retry)
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson as J
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isDigit)
import Data.Containers.ListUtils (nubOrd)
import Data.Either (partitionEithers, rights)
import Data.Fixed (div')
import Data.Foldable (foldr')
import Data.Functor (($>))
import Data.Functor.Identity
import Data.Int (Int64)
import Data.List (find, foldl', mapAccumL, partition)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time (addUTCTime)
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToDiffTime)
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Files
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.Batch (MsgBatch (..), batchMessages)
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.Operators
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
import Simplex.Chat.Protocol
import Simplex.Chat.Store
import Simplex.Chat.Store.ContactRequest
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Files
import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.Messages
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
import Simplex.Chat.Types.MemberRelations
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Util (encryptFile, shuffle)
import Simplex.FileTransfer.Description (FileDescriptionURI (..), ValidFileDescription)
import qualified Simplex.FileTransfer.Description as FD
import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI)
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Client (getFastNetworkConfig, ipAddressProtected, withLockMap)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), ServerCfg (..))
import Simplex.Messaging.Agent.Lock (withLock)
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..))
import Simplex.Messaging.Compression (compressionLevel)
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (MsgBody, MsgFlags (..), ProtoServerWithAuth (..), ProtocolServer, ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer)
import qualified Simplex.Messaging.Protocol as SMP
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import System.FilePath (takeFileName, (</>))
import System.IO (Handle, IOMode (..), hFlush)
import UnliftIO.Concurrent (forkFinally, mkWeakThreadId)
import UnliftIO.Directory
import UnliftIO.IO (hClose, openFile)
import UnliftIO.STM

maxMsgReactions :: Int
maxMsgReactions :: Int
maxMsgReactions = Int
3

maxRcvMentions :: Int
maxRcvMentions :: Int
maxRcvMentions = Int
5

maxSndMentions :: Int
maxSndMentions :: Int
maxSndMentions = Int
3

withChatLock :: Text -> CM a -> CM a
withChatLock :: forall a. ContactName -> CM a -> CM a
withChatLock ContactName
name CM a
action = (ChatController -> Lock)
-> ExceptT ChatError (ReaderT ChatController IO) Lock
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> Lock
chatLock ExceptT ChatError (ReaderT ChatController IO) Lock
-> (Lock -> CM a) -> CM a
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
>>= \Lock
l -> Lock -> ContactName -> CM a -> CM a
forall (m :: * -> *) e a.
MonadUnliftIO m =>
Lock -> ContactName -> ExceptT e m a -> ExceptT e m a
withLock Lock
l ContactName
name CM a
action

withEntityLock :: Text -> ChatLockEntity -> CM a -> CM a
withEntityLock :: forall a. ContactName -> ChatLockEntity -> CM a -> CM a
withEntityLock ContactName
name ChatLockEntity
entity CM a
action = do
  Lock
chatLock <- (ChatController -> Lock)
-> ExceptT ChatError (ReaderT ChatController IO) Lock
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> Lock
chatLock
  TMap ChatLockEntity Lock
ls <- (ChatController -> TMap ChatLockEntity Lock)
-> ExceptT
     ChatError (ReaderT ChatController IO) (TMap ChatLockEntity Lock)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TMap ChatLockEntity Lock
entityLocks
  STM () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT ChatError (ReaderT ChatController IO) ())
-> STM () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Lock -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar Lock
chatLock) STM ()
forall a. STM a
retry
  TMap ChatLockEntity Lock
-> ChatLockEntity -> ContactName -> CM a -> CM a
forall k (m :: * -> *) a.
(Ord k, MonadUnliftIO m) =>
TMap k Lock -> k -> ContactName -> m a -> m a
withLockMap TMap ChatLockEntity Lock
ls ChatLockEntity
entity ContactName
name CM a
action

withInvitationLock :: Text -> ByteString -> CM a -> CM a
withInvitationLock :: forall a. ContactName -> ByteString -> CM a -> CM a
withInvitationLock ContactName
name = ContactName -> ChatLockEntity -> CM a -> CM a
forall a. ContactName -> ChatLockEntity -> CM a -> CM a
withEntityLock ContactName
name (ChatLockEntity -> CM a -> CM a)
-> (ByteString -> ChatLockEntity) -> ByteString -> CM a -> CM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ChatLockEntity
CLInvitation
{-# INLINE withInvitationLock #-}

withConnectionLock :: Text -> Int64 -> CM a -> CM a
withConnectionLock :: forall a. ContactName -> UserId -> CM a -> CM a
withConnectionLock ContactName
name = ContactName -> ChatLockEntity -> CM a -> CM a
forall a. ContactName -> ChatLockEntity -> CM a -> CM a
withEntityLock ContactName
name (ChatLockEntity -> CM a -> CM a)
-> (UserId -> ChatLockEntity) -> UserId -> CM a -> CM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserId -> ChatLockEntity
CLConnection
{-# INLINE withConnectionLock #-}

withContactLock :: Text -> ContactId -> CM a -> CM a
withContactLock :: forall a. ContactName -> UserId -> CM a -> CM a
withContactLock ContactName
name = ContactName -> ChatLockEntity -> CM a -> CM a
forall a. ContactName -> ChatLockEntity -> CM a -> CM a
withEntityLock ContactName
name (ChatLockEntity -> CM a -> CM a)
-> (UserId -> ChatLockEntity) -> UserId -> CM a -> CM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserId -> ChatLockEntity
CLContact
{-# INLINE withContactLock #-}

withGroupLock :: Text -> GroupId -> CM a -> CM a
withGroupLock :: forall a. ContactName -> UserId -> CM a -> CM a
withGroupLock ContactName
name = ContactName -> ChatLockEntity -> CM a -> CM a
forall a. ContactName -> ChatLockEntity -> CM a -> CM a
withEntityLock ContactName
name (ChatLockEntity -> CM a -> CM a)
-> (UserId -> ChatLockEntity) -> UserId -> CM a -> CM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserId -> ChatLockEntity
CLGroup
{-# INLINE withGroupLock #-}

withUserContactLock :: Text -> Int64 -> CM a -> CM a
withUserContactLock :: forall a. ContactName -> UserId -> CM a -> CM a
withUserContactLock ContactName
name = ContactName -> ChatLockEntity -> CM a -> CM a
forall a. ContactName -> ChatLockEntity -> CM a -> CM a
withEntityLock ContactName
name (ChatLockEntity -> CM a -> CM a)
-> (UserId -> ChatLockEntity) -> UserId -> CM a -> CM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserId -> ChatLockEntity
CLUserContact
{-# INLINE withUserContactLock #-}

withContactRequestLock :: Text -> Int64 -> CM a -> CM a
withContactRequestLock :: forall a. ContactName -> UserId -> CM a -> CM a
withContactRequestLock ContactName
name = ContactName -> ChatLockEntity -> CM a -> CM a
forall a. ContactName -> ChatLockEntity -> CM a -> CM a
withEntityLock ContactName
name (ChatLockEntity -> CM a -> CM a)
-> (UserId -> ChatLockEntity) -> UserId -> CM a -> CM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserId -> ChatLockEntity
CLContactRequest
{-# INLINE withContactRequestLock #-}

withFileLock :: Text -> Int64 -> CM a -> CM a
withFileLock :: forall a. ContactName -> UserId -> CM a -> CM a
withFileLock ContactName
name = ContactName -> ChatLockEntity -> CM a -> CM a
forall a. ContactName -> ChatLockEntity -> CM a -> CM a
withEntityLock ContactName
name (ChatLockEntity -> CM a -> CM a)
-> (UserId -> ChatLockEntity) -> UserId -> CM a -> CM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserId -> ChatLockEntity
CLFile
{-# INLINE withFileLock #-}

useServerCfgs :: forall p. UserProtocol p => SProtocolType p -> RandomAgentServers -> [(Text, ServerOperator)] -> [UserServer p] -> NonEmpty (ServerCfg p)
useServerCfgs :: forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p
-> RandomAgentServers
-> [(ContactName, ServerOperator)]
-> [UserServer p]
-> NonEmpty (ServerCfg p)
useServerCfgs SProtocolType p
p RandomAgentServers {NonEmpty (ServerCfg 'PSMP)
smpServers :: NonEmpty (ServerCfg 'PSMP)
smpServers :: RandomAgentServers -> NonEmpty (ServerCfg 'PSMP)
smpServers, NonEmpty (ServerCfg 'PXFTP)
xftpServers :: NonEmpty (ServerCfg 'PXFTP)
xftpServers :: RandomAgentServers -> NonEmpty (ServerCfg 'PXFTP)
xftpServers} [(ContactName, ServerOperator)]
opDomains =
  NonEmpty (ServerCfg p)
-> Maybe (NonEmpty (ServerCfg p)) -> NonEmpty (ServerCfg p)
forall a. a -> Maybe a -> a
fromMaybe (SProtocolType p -> NonEmpty (ServerCfg p)
rndAgentServers SProtocolType p
p) (Maybe (NonEmpty (ServerCfg p)) -> NonEmpty (ServerCfg p))
-> ([UserServer p] -> Maybe (NonEmpty (ServerCfg p)))
-> [UserServer p]
-> NonEmpty (ServerCfg p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ServerCfg p] -> Maybe (NonEmpty (ServerCfg p))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([ServerCfg p] -> Maybe (NonEmpty (ServerCfg p)))
-> ([UserServer p] -> [ServerCfg p])
-> [UserServer p]
-> Maybe (NonEmpty (ServerCfg p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SProtocolType p
-> [(ContactName, ServerOperator)]
-> [UserServer p]
-> [ServerCfg p]
forall (p :: ProtocolType) (s :: DBStored).
UserProtocol p =>
SProtocolType p
-> [(ContactName, ServerOperator)]
-> [UserServer' s p]
-> [ServerCfg p]
agentServerCfgs SProtocolType p
p [(ContactName, ServerOperator)]
opDomains
  where
    rndAgentServers :: SProtocolType p -> NonEmpty (ServerCfg p)
    rndAgentServers :: SProtocolType p -> NonEmpty (ServerCfg p)
rndAgentServers = \case
      SProtocolType p
SPSMP -> NonEmpty (ServerCfg p)
NonEmpty (ServerCfg 'PSMP)
smpServers
      SProtocolType p
SPXFTP -> NonEmpty (ServerCfg p)
NonEmpty (ServerCfg 'PXFTP)
xftpServers

contactCITimed :: Contact -> CM (Maybe CITimed)
contactCITimed :: Contact -> CM (Maybe CITimed)
contactCITimed Contact
ct = Bool -> Contact -> Maybe Int -> CM (Maybe CITimed)
sndContactCITimed Bool
False Contact
ct Maybe Int
forall a. Maybe a
Nothing

sndContactCITimed :: Bool -> Contact -> Maybe Int -> CM (Maybe CITimed)
sndContactCITimed :: Bool -> Contact -> Maybe Int -> CM (Maybe CITimed)
sndContactCITimed Bool
live = Bool -> Maybe (Maybe Int) -> Maybe Int -> CM (Maybe CITimed)
sndCITimed_ Bool
live (Maybe (Maybe Int) -> Maybe Int -> CM (Maybe CITimed))
-> (Contact -> Maybe (Maybe Int))
-> Contact
-> Maybe Int
-> CM (Maybe CITimed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contact -> Maybe (Maybe Int)
contactTimedTTL

sndGroupCITimed :: Bool -> GroupInfo -> Maybe Int -> CM (Maybe CITimed)
sndGroupCITimed :: Bool -> GroupInfo -> Maybe Int -> CM (Maybe CITimed)
sndGroupCITimed Bool
live = Bool -> Maybe (Maybe Int) -> Maybe Int -> CM (Maybe CITimed)
sndCITimed_ Bool
live (Maybe (Maybe Int) -> Maybe Int -> CM (Maybe CITimed))
-> (GroupInfo -> Maybe (Maybe Int))
-> GroupInfo
-> Maybe Int
-> CM (Maybe CITimed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupInfo -> Maybe (Maybe Int)
groupTimedTTL

sndCITimed_ :: Bool -> Maybe (Maybe Int) -> Maybe Int -> CM (Maybe CITimed)
sndCITimed_ :: Bool -> Maybe (Maybe Int) -> Maybe Int -> CM (Maybe CITimed)
sndCITimed_ Bool
live Maybe (Maybe Int)
chatTTL Maybe Int
itemTTL =
  Maybe Int
-> (Int -> ExceptT ChatError (ReaderT ChatController IO) CITimed)
-> CM (Maybe CITimed)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Maybe (Maybe Int)
chatTTL Maybe (Maybe Int) -> (Maybe Int -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe Int
itemTTL Maybe Int -> Maybe Int -> Maybe Int
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>)) ((Int -> ExceptT ChatError (ReaderT ChatController IO) CITimed)
 -> CM (Maybe CITimed))
-> (Int -> ExceptT ChatError (ReaderT ChatController IO) CITimed)
-> CM (Maybe CITimed)
forall a b. (a -> b) -> a -> b
$ \Int
ttl ->
    Int -> Maybe UTCTime -> CITimed
CITimed Int
ttl
      (Maybe UTCTime -> CITimed)
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe UTCTime)
-> ExceptT ChatError (ReaderT ChatController IO) CITimed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool
live
        then Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe UTCTime)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
forall a. Maybe a
Nothing
        else UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime)
-> (UTCTime -> UTCTime) -> UTCTime -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Int -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
ttl) (UTCTime -> Maybe UTCTime)
-> ExceptT ChatError (ReaderT ChatController IO) UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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

callTimed :: Contact -> ACIContent -> CM (Maybe CITimed)
callTimed :: Contact -> ACIContent -> CM (Maybe CITimed)
callTimed Contact
ct ACIContent
aciContent =
  case ACIContent -> Maybe CICallStatus
aciContentCallStatus ACIContent
aciContent of
    Just CICallStatus
callStatus
      | CICallStatus -> Bool
callComplete CICallStatus
callStatus -> do
          Contact -> CM (Maybe CITimed)
contactCITimed Contact
ct
    Maybe CICallStatus
_ -> Maybe CITimed -> CM (Maybe CITimed)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CITimed
forall a. Maybe a
Nothing
  where
    aciContentCallStatus :: ACIContent -> Maybe CICallStatus
    aciContentCallStatus :: ACIContent -> Maybe CICallStatus
aciContentCallStatus (ACIContent SMsgDirection d
_ (CISndCall CICallStatus
st Int
_)) = CICallStatus -> Maybe CICallStatus
forall a. a -> Maybe a
Just CICallStatus
st
    aciContentCallStatus (ACIContent SMsgDirection d
_ (CIRcvCall CICallStatus
st Int
_)) = CICallStatus -> Maybe CICallStatus
forall a. a -> Maybe a
Just CICallStatus
st
    aciContentCallStatus ACIContent
_ = Maybe CICallStatus
forall a. Maybe a
Nothing

toggleNtf :: GroupMember -> Bool -> CM ()
toggleNtf :: GroupMember
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
toggleNtf GroupMember
m Bool
ntfOn =
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupMember -> Bool
memberActive GroupMember
m) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$
    Maybe ByteString
-> (ByteString -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GroupMember -> Maybe ByteString
memberConnId GroupMember
m) ((ByteString -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (ByteString -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \ByteString
connId ->
      (AgentClient -> ExceptT AgentErrorType IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent (\AgentClient
a -> AgentClient -> ByteString -> Bool -> ExceptT AgentErrorType IO ()
toggleConnectionNtfs AgentClient
a ByteString
connId Bool
ntfOn) ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> ExceptT ChatError (ReaderT ChatController IO) ()
eToView

prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
prepareGroupMsg :: Connection
-> User
-> GroupInfo
-> Maybe MsgScope
-> MsgContent
-> Map ContactName MsgMention
-> Maybe UserId
-> Maybe CIForwardedFrom
-> Maybe FileInvitation
-> Maybe CITimed
-> Bool
-> ExceptT
     StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
prepareGroupMsg Connection
db User
user g :: GroupInfo
g@GroupInfo {GroupMember
membership :: GroupMember
membership :: GroupInfo -> GroupMember
membership} Maybe MsgScope
msgScope MsgContent
mc Map ContactName MsgMention
mentions Maybe UserId
quotedItemId_ Maybe CIForwardedFrom
itemForwarded Maybe FileInvitation
fInv_ Maybe CITimed
timed_ Bool
live = case (Maybe UserId
quotedItemId_, Maybe CIForwardedFrom
itemForwarded) of
  (Maybe UserId
Nothing, Maybe CIForwardedFrom
Nothing) ->
    let mc' :: MsgContainer
mc' = ExtMsgContent -> MsgContainer
MCSimple (ExtMsgContent -> MsgContainer) -> ExtMsgContent -> MsgContainer
forall a b. (a -> b) -> a -> b
$ MsgContent
-> Map ContactName MsgMention
-> Maybe FileInvitation
-> Maybe Int
-> Maybe Bool
-> Maybe MsgScope
-> ExtMsgContent
ExtMsgContent MsgContent
mc Map ContactName MsgMention
mentions Maybe FileInvitation
fInv_ (CITimed -> Int
ttl' (CITimed -> Int) -> Maybe CITimed -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CITimed
timed_) (Bool -> Maybe Bool
justTrue Bool
live) Maybe MsgScope
msgScope
     in (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
-> ExceptT
     StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MsgContainer -> ChatMsgEvent 'Json
XMsgNew MsgContainer
mc', Maybe (CIQuote 'CTGroup)
forall a. Maybe a
Nothing)
  (Maybe UserId
Nothing, Just CIForwardedFrom
_) ->
    let mc' :: MsgContainer
mc' = ExtMsgContent -> MsgContainer
MCForward (ExtMsgContent -> MsgContainer) -> ExtMsgContent -> MsgContainer
forall a b. (a -> b) -> a -> b
$ MsgContent
-> Map ContactName MsgMention
-> Maybe FileInvitation
-> Maybe Int
-> Maybe Bool
-> Maybe MsgScope
-> ExtMsgContent
ExtMsgContent MsgContent
mc Map ContactName MsgMention
mentions Maybe FileInvitation
fInv_ (CITimed -> Int
ttl' (CITimed -> Int) -> Maybe CITimed -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CITimed
timed_) (Bool -> Maybe Bool
justTrue Bool
live) Maybe MsgScope
msgScope
     in (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
-> ExceptT
     StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MsgContainer -> ChatMsgEvent 'Json
XMsgNew MsgContainer
mc', Maybe (CIQuote 'CTGroup)
forall a. Maybe a
Nothing)
  (Just UserId
quotedItemId, Maybe CIForwardedFrom
Nothing) -> do
    CChatItem SMsgDirection d
_ qci :: ChatItem 'CTGroup d
qci@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 SharedMsgId
itemSharedMsgId :: Maybe SharedMsgId
itemSharedMsgId :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> Maybe SharedMsgId
itemSharedMsgId}, Maybe MarkdownList
formattedText :: Maybe MarkdownList
formattedText :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe MarkdownList
formattedText, mentions :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Map ContactName CIMention
mentions = Map ContactName CIMention
quoteMentions, Maybe (CIFile d)
file :: Maybe (CIFile d)
file :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIFile d)
file} <-
      Connection
-> User
-> GroupInfo
-> UserId
-> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupCIWithReactions Connection
db User
user GroupInfo
g UserId
quotedItemId
    (MsgContent
origQmc, CIQDirection 'CTGroup
qd, Bool
sent, GroupMember {MemberId
memberId :: MemberId
memberId :: GroupMember -> MemberId
memberId}) <- ChatItem 'CTGroup d
-> GroupMember
-> ExceptT
     StoreError
     IO
     (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d
-> GroupMember
-> ExceptT
     StoreError
     IO
     (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
quoteData ChatItem 'CTGroup d
qci GroupMember
membership
    let msgRef :: MsgRef
msgRef = MsgRef {msgId :: Maybe SharedMsgId
msgId = Maybe SharedMsgId
itemSharedMsgId, sentAt :: UTCTime
sentAt = UTCTime
itemTs, Bool
sent :: Bool
sent :: Bool
sent, memberId :: Maybe MemberId
memberId = MemberId -> Maybe MemberId
forall a. a -> Maybe a
Just MemberId
memberId}
        qmc :: MsgContent
qmc = MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent
forall (d :: MsgDirection).
MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent
quoteContent MsgContent
mc MsgContent
origQmc Maybe (CIFile d)
file
        (MsgContent
qmc', Maybe MarkdownList
ft', Map ContactName CIMention
_) = MsgContent
-> Maybe MarkdownList
-> Map ContactName CIMention
-> (MsgContent, Maybe MarkdownList, Map ContactName CIMention)
updatedMentionNames MsgContent
qmc Maybe MarkdownList
formattedText Map ContactName CIMention
quoteMentions
        quotedItem :: CIQuote 'CTGroup
quotedItem = CIQuote {chatDir :: CIQDirection 'CTGroup
chatDir = CIQDirection 'CTGroup
qd, itemId :: Maybe UserId
itemId = UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
quotedItemId, sharedMsgId :: Maybe SharedMsgId
sharedMsgId = Maybe SharedMsgId
itemSharedMsgId, sentAt :: UTCTime
sentAt = UTCTime
itemTs, content :: MsgContent
content = MsgContent
qmc', formattedText :: Maybe MarkdownList
formattedText = Maybe MarkdownList
ft'}
        mc' :: MsgContainer
mc' = QuotedMsg -> ExtMsgContent -> MsgContainer
MCQuote QuotedMsg {MsgRef
msgRef :: MsgRef
msgRef :: MsgRef
msgRef, content :: MsgContent
content = MsgContent
qmc'} (MsgContent
-> Map ContactName MsgMention
-> Maybe FileInvitation
-> Maybe Int
-> Maybe Bool
-> Maybe MsgScope
-> ExtMsgContent
ExtMsgContent MsgContent
mc Map ContactName MsgMention
mentions Maybe FileInvitation
fInv_ (CITimed -> Int
ttl' (CITimed -> Int) -> Maybe CITimed -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CITimed
timed_) (Bool -> Maybe Bool
justTrue Bool
live) Maybe MsgScope
msgScope)
    (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
-> ExceptT
     StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MsgContainer -> ChatMsgEvent 'Json
XMsgNew MsgContainer
mc', CIQuote 'CTGroup -> Maybe (CIQuote 'CTGroup)
forall a. a -> Maybe a
Just CIQuote 'CTGroup
quotedItem)
  (Just UserId
_, Just CIForwardedFrom
_) -> StoreError
-> ExceptT
     StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
forall a. StoreError -> ExceptT StoreError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StoreError
SEInvalidQuote
  where
    quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
    quoteData :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d
-> GroupMember
-> ExceptT
     StoreError
     IO
     (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
quoteData ChatItem {meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta = CIMeta {itemDeleted :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> Maybe (CIDeleted c)
itemDeleted = Just CIDeleted c
_}} GroupMember
_ = StoreError
-> ExceptT
     StoreError
     IO
     (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
forall a. StoreError -> ExceptT StoreError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StoreError
SEInvalidQuote
    quoteData ChatItem {chatDir :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIDirection c d
chatDir = CIDirection c d
CIGroupSnd, content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content = CISndMsgContent MsgContent
qmc} GroupMember
membership' = (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
-> ExceptT
     StoreError
     IO
     (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MsgContent
qmc, CIQDirection 'CTGroup
CIQGroupSnd, Bool
True, GroupMember
membership')
    quoteData 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
qmc} GroupMember
_ = (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
-> ExceptT
     StoreError
     IO
     (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MsgContent
qmc, Maybe GroupMember -> CIQDirection 'CTGroup
CIQGroupRcv (Maybe GroupMember -> CIQDirection 'CTGroup)
-> Maybe GroupMember -> CIQDirection 'CTGroup
forall a b. (a -> b) -> a -> b
$ GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
m, Bool
False, GroupMember
m)
    quoteData ChatItem c d
_ GroupMember
_ = StoreError
-> ExceptT
     StoreError
     IO
     (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
forall a. StoreError -> ExceptT StoreError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StoreError
SEInvalidQuote

updatedMentionNames :: MsgContent -> Maybe MarkdownList -> Map MemberName CIMention -> (MsgContent, Maybe MarkdownList, Map MemberName CIMention)
updatedMentionNames :: MsgContent
-> Maybe MarkdownList
-> Map ContactName CIMention
-> (MsgContent, Maybe MarkdownList, Map ContactName CIMention)
updatedMentionNames MsgContent
mc Maybe MarkdownList
ft_ Map ContactName CIMention
mentions = case Maybe MarkdownList
ft_ of
  Just MarkdownList
ft
    | Bool -> Bool
not (MarkdownList -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null MarkdownList
ft) Bool -> Bool -> Bool
&& Bool -> Bool
not (Map ContactName CIMention -> Bool
forall a. Map ContactName a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map ContactName CIMention
mentions) Bool -> Bool -> Bool
&& Bool -> Bool
not (((ContactName, CIMention) -> Bool)
-> [(ContactName, CIMention)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ContactName, CIMention) -> Bool
sameName ([(ContactName, CIMention)] -> Bool)
-> [(ContactName, CIMention)] -> Bool
forall a b. (a -> b) -> a -> b
$ Map ContactName CIMention -> [(ContactName, CIMention)]
forall k a. Map k a -> [(k, a)]
M.assocs Map ContactName CIMention
mentions) ->
        let (Map ContactName CIMention
mentions', MarkdownList
ft') = (Map ContactName CIMention
 -> FormattedText -> (Map ContactName CIMention, FormattedText))
-> Map ContactName CIMention
-> MarkdownList
-> (Map ContactName CIMention, MarkdownList)
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Map ContactName CIMention
-> FormattedText -> (Map ContactName CIMention, FormattedText)
update Map ContactName CIMention
forall k a. Map k a
M.empty MarkdownList
ft
            text :: ContactName
text = [ContactName] -> ContactName
T.concat ([ContactName] -> ContactName) -> [ContactName] -> ContactName
forall a b. (a -> b) -> a -> b
$ (FormattedText -> ContactName) -> MarkdownList -> [ContactName]
forall a b. (a -> b) -> [a] -> [b]
map FormattedText -> ContactName
markdownText MarkdownList
ft'
         in (MsgContent
mc {text} :: MsgContent, MarkdownList -> Maybe MarkdownList
forall a. a -> Maybe a
Just MarkdownList
ft', Map ContactName CIMention
mentions')
  Maybe MarkdownList
_ -> (MsgContent
mc, Maybe MarkdownList
ft_, Map ContactName CIMention
mentions)
  where
    sameName :: (ContactName, CIMention) -> Bool
sameName (ContactName
name, CIMention {Maybe CIMentionMember
memberRef :: Maybe CIMentionMember
memberRef :: CIMention -> Maybe CIMentionMember
memberRef}) = case Maybe CIMentionMember
memberRef of
      Just CIMentionMember {ContactName
displayName :: ContactName
displayName :: CIMentionMember -> ContactName
displayName} -> case ContactName -> ContactName -> Maybe ContactName
T.stripPrefix ContactName
displayName ContactName
name of
        Just ContactName
rest
          | ContactName -> Bool
T.null ContactName
rest -> Bool
True
          | Bool
otherwise -> case ContactName -> Maybe (Char, ContactName)
T.uncons ContactName
rest of
              Just (Char
'_', ContactName
suffix) -> (Char -> Bool) -> ContactName -> Bool
T.all Char -> Bool
isDigit ContactName
suffix
              Maybe (Char, ContactName)
_ -> Bool
False
        Maybe ContactName
Nothing -> Bool
False
      Maybe CIMentionMember
Nothing -> Bool
True
    update :: Map ContactName CIMention
-> FormattedText -> (Map ContactName CIMention, FormattedText)
update Map ContactName CIMention
mentions' ft :: FormattedText
ft@(FormattedText Maybe Format
f ContactName
_) = case Maybe Format
f of
      Just (Mention ContactName
name) -> case ContactName -> Map ContactName CIMention -> Maybe CIMention
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ContactName
name Map ContactName CIMention
mentions of
        Just mm :: CIMention
mm@CIMention {Maybe CIMentionMember
memberRef :: CIMention -> Maybe CIMentionMember
memberRef :: Maybe CIMentionMember
memberRef} ->
          let name' :: ContactName
name' = Int -> ContactName -> ContactName
uniqueMentionName Int
0 (ContactName -> ContactName) -> ContactName -> ContactName
forall a b. (a -> b) -> a -> b
$ case Maybe CIMentionMember
memberRef of
                Just CIMentionMember {ContactName
displayName :: CIMentionMember -> ContactName
displayName :: ContactName
displayName} -> ContactName
displayName
                Maybe CIMentionMember
Nothing -> ContactName
name
           in (ContactName
-> CIMention
-> Map ContactName CIMention
-> Map ContactName CIMention
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ContactName
name' CIMention
mm Map ContactName CIMention
mentions', Maybe Format -> ContactName -> FormattedText
FormattedText (Format -> Maybe Format
forall a. a -> Maybe a
Just (Format -> Maybe Format) -> Format -> Maybe Format
forall a b. (a -> b) -> a -> b
$ ContactName -> Format
Mention ContactName
name') (Char
'@' Char -> ContactName -> ContactName
`T.cons` ContactName -> ContactName
viewName ContactName
name'))
        Maybe CIMention
Nothing -> (Map ContactName CIMention
mentions', FormattedText
ft)
      Maybe Format
_ -> (Map ContactName CIMention
mentions', FormattedText
ft)
      where
        uniqueMentionName :: Int -> Text -> Text
        uniqueMentionName :: Int -> ContactName -> ContactName
uniqueMentionName Int
pfx ContactName
name =
          let prefixed :: ContactName
prefixed = if Int
pfx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then ContactName
name else (ContactName
name ContactName -> Char -> ContactName
`T.snoc` Char
'_') ContactName -> ContactName -> ContactName
forall a. Semigroup a => a -> a -> a
<> Int -> ContactName
forall a. Show a => a -> ContactName
tshow Int
pfx
           in if ContactName
prefixed ContactName -> Map ContactName CIMention -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map ContactName CIMention
mentions' then Int -> ContactName -> ContactName
uniqueMentionName (Int
pfx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ContactName
name else ContactName
prefixed

getCIMentions :: DB.Connection -> User -> GroupInfo -> Maybe MarkdownList -> Map MemberName GroupMemberId -> ExceptT StoreError IO (Map MemberName CIMention)
getCIMentions :: Connection
-> User
-> GroupInfo
-> Maybe MarkdownList
-> Map ContactName UserId
-> ExceptT StoreError IO (Map ContactName CIMention)
getCIMentions Connection
db User
user GroupInfo {UserId
groupId :: UserId
groupId :: GroupInfo -> UserId
groupId} Maybe MarkdownList
ft_ Map ContactName UserId
mentions = case Maybe MarkdownList
ft_ of
  Just MarkdownList
ft | Bool -> Bool
not (MarkdownList -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null MarkdownList
ft) Bool -> Bool -> Bool
&& Bool -> Bool
not (Map ContactName UserId -> Bool
forall a. Map ContactName a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map ContactName UserId
mentions) -> do
    let msgMentions :: Set ContactName
msgMentions = [ContactName] -> Set ContactName
forall a. Ord a => [a] -> Set a
S.fromList ([ContactName] -> Set ContactName)
-> [ContactName] -> Set ContactName
forall a b. (a -> b) -> a -> b
$ MarkdownList -> [ContactName]
mentionedNames MarkdownList
ft
        n :: Int
n = Map ContactName UserId -> Int
forall k a. Map k a -> Int
M.size Map ContactName UserId
mentions
    -- prevent "invisible" and repeated-with-different-name mentions (when the same member is mentioned via another name)
    Bool -> ExceptT StoreError IO () -> ExceptT StoreError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxSndMentions Bool -> Bool -> Bool
&& (ContactName -> Bool) -> [ContactName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ContactName -> Set ContactName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set ContactName
msgMentions) (Map ContactName UserId -> [ContactName]
forall k a. Map k a -> [k]
M.keys Map ContactName UserId
mentions) Bool -> Bool -> Bool
&& Set UserId -> Int
forall a. Set a -> Int
S.size ([UserId] -> Set UserId
forall a. Ord a => [a] -> Set a
S.fromList ([UserId] -> Set UserId) -> [UserId] -> Set UserId
forall a b. (a -> b) -> a -> b
$ Map ContactName UserId -> [UserId]
forall k a. Map k a -> [a]
M.elems Map ContactName UserId
mentions) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n) (ExceptT StoreError IO () -> ExceptT StoreError IO ())
-> ExceptT StoreError IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$
      StoreError -> ExceptT StoreError IO ()
forall a. StoreError -> ExceptT StoreError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StoreError
SEInvalidMention
    (UserId -> ExceptT StoreError IO CIMention)
-> Map ContactName UserId
-> ExceptT StoreError IO (Map ContactName CIMention)
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) -> Map ContactName a -> m (Map ContactName b)
mapM (Connection
-> User -> UserId -> UserId -> ExceptT StoreError IO CIMention
getMentionedGroupMember Connection
db User
user UserId
groupId) Map ContactName UserId
mentions
  Maybe MarkdownList
_ -> Map ContactName CIMention
-> ExceptT StoreError IO (Map ContactName CIMention)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ContactName CIMention
forall k a. Map k a
M.empty

getRcvCIMentions :: DB.Connection -> User -> GroupInfo -> Maybe MarkdownList -> Map MemberName MsgMention -> IO (Map MemberName CIMention)
getRcvCIMentions :: Connection
-> User
-> GroupInfo
-> Maybe MarkdownList
-> Map ContactName MsgMention
-> IO (Map ContactName CIMention)
getRcvCIMentions Connection
db User
user GroupInfo {UserId
groupId :: GroupInfo -> UserId
groupId :: UserId
groupId} Maybe MarkdownList
ft_ Map ContactName MsgMention
mentions = case Maybe MarkdownList
ft_ of
  Just MarkdownList
ft
    | Bool -> Bool
not (MarkdownList -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null MarkdownList
ft) Bool -> Bool -> Bool
&& Bool -> Bool
not (Map ContactName MsgMention -> Bool
forall a. Map ContactName a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map ContactName MsgMention
mentions) ->
        let mentions' :: Map ContactName MsgMention
mentions' = Int
-> Map ContactName MsgMention
-> [ContactName]
-> Map ContactName MsgMention
uniqueMsgMentions Int
maxRcvMentions Map ContactName MsgMention
mentions ([ContactName] -> Map ContactName MsgMention)
-> [ContactName] -> Map ContactName MsgMention
forall a b. (a -> b) -> a -> b
$ MarkdownList -> [ContactName]
mentionedNames MarkdownList
ft
         in (MsgMention -> IO CIMention)
-> Map ContactName MsgMention -> IO (Map ContactName CIMention)
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) -> Map ContactName a -> m (Map ContactName b)
mapM (Connection -> User -> UserId -> MsgMention -> IO CIMention
getMentionedMemberByMemberId Connection
db User
user UserId
groupId) Map ContactName MsgMention
mentions'
  Maybe MarkdownList
_ -> Map ContactName CIMention -> IO (Map ContactName CIMention)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ContactName CIMention
forall k a. Map k a
M.empty

-- prevent "invisible" and repeated-with-different-name mentions
uniqueMsgMentions :: Int -> Map MemberName MsgMention -> [ContactName] -> Map MemberName MsgMention
uniqueMsgMentions :: Int
-> Map ContactName MsgMention
-> [ContactName]
-> Map ContactName MsgMention
uniqueMsgMentions Int
maxMentions Map ContactName MsgMention
mentions = Map ContactName MsgMention
-> Set MemberId
-> Int
-> [ContactName]
-> Map ContactName MsgMention
go Map ContactName MsgMention
forall k a. Map k a
M.empty Set MemberId
forall a. Set a
S.empty Int
0
  where
    go :: Map ContactName MsgMention
-> Set MemberId
-> Int
-> [ContactName]
-> Map ContactName MsgMention
go Map ContactName MsgMention
acc Set MemberId
_ Int
_ [] = Map ContactName MsgMention
acc
    go Map ContactName MsgMention
acc Set MemberId
seen Int
n (ContactName
name : [ContactName]
rest)
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxMentions = Map ContactName MsgMention
acc
      | Bool
otherwise = case ContactName -> Map ContactName MsgMention -> Maybe MsgMention
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ContactName
name Map ContactName MsgMention
mentions of
          Just mm :: MsgMention
mm@MsgMention {MemberId
memberId :: MemberId
memberId :: MsgMention -> MemberId
memberId}
            | MemberId -> Set MemberId -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember MemberId
memberId Set MemberId
seen ->
                Map ContactName MsgMention
-> Set MemberId
-> Int
-> [ContactName]
-> Map ContactName MsgMention
go (ContactName
-> MsgMention
-> Map ContactName MsgMention
-> Map ContactName MsgMention
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ContactName
name MsgMention
mm Map ContactName MsgMention
acc) (MemberId -> Set MemberId -> Set MemberId
forall a. Ord a => a -> Set a -> Set a
S.insert MemberId
memberId Set MemberId
seen) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [ContactName]
rest
          Maybe MsgMention
_ -> Map ContactName MsgMention
-> Set MemberId
-> Int
-> [ContactName]
-> Map ContactName MsgMention
go Map ContactName MsgMention
acc Set MemberId
seen Int
n [ContactName]
rest

getMessageMentions :: DB.Connection -> User -> GroupId -> Text -> IO (Map MemberName GroupMemberId)
getMessageMentions :: Connection
-> User -> UserId -> ContactName -> IO (Map ContactName UserId)
getMessageMentions Connection
db User
user UserId
gId ContactName
msg = case ContactName -> Maybe MarkdownList
parseMaybeMarkdownList ContactName
msg of
  Just MarkdownList
ft | Bool -> Bool
not (MarkdownList -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null MarkdownList
ft) -> [(ContactName, UserId)] -> Map ContactName UserId
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ContactName, UserId)] -> Map ContactName UserId)
-> ([Maybe (ContactName, UserId)] -> [(ContactName, UserId)])
-> [Maybe (ContactName, UserId)]
-> Map ContactName UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (ContactName, UserId)] -> [(ContactName, UserId)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ContactName, UserId)] -> Map ContactName UserId)
-> IO [Maybe (ContactName, UserId)] -> IO (Map ContactName UserId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ContactName -> IO (Maybe (ContactName, UserId)))
-> [ContactName] -> IO [Maybe (ContactName, UserId)]
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 ContactName -> IO (Maybe (ContactName, UserId))
get ([ContactName] -> [ContactName]
forall a. Ord a => [a] -> [a]
nubOrd ([ContactName] -> [ContactName]) -> [ContactName] -> [ContactName]
forall a b. (a -> b) -> a -> b
$ MarkdownList -> [ContactName]
mentionedNames MarkdownList
ft)
  Maybe MarkdownList
_ -> Map ContactName UserId -> IO (Map ContactName UserId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map ContactName UserId
forall k a. Map k a
M.empty
  where
    get :: ContactName -> IO (Maybe (ContactName, UserId))
get ContactName
name =
      (UserId -> (ContactName, UserId))
-> Maybe UserId -> Maybe (ContactName, UserId)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ContactName
name,) (Maybe UserId -> Maybe (ContactName, UserId))
-> (Either StoreError UserId -> Maybe UserId)
-> Either StoreError UserId
-> Maybe (ContactName, UserId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either StoreError UserId -> Maybe UserId
forall a b. Either a b -> Maybe b
eitherToMaybe
        (Either StoreError UserId -> Maybe (ContactName, UserId))
-> IO (Either StoreError UserId)
-> IO (Maybe (ContactName, UserId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT StoreError IO UserId -> IO (Either StoreError UserId)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Connection
-> User -> UserId -> ContactName -> ExceptT StoreError IO UserId
getGroupMemberIdByName Connection
db User
user UserId
gId ContactName
name)

msgContentTexts :: MsgContent -> (Text, Maybe MarkdownList)
msgContentTexts :: MsgContent -> (ContactName, Maybe MarkdownList)
msgContentTexts MsgContent
mc = let t :: ContactName
t = MsgContent -> ContactName
msgContentText MsgContent
mc in (ContactName
t, ContactName -> Maybe MarkdownList
parseMaybeMarkdownList ContactName
t)

ciContentTexts :: CIContent d -> (Text, Maybe MarkdownList)
ciContentTexts :: forall (d :: MsgDirection).
CIContent d -> (ContactName, Maybe MarkdownList)
ciContentTexts CIContent d
content = let t :: ContactName
t = CIContent d -> ContactName
forall (d :: MsgDirection). CIContent d -> ContactName
ciContentToText CIContent d
content in (ContactName
t, ContactName -> Maybe MarkdownList
parseMaybeMarkdownList ContactName
t)

quoteContent :: forall d. MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent
quoteContent :: forall (d :: MsgDirection).
MsgContent -> MsgContent -> Maybe (CIFile d) -> MsgContent
quoteContent MsgContent
mc MsgContent
qmc Maybe (CIFile d)
ciFile_
  | Bool
replaceContent = ContactName -> MsgContent
MCText ContactName
qTextOrFile
  | Bool
otherwise = case MsgContent
qmc of
      MCImage ContactName
_ ImageData
image -> ContactName -> ImageData -> MsgContent
MCImage ContactName
qTextOrFile ImageData
image
      MCFile ContactName
_ -> ContactName -> MsgContent
MCFile ContactName
qTextOrFile
      -- consider same for voice messages
      -- MCVoice _ voice -> MCVoice qTextOrFile voice
      MsgContent
_ -> MsgContent
qmc
  where
    -- if the message we're quoting with is one of the "large" MsgContents
    -- we replace the quote's content with MCText
    replaceContent :: Bool
replaceContent = case MsgContent
mc of
      MCText ContactName
_ -> Bool
False
      MCFile ContactName
_ -> Bool
False
      MCLink {} -> Bool
True
      MCImage {} -> Bool
True
      MCVideo {} -> Bool
True
      MCVoice {} -> Bool
False
      MCReport {} -> Bool
False
      MCChat {} -> Bool
True
      MCUnknown {} -> Bool
True
    qText :: ContactName
qText = MsgContent -> ContactName
msgContentText MsgContent
qmc
    getFileName :: CIFile d -> String
    getFileName :: CIFile d -> String
getFileName CIFile {String
fileName :: String
fileName :: forall (d :: MsgDirection). CIFile d -> String
fileName} = String
fileName
    qFileName :: ContactName
qFileName = ContactName
-> (CIFile d -> ContactName) -> Maybe (CIFile d) -> ContactName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ContactName
qText (String -> ContactName
T.pack (String -> ContactName)
-> (CIFile d -> String) -> CIFile d -> ContactName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CIFile d -> String
getFileName) Maybe (CIFile d)
ciFile_
    qTextOrFile :: ContactName
qTextOrFile = if ContactName -> Bool
T.null ContactName
qText then ContactName
qFileName else ContactName
qText

prohibitedGroupContent :: GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> MsgContent -> Maybe MarkdownList -> Maybe f -> Bool -> Maybe GroupFeature
prohibitedGroupContent :: forall f.
GroupInfo
-> GroupMember
-> Maybe GroupChatScopeInfo
-> MsgContent
-> Maybe MarkdownList
-> Maybe f
-> Bool
-> Maybe GroupFeature
prohibitedGroupContent gInfo :: GroupInfo
gInfo@GroupInfo {membership :: GroupInfo -> GroupMember
membership = GroupMember {memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
userRole}} GroupMember
m Maybe GroupChatScopeInfo
scopeInfo MsgContent
mc Maybe MarkdownList
ft Maybe f
file_ Bool
sent
  | MsgContent -> Bool
isVoice MsgContent
mc Bool -> Bool -> Bool
&& Bool -> Bool
not (SGroupFeature 'GFVoice -> GroupMember -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupMember -> GroupInfo -> Bool
groupFeatureMemberAllowed SGroupFeature 'GFVoice
SGFVoice GroupMember
m GroupInfo
gInfo) = GroupFeature -> Maybe GroupFeature
forall a. a -> Maybe a
Just GroupFeature
GFVoice
  | Maybe GroupChatScopeInfo -> Bool
forall a. Maybe a -> Bool
isNothing Maybe GroupChatScopeInfo
scopeInfo Bool -> Bool -> Bool
&& Bool -> Bool
not (MsgContent -> Bool
isVoice MsgContent
mc) Bool -> Bool -> Bool
&& Maybe f -> Bool
forall a. Maybe a -> Bool
isJust Maybe f
file_ Bool -> Bool -> Bool
&& Bool -> Bool
not (SGroupFeature 'GFFiles -> GroupMember -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupMember -> GroupInfo -> Bool
groupFeatureMemberAllowed SGroupFeature 'GFFiles
SGFFiles GroupMember
m GroupInfo
gInfo) = GroupFeature -> Maybe GroupFeature
forall a. a -> Maybe a
Just GroupFeature
GFFiles
  | Maybe GroupChatScopeInfo -> Bool
forall a. Maybe a -> Bool
isNothing Maybe GroupChatScopeInfo
scopeInfo Bool -> Bool -> Bool
&& MsgContent -> Bool
isReport MsgContent
mc Bool -> Bool -> Bool
&& (Bool
badReportUser Bool -> Bool -> Bool
|| Bool -> Bool
not (SGroupFeature 'GFReports -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureNoRoleI f =>
SGroupFeature f -> GroupInfo -> Bool
groupFeatureAllowed SGroupFeature 'GFReports
SGFReports GroupInfo
gInfo)) = GroupFeature -> Maybe GroupFeature
forall a. a -> Maybe a
Just GroupFeature
GFReports
  | Maybe GroupChatScopeInfo -> Bool
forall a. Maybe a -> Bool
isNothing Maybe GroupChatScopeInfo
scopeInfo Bool -> Bool -> Bool
&& GroupInfo -> GroupMember -> Maybe MarkdownList -> Bool
prohibitedSimplexLinks GroupInfo
gInfo GroupMember
m Maybe MarkdownList
ft = GroupFeature -> Maybe GroupFeature
forall a. a -> Maybe a
Just GroupFeature
GFSimplexLinks
  | Bool
otherwise = Maybe GroupFeature
forall a. Maybe a
Nothing
  where
    -- admins cannot send reports, non-admins cannot receive reports
    badReportUser :: Bool
badReportUser
      | Bool
sent = GroupMemberRole
userRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
>= GroupMemberRole
GRModerator
      | Bool
otherwise = GroupMemberRole
userRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
< GroupMemberRole
GRModerator

prohibitedSimplexLinks :: GroupInfo -> GroupMember -> Maybe MarkdownList -> Bool
prohibitedSimplexLinks :: GroupInfo -> GroupMember -> Maybe MarkdownList -> Bool
prohibitedSimplexLinks GroupInfo
gInfo GroupMember
m Maybe MarkdownList
ft =
  Bool -> Bool
not (SGroupFeature 'GFSimplexLinks -> GroupMember -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupMember -> GroupInfo -> Bool
groupFeatureMemberAllowed SGroupFeature 'GFSimplexLinks
SGFSimplexLinks GroupMember
m GroupInfo
gInfo)
    Bool -> Bool -> Bool
&& Bool -> (MarkdownList -> Bool) -> Maybe MarkdownList -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((FormattedText -> Bool) -> MarkdownList -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any FormattedText -> Bool
ftIsSimplexLink) Maybe MarkdownList
ft

ftIsSimplexLink :: FormattedText -> Bool
ftIsSimplexLink :: FormattedText -> Bool
ftIsSimplexLink FormattedText {Maybe Format
format :: Maybe Format
format :: FormattedText -> Maybe Format
format} = Bool -> (Format -> Bool) -> Maybe Format -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Format -> Bool
isSimplexLink Maybe Format
format

roundedFDCount :: Int -> Int
roundedFDCount :: Int -> Int
roundedFDCount Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Int
4
  | Bool
otherwise = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
4 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ (Integer
2 :: Integer) Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) :: Double) :: Integer)

xftpSndFileTransfer_ :: User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
xftpSndFileTransfer_ :: User
-> CryptoFile
-> Integer
-> Int
-> Maybe ContactOrGroup
-> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
xftpSndFileTransfer_ User
user file :: CryptoFile
file@(CryptoFile String
filePath Maybe CryptoFileArgs
cfArgs) Integer
fileSize Int
n Maybe ContactOrGroup
contactOrGroup_ = do
  let fileName :: String
fileName = String -> String
takeFileName String
filePath
      fInv :: FileInvitation
fInv = String -> Integer -> FileDescr -> FileInvitation
xftpFileInvitation String
fileName Integer
fileSize FileDescr
dummyFileDescr
  String
fsFilePath <- 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
filePath
  let srcFile :: CryptoFile
srcFile = String -> Maybe CryptoFileArgs -> CryptoFile
CryptoFile String
fsFilePath Maybe CryptoFileArgs
cfArgs
  ByteString
aFileId <- (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ByteString)
 -> CM ByteString)
-> (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> UserId
-> CryptoFile
-> Int
-> ExceptT AgentErrorType IO ByteString
xftpSendFile AgentClient
a (User -> UserId
aUserId User
user) CryptoFile
srcFile (Int -> Int
roundedFDCount Int
n)
  -- TODO CRSndFileStart event for XFTP
  Integer
chSize <- (ChatController -> Integer)
-> ExceptT ChatError (ReaderT ChatController IO) Integer
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ChatController -> Integer)
 -> ExceptT ChatError (ReaderT ChatController IO) Integer)
-> (ChatController -> Integer)
-> ExceptT ChatError (ReaderT ChatController IO) Integer
forall a b. (a -> b) -> a -> b
$ ChatConfig -> Integer
fileChunkSize (ChatConfig -> Integer)
-> (ChatController -> ChatConfig) -> ChatController -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config
  ft :: FileTransferMeta
ft@FileTransferMeta {UserId
fileId :: UserId
fileId :: FileTransferMeta -> UserId
fileId} <- (Connection -> IO FileTransferMeta) -> CM FileTransferMeta
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO FileTransferMeta) -> CM FileTransferMeta)
-> (Connection -> IO FileTransferMeta) -> CM FileTransferMeta
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> Maybe ContactOrGroup
-> CryptoFile
-> FileInvitation
-> AgentSndFileId
-> Maybe UserId
-> Integer
-> IO FileTransferMeta
createSndFileTransferXFTP Connection
db User
user Maybe ContactOrGroup
contactOrGroup_ CryptoFile
file FileInvitation
fInv (ByteString -> AgentSndFileId
AgentSndFileId ByteString
aFileId) Maybe UserId
forall a. Maybe a
Nothing Integer
chSize
  let fileSource :: Maybe CryptoFile
fileSource = CryptoFile -> Maybe CryptoFile
forall a. a -> Maybe a
Just (CryptoFile -> Maybe CryptoFile) -> CryptoFile -> Maybe CryptoFile
forall a b. (a -> b) -> a -> b
$ String -> Maybe CryptoFileArgs -> CryptoFile
CryptoFile String
filePath Maybe CryptoFileArgs
cfArgs
      ciFile :: CIFile 'MDSnd
ciFile = CIFile {UserId
fileId :: UserId
fileId :: UserId
fileId, String
fileName :: String
fileName :: String
fileName, Integer
fileSize :: Integer
fileSize :: Integer
fileSize, Maybe CryptoFile
fileSource :: Maybe CryptoFile
fileSource :: Maybe CryptoFile
fileSource, fileStatus :: CIFileStatus 'MDSnd
fileStatus = CIFileStatus 'MDSnd
CIFSSndStored, fileProtocol :: FileProtocol
fileProtocol = FileProtocol
FPXFTP}
  (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
-> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileInvitation
fInv, CIFile 'MDSnd
ciFile, FileTransferMeta
ft)

xftpSndFileRedirect :: User -> FileTransferId -> ValidFileDescription 'FRecipient -> CM FileTransferMeta
xftpSndFileRedirect :: User
-> UserId
-> ValidFileDescription 'FRecipient
-> CM FileTransferMeta
xftpSndFileRedirect User
user UserId
ftId ValidFileDescription 'FRecipient
vfd = do
  let fileName :: String
fileName = String
"redirect.yaml"
      file :: CryptoFile
file = String -> Maybe CryptoFileArgs -> CryptoFile
CryptoFile String
fileName Maybe CryptoFileArgs
forall a. Maybe a
Nothing
      fInv :: FileInvitation
fInv = String -> Integer -> FileDescr -> FileInvitation
xftpFileInvitation String
fileName (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ ValidFileDescription 'FRecipient -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ValidFileDescription 'FRecipient
vfd) FileDescr
dummyFileDescr
  ByteString
aFileId <- (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ByteString)
 -> CM ByteString)
-> (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> UserId
-> ValidFileDescription 'FRecipient
-> Int
-> ExceptT AgentErrorType IO ByteString
xftpSendDescription AgentClient
a (User -> UserId
aUserId User
user) ValidFileDescription 'FRecipient
vfd (Int -> Int
roundedFDCount Int
1)
  Integer
chSize <- (ChatController -> Integer)
-> ExceptT ChatError (ReaderT ChatController IO) Integer
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ChatController -> Integer)
 -> ExceptT ChatError (ReaderT ChatController IO) Integer)
-> (ChatController -> Integer)
-> ExceptT ChatError (ReaderT ChatController IO) Integer
forall a b. (a -> b) -> a -> b
$ ChatConfig -> Integer
fileChunkSize (ChatConfig -> Integer)
-> (ChatController -> ChatConfig) -> ChatController -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config
  (Connection -> IO FileTransferMeta) -> CM FileTransferMeta
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO FileTransferMeta) -> CM FileTransferMeta)
-> (Connection -> IO FileTransferMeta) -> CM FileTransferMeta
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> Maybe ContactOrGroup
-> CryptoFile
-> FileInvitation
-> AgentSndFileId
-> Maybe UserId
-> Integer
-> IO FileTransferMeta
createSndFileTransferXFTP Connection
db User
user Maybe ContactOrGroup
forall a. Maybe a
Nothing CryptoFile
file FileInvitation
fInv (ByteString -> AgentSndFileId
AgentSndFileId ByteString
aFileId) (UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
ftId) Integer
chSize

dummyFileDescr :: FileDescr
dummyFileDescr :: FileDescr
dummyFileDescr = FileDescr {fileDescrText :: ContactName
fileDescrText = ContactName
"", fileDescrPartNo :: Int
fileDescrPartNo = Int
0, fileDescrComplete :: Bool
fileDescrComplete = Bool
False}

cancelFilesInProgress :: User -> [CIFileInfo] -> CM ()
cancelFilesInProgress :: User
-> [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
cancelFilesInProgress User
user [CIFileInfo]
filesInfo = do
  let filesInfo' :: [CIFileInfo]
filesInfo' = (CIFileInfo -> Bool) -> [CIFileInfo] -> [CIFileInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CIFileInfo -> Bool) -> CIFileInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CIFileInfo -> Bool
fileEnded) [CIFileInfo]
filesInfo
  ([(FileTransferMeta, [SndFileTransfer])]
sfs, [RcvFileTransfer]
rfs) <- ReaderT
  ChatController
  IO
  ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
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
   ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer]))
-> ReaderT
     ChatController
     IO
     ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
forall a b. (a -> b) -> a -> b
$ [Either ChatError FileTransfer]
-> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
splitFTTypes ([Either ChatError FileTransfer]
 -> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer]))
-> ReaderT ChatController IO [Either ChatError FileTransfer]
-> ReaderT
     ChatController
     IO
     ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> [IO (Either ChatError FileTransfer)])
-> ReaderT ChatController IO [Either ChatError FileTransfer]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO (Either ChatError a)))
-> CM' (t (Either ChatError a))
withStoreBatch (\Connection
db -> (CIFileInfo -> IO (Either ChatError FileTransfer))
-> [CIFileInfo] -> [IO (Either ChatError FileTransfer)]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> CIFileInfo -> IO (Either ChatError FileTransfer)
getFT Connection
db) [CIFileInfo]
filesInfo')
  [RcvFileTransfer]
-> (RcvFileTransfer
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RcvFileTransfer]
rfs ((RcvFileTransfer
  -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (RcvFileTransfer
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \RcvFileTransfer {UserId
fileId :: UserId
fileId :: RcvFileTransfer -> UserId
fileId} -> ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 (UserId
-> (ChatController -> TVar (Map UserId Handle))
-> ReaderT ChatController IO ()
closeFileHandle UserId
fileId ChatController -> TVar (Map UserId Handle)
rcvFiles) ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
_ -> () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ((Connection -> [IO ()]) -> ReaderT ChatController IO ())
-> (Connection -> [IO ()])
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ChatController IO [Either ChatError ()]
-> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO [Either ChatError ()]
 -> ReaderT ChatController IO ())
-> ((Connection -> [IO ()])
    -> ReaderT ChatController IO [Either ChatError ()])
-> (Connection -> [IO ()])
-> ReaderT ChatController IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> [IO ()])
-> ReaderT ChatController IO [Either ChatError ()]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' ((Connection -> [IO ()])
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> [IO ()])
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ((FileTransferMeta, [SndFileTransfer]) -> IO ())
-> [(FileTransferMeta, [SndFileTransfer])] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> (FileTransferMeta, [SndFileTransfer]) -> IO ()
updateSndFileCancelled Connection
db) [(FileTransferMeta, [SndFileTransfer])]
sfs
  ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ((Connection -> [IO ()]) -> ReaderT ChatController IO ())
-> (Connection -> [IO ()])
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ChatController IO [Either ChatError ()]
-> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO [Either ChatError ()]
 -> ReaderT ChatController IO ())
-> ((Connection -> [IO ()])
    -> ReaderT ChatController IO [Either ChatError ()])
-> (Connection -> [IO ()])
-> ReaderT ChatController IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> [IO ()])
-> ReaderT ChatController IO [Either ChatError ()]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' ((Connection -> [IO ()])
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> [IO ()])
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> (RcvFileTransfer -> IO ()) -> [RcvFileTransfer] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> RcvFileTransfer -> IO ()
updateRcvFileCancelled Connection
db) [RcvFileTransfer]
rfs
  let xsfIds :: [(XFTPSndFile, UserId)]
xsfIds = ((FileTransferMeta, [SndFileTransfer])
 -> Maybe (XFTPSndFile, UserId))
-> [(FileTransferMeta, [SndFileTransfer])]
-> [(XFTPSndFile, UserId)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(FileTransferMeta {UserId
fileId :: FileTransferMeta -> UserId
fileId :: UserId
fileId, Maybe XFTPSndFile
xftpSndFile :: Maybe XFTPSndFile
xftpSndFile :: FileTransferMeta -> Maybe XFTPSndFile
xftpSndFile}, [SndFileTransfer]
_) -> (,UserId
fileId) (XFTPSndFile -> (XFTPSndFile, UserId))
-> Maybe XFTPSndFile -> Maybe (XFTPSndFile, UserId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe XFTPSndFile
xftpSndFile) [(FileTransferMeta, [SndFileTransfer])]
sfs
      xrfIds :: [(XFTPRcvFile, UserId)]
xrfIds = (RcvFileTransfer -> Maybe (XFTPRcvFile, UserId))
-> [RcvFileTransfer] -> [(XFTPRcvFile, UserId)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\RcvFileTransfer {UserId
fileId :: RcvFileTransfer -> UserId
fileId :: UserId
fileId, Maybe XFTPRcvFile
xftpRcvFile :: Maybe XFTPRcvFile
xftpRcvFile :: RcvFileTransfer -> Maybe XFTPRcvFile
xftpRcvFile} -> (,UserId
fileId) (XFTPRcvFile -> (XFTPRcvFile, UserId))
-> Maybe XFTPRcvFile -> Maybe (XFTPRcvFile, UserId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe XFTPRcvFile
xftpRcvFile) [RcvFileTransfer]
rfs
  ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User -> [(XFTPSndFile, UserId)] -> ReaderT ChatController IO ()
agentXFTPDeleteSndFilesRemote User
user [(XFTPSndFile, UserId)]
xsfIds
  ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ [(XFTPRcvFile, UserId)] -> ReaderT ChatController IO ()
agentXFTPDeleteRcvFiles [(XFTPRcvFile, UserId)]
xrfIds
  where
    fileEnded :: CIFileInfo -> Bool
fileEnded CIFileInfo {Maybe ACIFileStatus
fileStatus :: Maybe ACIFileStatus
fileStatus :: CIFileInfo -> Maybe ACIFileStatus
fileStatus} = case Maybe ACIFileStatus
fileStatus of
      Just (AFS SMsgDirection d
_ CIFileStatus d
status) -> CIFileStatus d -> Bool
forall (d :: MsgDirection). CIFileStatus d -> Bool
ciFileEnded CIFileStatus d
status
      Maybe ACIFileStatus
Nothing -> Bool
True
    getFT :: DB.Connection -> CIFileInfo -> IO (Either ChatError FileTransfer)
    getFT :: Connection -> CIFileInfo -> IO (Either ChatError FileTransfer)
getFT Connection
db CIFileInfo {UserId
fileId :: UserId
fileId :: CIFileInfo -> UserId
fileId} = ExceptT ChatError IO FileTransfer
-> IO (Either ChatError FileTransfer)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ChatError IO FileTransfer
 -> IO (Either ChatError FileTransfer))
-> (ExceptT StoreError IO FileTransfer
    -> ExceptT ChatError IO FileTransfer)
-> ExceptT StoreError IO FileTransfer
-> IO (Either ChatError FileTransfer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StoreError -> ChatError)
-> ExceptT StoreError IO FileTransfer
-> ExceptT ChatError IO FileTransfer
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT StoreError -> ChatError
ChatErrorStore (ExceptT StoreError IO FileTransfer
 -> IO (Either ChatError FileTransfer))
-> ExceptT StoreError IO FileTransfer
-> IO (Either ChatError FileTransfer)
forall a b. (a -> b) -> a -> b
$ Connection -> User -> UserId -> ExceptT StoreError IO FileTransfer
getFileTransfer Connection
db User
user UserId
fileId
    updateSndFileCancelled :: DB.Connection -> (FileTransferMeta, [SndFileTransfer]) -> IO ()
    updateSndFileCancelled :: Connection -> (FileTransferMeta, [SndFileTransfer]) -> IO ()
updateSndFileCancelled Connection
db (FileTransferMeta {UserId
fileId :: FileTransferMeta -> UserId
fileId :: UserId
fileId}, [SndFileTransfer]
sfts) = do
      Connection -> User -> UserId -> CIFileStatus 'MDSnd -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> UserId -> CIFileStatus d -> IO ()
updateFileCancelled Connection
db User
user UserId
fileId CIFileStatus 'MDSnd
CIFSSndCancelled
      [SndFileTransfer] -> (SndFileTransfer -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SndFileTransfer]
sfts ((SndFileTransfer -> IO ()) -> IO ())
-> (SndFileTransfer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SndFileTransfer
sft -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SndFileTransfer -> Bool
sndFTEnded SndFileTransfer
sft) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> SndFileTransfer -> FileStatus -> IO ()
updateSndFileStatus Connection
db SndFileTransfer
sft FileStatus
FSCancelled
    updateRcvFileCancelled :: DB.Connection -> RcvFileTransfer -> IO ()
    updateRcvFileCancelled :: Connection -> RcvFileTransfer -> IO ()
updateRcvFileCancelled Connection
db ft :: RcvFileTransfer
ft@RcvFileTransfer {UserId
fileId :: RcvFileTransfer -> UserId
fileId :: UserId
fileId} = do
      Connection -> User -> UserId -> CIFileStatus 'MDRcv -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> UserId -> CIFileStatus d -> IO ()
updateFileCancelled Connection
db User
user UserId
fileId CIFileStatus 'MDRcv
CIFSRcvCancelled
      Connection -> UserId -> FileStatus -> IO ()
updateRcvFileStatus Connection
db UserId
fileId FileStatus
FSCancelled
      Connection -> RcvFileTransfer -> IO ()
deleteRcvFileChunks Connection
db RcvFileTransfer
ft
    splitFTTypes :: [Either ChatError FileTransfer] -> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
    splitFTTypes :: [Either ChatError FileTransfer]
-> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
splitFTTypes = (FileTransfer
 -> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
 -> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer]))
-> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
-> [FileTransfer]
-> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FileTransfer
-> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
-> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
addFT ([], []) ([FileTransfer]
 -> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer]))
-> ([Either ChatError FileTransfer] -> [FileTransfer])
-> [Either ChatError FileTransfer]
-> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either ChatError FileTransfer] -> [FileTransfer]
forall a b. [Either a b] -> [b]
rights
      where
        addFT :: FileTransfer
-> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
-> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
addFT FileTransfer
f ([(FileTransferMeta, [SndFileTransfer])]
sfs, [RcvFileTransfer]
rfs) = case FileTransfer
f of
          FTSnd ft :: FileTransferMeta
ft@FileTransferMeta {Bool
cancelled :: Bool
cancelled :: FileTransferMeta -> Bool
cancelled} [SndFileTransfer]
sfts | Bool -> Bool
not Bool
cancelled -> ((FileTransferMeta
ft, [SndFileTransfer]
sfts) (FileTransferMeta, [SndFileTransfer])
-> [(FileTransferMeta, [SndFileTransfer])]
-> [(FileTransferMeta, [SndFileTransfer])]
forall a. a -> [a] -> [a]
: [(FileTransferMeta, [SndFileTransfer])]
sfs, [RcvFileTransfer]
rfs)
          FTRcv ft :: RcvFileTransfer
ft@RcvFileTransfer {Bool
cancelled :: Bool
cancelled :: RcvFileTransfer -> Bool
cancelled} | Bool -> Bool
not Bool
cancelled -> ([(FileTransferMeta, [SndFileTransfer])]
sfs, RcvFileTransfer
ft RcvFileTransfer -> [RcvFileTransfer] -> [RcvFileTransfer]
forall a. a -> [a] -> [a]
: [RcvFileTransfer]
rfs)
          FileTransfer
_ -> ([(FileTransferMeta, [SndFileTransfer])]
sfs, [RcvFileTransfer]
rfs)
    sndFTEnded :: SndFileTransfer -> Bool
sndFTEnded SndFileTransfer {FileStatus
fileStatus :: FileStatus
fileStatus :: SndFileTransfer -> FileStatus
fileStatus} = FileStatus
fileStatus FileStatus -> FileStatus -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus
FSCancelled Bool -> Bool -> Bool
|| FileStatus
fileStatus FileStatus -> FileStatus -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus
FSComplete

deleteFilesLocally :: [CIFileInfo] -> CM ()
deleteFilesLocally :: [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteFilesLocally [CIFileInfo]
files =
  (String -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
withFilesFolder ((String -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (String -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \String
filesFolder ->
    IO () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ((CIFileInfo -> IO ()) -> IO ())
-> (CIFileInfo -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CIFileInfo] -> (CIFileInfo -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CIFileInfo]
files ((CIFileInfo -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (CIFileInfo -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \CIFileInfo {Maybe String
filePath :: Maybe String
filePath :: CIFileInfo -> Maybe String
filePath} ->
      (String -> IO ()) -> Maybe String -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
delete (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
filesFolder String -> String -> String
</>)) Maybe String
filePath
  where
    delete :: FilePath -> IO ()
    delete :: String -> IO ()
delete String
fPath =
      String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
fPath IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchAll` \SomeException
_ ->
        String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removePathForcibly String
fPath 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 ()
    -- perform an action only if filesFolder is set (i.e. on mobile devices)
    withFilesFolder :: (FilePath -> CM ()) -> CM ()
    withFilesFolder :: (String -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
withFilesFolder String -> ExceptT ChatError (ReaderT ChatController IO) ()
action = (ChatController -> TVar (Maybe String))
-> ExceptT
     ChatError (ReaderT ChatController IO) (TVar (Maybe String))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Maybe String)
filesFolder ExceptT ChatError (ReaderT ChatController IO) (TVar (Maybe String))
-> (TVar (Maybe String)
    -> ExceptT ChatError (ReaderT ChatController IO) (Maybe String))
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe String)
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
>>= TVar (Maybe String)
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe String)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO ExceptT ChatError (ReaderT ChatController IO) (Maybe String)
-> (Maybe String
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
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
>>= (String -> ExceptT ChatError (ReaderT ChatController IO) ())
-> Maybe String -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> ExceptT ChatError (ReaderT ChatController IO) ()
action

deleteDirectCIs :: User -> Contact -> [CChatItem 'CTDirect] -> CM [ChatItemDeletion]
deleteDirectCIs :: User -> Contact -> [CChatItem 'CTDirect] -> CM [ChatItemDeletion]
deleteDirectCIs User
user Contact
ct [CChatItem 'CTDirect]
items = do
  let ciFilesInfo :: [CIFileInfo]
ciFilesInfo = (CChatItem 'CTDirect -> Maybe CIFileInfo)
-> [CChatItem 'CTDirect] -> [CIFileInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(CChatItem SMsgDirection d
_ ChatItem {Maybe (CIFile d)
file :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIFile d)
file :: Maybe (CIFile d)
file}) -> CIFile d -> CIFileInfo
forall (d :: MsgDirection).
MsgDirectionI d =>
CIFile d -> CIFileInfo
mkCIFileInfo (CIFile d -> CIFileInfo) -> Maybe (CIFile d) -> Maybe CIFileInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CIFile d)
file) [CChatItem 'CTDirect]
items
  User
-> [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteCIFiles User
user [CIFileInfo]
ciFilesInfo
  ([ChatError]
errs, [ChatItemDeletion]
deletions) <- ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItemDeletion])
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 ([ChatError], [ChatItemDeletion])
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      ([ChatError], [ChatItemDeletion]))
-> ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItemDeletion])
forall a b. (a -> b) -> a -> b
$ [Either ChatError ChatItemDeletion]
-> ([ChatError], [ChatItemDeletion])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ChatError ChatItemDeletion]
 -> ([ChatError], [ChatItemDeletion]))
-> ReaderT ChatController IO [Either ChatError ChatItemDeletion]
-> ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> [IO ChatItemDeletion])
-> ReaderT ChatController IO [Either ChatError ChatItemDeletion]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' (\Connection
db -> (CChatItem 'CTDirect -> IO ChatItemDeletion)
-> [CChatItem 'CTDirect] -> [IO ChatItemDeletion]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> CChatItem 'CTDirect -> IO ChatItemDeletion
deleteItem Connection
db) [CChatItem 'CTDirect]
items)
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ [ChatError] -> ChatEvent
CEvtChatErrors [ChatError]
errs
  [ChatItemDeletion] -> CM [ChatItemDeletion]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ChatItemDeletion]
deletions
  where
    deleteItem :: Connection -> CChatItem 'CTDirect -> IO ChatItemDeletion
deleteItem Connection
db (CChatItem SMsgDirection d
md ChatItem 'CTDirect d
ci) = do
      Connection -> User -> Contact -> ChatItem 'CTDirect d -> IO ()
forall (d :: MsgDirection).
Connection -> User -> Contact -> ChatItem 'CTDirect d -> IO ()
deleteDirectChatItem Connection
db User
user Contact
ct ChatItem 'CTDirect d
ci
      ChatItemDeletion -> IO ChatItemDeletion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatItemDeletion -> IO ChatItemDeletion)
-> ChatItemDeletion -> IO ChatItemDeletion
forall a b. (a -> b) -> a -> b
$ SMsgDirection d
-> Contact
-> ChatItem 'CTDirect d
-> Maybe (ChatItem 'CTDirect d)
-> ChatItemDeletion
forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d
-> Contact
-> ChatItem 'CTDirect d
-> Maybe (ChatItem 'CTDirect d)
-> ChatItemDeletion
contactDeletion SMsgDirection d
md Contact
ct ChatItem 'CTDirect d
ci Maybe (ChatItem 'CTDirect d)
forall a. Maybe a
Nothing

deleteGroupCIs :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [CChatItem 'CTGroup] -> Maybe GroupMember -> UTCTime -> CM [ChatItemDeletion]
deleteGroupCIs :: User
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> [CChatItem 'CTGroup]
-> Maybe GroupMember
-> UTCTime
-> CM [ChatItemDeletion]
deleteGroupCIs User
user GroupInfo
gInfo Maybe GroupChatScopeInfo
chatScopeInfo [CChatItem 'CTGroup]
items Maybe GroupMember
byGroupMember_ UTCTime
deletedTs = do
  let ciFilesInfo :: [CIFileInfo]
ciFilesInfo = (CChatItem 'CTGroup -> Maybe CIFileInfo)
-> [CChatItem 'CTGroup] -> [CIFileInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(CChatItem SMsgDirection d
_ ChatItem {Maybe (CIFile d)
file :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIFile d)
file :: Maybe (CIFile d)
file}) -> CIFile d -> CIFileInfo
forall (d :: MsgDirection).
MsgDirectionI d =>
CIFile d -> CIFileInfo
mkCIFileInfo (CIFile d -> CIFileInfo) -> Maybe (CIFile d) -> Maybe CIFileInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CIFile d)
file) [CChatItem 'CTGroup]
items
  User
-> [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteCIFiles User
user [CIFileInfo]
ciFilesInfo
  ([ChatError]
errs, [ChatItemDeletion]
deletions) <- ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItemDeletion])
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 ([ChatError], [ChatItemDeletion])
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      ([ChatError], [ChatItemDeletion]))
-> ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItemDeletion])
forall a b. (a -> b) -> a -> b
$ [Either ChatError ChatItemDeletion]
-> ([ChatError], [ChatItemDeletion])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ChatError ChatItemDeletion]
 -> ([ChatError], [ChatItemDeletion]))
-> ReaderT ChatController IO [Either ChatError ChatItemDeletion]
-> ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> [IO ChatItemDeletion])
-> ReaderT ChatController IO [Either ChatError ChatItemDeletion]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' (\Connection
db -> (CChatItem 'CTGroup -> IO ChatItemDeletion)
-> [CChatItem 'CTGroup] -> [IO ChatItemDeletion]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> CChatItem 'CTGroup -> IO ChatItemDeletion
deleteItem Connection
db) [CChatItem 'CTGroup]
items)
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ [ChatError] -> ChatEvent
CEvtChatErrors [ChatError]
errs
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  [ChatItemDeletion]
deletions' <- case Maybe GroupChatScopeInfo
chatScopeInfo of
    Maybe GroupChatScopeInfo
Nothing -> [ChatItemDeletion] -> CM [ChatItemDeletion]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ChatItemDeletion]
deletions
    Just scopeInfo :: GroupChatScopeInfo
scopeInfo@GCSIMemberSupport {Maybe GroupMember
groupMember_ :: Maybe GroupMember
groupMember_ :: GroupChatScopeInfo -> Maybe GroupMember
groupMember_} -> do
      let decStats :: (Int, Int, Int)
decStats = Maybe GroupMember -> [ChatItemDeletion] -> (Int, Int, Int)
countDeletedUnreadItems Maybe GroupMember
groupMember_ [ChatItemDeletion]
deletions
      GroupInfo
gInfo' <- (Connection -> IO GroupInfo) -> CM GroupInfo
forall a. (Connection -> IO a) -> CM a
withFastStore' ((Connection -> IO GroupInfo) -> CM GroupInfo)
-> (Connection -> IO GroupInfo) -> CM GroupInfo
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> GroupChatScopeInfo
-> (Int, Int, Int)
-> IO GroupInfo
updateGroupScopeUnreadStats Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo GroupChatScopeInfo
scopeInfo (Int, Int, Int)
decStats
      [ChatItemDeletion] -> CM [ChatItemDeletion]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ChatItemDeletion] -> CM [ChatItemDeletion])
-> [ChatItemDeletion] -> CM [ChatItemDeletion]
forall a b. (a -> b) -> a -> b
$ (ChatItemDeletion -> ChatItemDeletion)
-> [ChatItemDeletion] -> [ChatItemDeletion]
forall a b. (a -> b) -> [a] -> [b]
map (GroupInfo -> ChatItemDeletion -> ChatItemDeletion
updateDeletionGroupInfo GroupInfo
gInfo') [ChatItemDeletion]
deletions
  [ChatItemDeletion] -> CM [ChatItemDeletion]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ChatItemDeletion]
deletions'
  where
    deleteItem :: DB.Connection -> CChatItem 'CTGroup -> IO ChatItemDeletion
    deleteItem :: Connection -> CChatItem 'CTGroup -> IO ChatItemDeletion
deleteItem Connection
db (CChatItem SMsgDirection d
md ChatItem 'CTGroup d
ci) = do
      Maybe (ChatItem 'CTGroup d)
ci' <- case Maybe GroupMember
byGroupMember_ of
        Just GroupMember
m -> ChatItem 'CTGroup d -> Maybe (ChatItem 'CTGroup d)
forall a. a -> Maybe a
Just (ChatItem 'CTGroup d -> Maybe (ChatItem 'CTGroup d))
-> IO (ChatItem 'CTGroup d) -> IO (Maybe (ChatItem 'CTGroup d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup d
-> GroupMember
-> UTCTime
-> IO (ChatItem 'CTGroup d)
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 d
ci GroupMember
m UTCTime
deletedTs
        Maybe GroupMember
Nothing -> Maybe (ChatItem 'CTGroup d)
forall a. Maybe a
Nothing Maybe (ChatItem 'CTGroup d)
-> IO () -> IO (Maybe (ChatItem 'CTGroup d))
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
forall (d :: MsgDirection).
Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
deleteGroupChatItem Connection
db User
user GroupInfo
gInfo ChatItem 'CTGroup d
ci
      ChatItemDeletion -> IO ChatItemDeletion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatItemDeletion -> IO ChatItemDeletion)
-> ChatItemDeletion -> IO ChatItemDeletion
forall a b. (a -> b) -> a -> b
$ SMsgDirection d
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> ChatItem 'CTGroup d
-> Maybe (ChatItem 'CTGroup d)
-> ChatItemDeletion
forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> ChatItem 'CTGroup d
-> Maybe (ChatItem 'CTGroup d)
-> ChatItemDeletion
groupDeletion SMsgDirection d
md GroupInfo
gInfo Maybe GroupChatScopeInfo
chatScopeInfo ChatItem 'CTGroup d
ci Maybe (ChatItem 'CTGroup d)
ci'
    countDeletedUnreadItems :: Maybe GroupMember -> [ChatItemDeletion] -> (Int, Int, Int)
    countDeletedUnreadItems :: Maybe GroupMember -> [ChatItemDeletion] -> (Int, Int, Int)
countDeletedUnreadItems Maybe GroupMember
scopeMember_ = ((Int, Int, Int) -> ChatItemDeletion -> (Int, Int, Int))
-> (Int, Int, Int) -> [ChatItemDeletion] -> (Int, Int, Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, Int, Int) -> ChatItemDeletion -> (Int, Int, Int)
countItem (Int
0, Int
0, Int
0)
      where
        countItem :: (Int, Int, Int) -> ChatItemDeletion -> (Int, Int, Int)
        countItem :: (Int, Int, Int) -> ChatItemDeletion -> (Int, Int, Int)
countItem (!Int
unread, !Int
unanswered, !Int
mentions) ChatItemDeletion {AChatItem
deletedChatItem :: AChatItem
deletedChatItem :: ChatItemDeletion -> AChatItem
deletedChatItem}
          | AChatItem -> Bool
aChatItemIsRcvNew AChatItem
deletedChatItem =
              let unread' :: Int
unread' = Int
unread Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                  unanswered' :: Int
unanswered' = case (Maybe GroupMember
scopeMember_, AChatItem -> Maybe GroupMember
aChatItemRcvFromMember AChatItem
deletedChatItem) of
                    (Just GroupMember
scopeMember, Just GroupMember
rcvFromMember)
                      | GroupMember -> UserId
groupMemberId' GroupMember
rcvFromMember UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMember -> UserId
groupMemberId' GroupMember
scopeMember -> Int
unanswered Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                    (Maybe GroupMember, Maybe GroupMember)
_ -> Int
unanswered
                  mentions' :: Int
mentions' = if AChatItem -> Bool
isACIUserMention AChatItem
deletedChatItem then Int
mentions Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
mentions
               in (Int
unread', Int
unanswered', Int
mentions')
          | Bool
otherwise = (Int
unread, Int
unanswered, Int
mentions)
    updateDeletionGroupInfo :: GroupInfo -> ChatItemDeletion -> ChatItemDeletion
    updateDeletionGroupInfo :: GroupInfo -> ChatItemDeletion -> ChatItemDeletion
updateDeletionGroupInfo GroupInfo
gInfo' ChatItemDeletion {AChatItem
deletedChatItem :: ChatItemDeletion -> AChatItem
deletedChatItem :: AChatItem
deletedChatItem, Maybe AChatItem
toChatItem :: Maybe AChatItem
toChatItem :: ChatItemDeletion -> Maybe AChatItem
toChatItem} =
      ChatItemDeletion
        { deletedChatItem :: AChatItem
deletedChatItem = GroupInfo -> AChatItem -> AChatItem
updateACIGroupInfo GroupInfo
gInfo' AChatItem
deletedChatItem,
          toChatItem :: Maybe AChatItem
toChatItem = GroupInfo -> AChatItem -> AChatItem
updateACIGroupInfo GroupInfo
gInfo' (AChatItem -> AChatItem) -> Maybe AChatItem -> Maybe AChatItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AChatItem
toChatItem
        }

updateACIGroupInfo :: GroupInfo -> AChatItem -> AChatItem
updateACIGroupInfo :: GroupInfo -> AChatItem -> AChatItem
updateACIGroupInfo GroupInfo
gInfo' = \case
  AChatItem SChatType c
SCTGroup SMsgDirection d
dir (GroupChat GroupInfo
_gInfo Maybe GroupChatScopeInfo
chatScopeInfo) ChatItem c d
ci ->
    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 SMsgDirection d
dir (GroupInfo -> Maybe GroupChatScopeInfo -> ChatInfo 'CTGroup
GroupChat GroupInfo
gInfo' Maybe GroupChatScopeInfo
chatScopeInfo) ChatItem c d
ChatItem 'CTGroup d
ci
  AChatItem
aci -> AChatItem
aci

deleteGroupMemberCIs :: MsgDirectionI d => User -> GroupInfo -> GroupMember -> GroupMember -> SMsgDirection d -> CM ()
deleteGroupMemberCIs :: forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> GroupInfo
-> GroupMember
-> GroupMember
-> SMsgDirection d
-> ExceptT ChatError (ReaderT ChatController IO) ()
deleteGroupMemberCIs User
user GroupInfo
gInfo GroupMember
member GroupMember
byGroupMember SMsgDirection d
msgDir = do
  UTCTime
deletedTs <- 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
  [CIFileInfo]
filesInfo <- (Connection -> IO [CIFileInfo]) -> CM [CIFileInfo]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [CIFileInfo]) -> CM [CIFileInfo])
-> (Connection -> IO [CIFileInfo]) -> CM [CIFileInfo]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupMember
-> SMsgDirection d
-> UTCTime
-> IO [CIFileInfo]
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupMember
-> SMsgDirection d
-> UTCTime
-> IO [CIFileInfo]
deleteGroupMemberCIs_ Connection
db User
user GroupInfo
gInfo GroupMember
member GroupMember
byGroupMember SMsgDirection d
msgDir UTCTime
deletedTs
  User
-> [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteCIFiles User
user [CIFileInfo]
filesInfo

deleteGroupMembersCIs :: User -> GroupInfo -> [GroupMember] -> GroupMember -> CM ()
deleteGroupMembersCIs :: User
-> GroupInfo
-> [GroupMember]
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) ()
deleteGroupMembersCIs User
user GroupInfo
gInfo [GroupMember]
members GroupMember
byGroupMember = do
  UTCTime
deletedTs <- 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
  [CIFileInfo]
filesInfo <- (Connection -> IO [CIFileInfo]) -> CM [CIFileInfo]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [CIFileInfo]) -> CM [CIFileInfo])
-> (Connection -> IO [CIFileInfo]) -> CM [CIFileInfo]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ([[CIFileInfo]] -> [CIFileInfo])
-> IO [[CIFileInfo]] -> IO [CIFileInfo]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[CIFileInfo]] -> [CIFileInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[CIFileInfo]] -> IO [CIFileInfo])
-> IO [[CIFileInfo]] -> IO [CIFileInfo]
forall a b. (a -> b) -> a -> b
$ [GroupMember]
-> (GroupMember -> IO [CIFileInfo]) -> IO [[CIFileInfo]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GroupMember]
members ((GroupMember -> IO [CIFileInfo]) -> IO [[CIFileInfo]])
-> (GroupMember -> IO [CIFileInfo]) -> IO [[CIFileInfo]]
forall a b. (a -> b) -> a -> b
$ \GroupMember
m -> Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupMember
-> SMsgDirection 'MDRcv
-> UTCTime
-> IO [CIFileInfo]
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupMember
-> SMsgDirection d
-> UTCTime
-> IO [CIFileInfo]
deleteGroupMemberCIs_ Connection
db User
user GroupInfo
gInfo GroupMember
m GroupMember
byGroupMember SMsgDirection 'MDRcv
SMDRcv UTCTime
deletedTs
  User
-> [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteCIFiles User
user [CIFileInfo]
filesInfo

deleteGroupMemberCIs_ :: MsgDirectionI d => DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> SMsgDirection d -> UTCTime -> IO [CIFileInfo]
deleteGroupMemberCIs_ :: forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupMember
-> SMsgDirection d
-> UTCTime
-> IO [CIFileInfo]
deleteGroupMemberCIs_ Connection
db User
user GroupInfo
gInfo GroupMember
member GroupMember
byGroupMember SMsgDirection d
msgDir UTCTime
deletedTs = do
  [CIFileInfo]
fs <- Connection -> User -> GroupInfo -> GroupMember -> IO [CIFileInfo]
getGroupMemberFileInfo Connection
db User
user GroupInfo
gInfo GroupMember
member
  Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupMember
-> SMsgDirection d
-> UTCTime
-> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupMember
-> SMsgDirection d
-> UTCTime
-> IO ()
updateMemberCIsModerated Connection
db User
user GroupInfo
gInfo GroupMember
member GroupMember
byGroupMember SMsgDirection d
msgDir UTCTime
deletedTs
  [CIFileInfo] -> IO [CIFileInfo]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CIFileInfo]
fs

deleteLocalCIs :: User -> NoteFolder -> [CChatItem 'CTLocal] -> Bool -> Bool -> CM ChatResponse
deleteLocalCIs :: User
-> NoteFolder
-> [CChatItem 'CTLocal]
-> Bool
-> Bool
-> CM ChatResponse
deleteLocalCIs User
user NoteFolder
nf [CChatItem 'CTLocal]
items Bool
byUser Bool
timed = do
  let ciFilesInfo :: [CIFileInfo]
ciFilesInfo = (CChatItem 'CTLocal -> Maybe CIFileInfo)
-> [CChatItem 'CTLocal] -> [CIFileInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(CChatItem SMsgDirection d
_ ChatItem {Maybe (CIFile d)
file :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIFile d)
file :: Maybe (CIFile d)
file}) -> CIFile d -> CIFileInfo
forall (d :: MsgDirection).
MsgDirectionI d =>
CIFile d -> CIFileInfo
mkCIFileInfo (CIFile d -> CIFileInfo) -> Maybe (CIFile d) -> Maybe CIFileInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CIFile d)
file) [CChatItem 'CTLocal]
items
  [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteFilesLocally [CIFileInfo]
ciFilesInfo
  ([ChatError]
errs, [ChatItemDeletion]
deletions) <- ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItemDeletion])
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 ([ChatError], [ChatItemDeletion])
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      ([ChatError], [ChatItemDeletion]))
-> ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItemDeletion])
forall a b. (a -> b) -> a -> b
$ [Either ChatError ChatItemDeletion]
-> ([ChatError], [ChatItemDeletion])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ChatError ChatItemDeletion]
 -> ([ChatError], [ChatItemDeletion]))
-> ReaderT ChatController IO [Either ChatError ChatItemDeletion]
-> ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> [IO ChatItemDeletion])
-> ReaderT ChatController IO [Either ChatError ChatItemDeletion]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' (\Connection
db -> (CChatItem 'CTLocal -> IO ChatItemDeletion)
-> [CChatItem 'CTLocal] -> [IO ChatItemDeletion]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> CChatItem 'CTLocal -> IO ChatItemDeletion
deleteItem Connection
db) [CChatItem 'CTLocal]
items)
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ [ChatError] -> ChatEvent
CEvtChatErrors [ChatError]
errs
  ChatResponse -> CM ChatResponse
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatResponse -> CM ChatResponse)
-> ChatResponse -> CM ChatResponse
forall a b. (a -> b) -> a -> b
$ User -> [ChatItemDeletion] -> Bool -> Bool -> ChatResponse
CRChatItemsDeleted User
user [ChatItemDeletion]
deletions Bool
byUser Bool
timed
  where
    deleteItem :: Connection -> CChatItem 'CTLocal -> IO ChatItemDeletion
deleteItem Connection
db (CChatItem SMsgDirection d
md ChatItem 'CTLocal d
ci) = do
      Connection -> User -> NoteFolder -> ChatItem 'CTLocal d -> IO ()
forall (d :: MsgDirection).
Connection -> User -> NoteFolder -> ChatItem 'CTLocal d -> IO ()
deleteLocalChatItem Connection
db User
user NoteFolder
nf ChatItem 'CTLocal d
ci
      ChatItemDeletion -> IO ChatItemDeletion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatItemDeletion -> IO ChatItemDeletion)
-> ChatItemDeletion -> IO ChatItemDeletion
forall a b. (a -> b) -> a -> b
$ AChatItem -> Maybe AChatItem -> ChatItemDeletion
ChatItemDeletion (SMsgDirection d -> ChatItem 'CTLocal d -> AChatItem
forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d -> ChatItem 'CTLocal d -> AChatItem
nfItem SMsgDirection d
md ChatItem 'CTLocal d
ci) Maybe AChatItem
forall a. Maybe a
Nothing
    nfItem :: MsgDirectionI d => SMsgDirection d -> ChatItem 'CTLocal d -> AChatItem
    nfItem :: forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d -> ChatItem 'CTLocal d -> AChatItem
nfItem SMsgDirection d
md = SChatType 'CTLocal
-> SMsgDirection d
-> ChatInfo 'CTLocal
-> ChatItem 'CTLocal d
-> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem SChatType 'CTLocal
SCTLocal SMsgDirection d
md (NoteFolder -> ChatInfo 'CTLocal
LocalChat NoteFolder
nf)

deleteCIFiles :: User -> [CIFileInfo] -> CM ()
deleteCIFiles :: User
-> [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteCIFiles User
user [CIFileInfo]
filesInfo = do
  User
-> [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
cancelFilesInProgress User
user [CIFileInfo]
filesInfo
  [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteFilesLocally [CIFileInfo]
filesInfo

markDirectCIsDeleted :: User -> Contact -> [CChatItem 'CTDirect] -> UTCTime -> CM [ChatItemDeletion]
markDirectCIsDeleted :: User
-> Contact
-> [CChatItem 'CTDirect]
-> UTCTime
-> CM [ChatItemDeletion]
markDirectCIsDeleted User
user Contact
ct [CChatItem 'CTDirect]
items UTCTime
deletedTs = do
  let ciFilesInfo :: [CIFileInfo]
ciFilesInfo = (CChatItem 'CTDirect -> Maybe CIFileInfo)
-> [CChatItem 'CTDirect] -> [CIFileInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(CChatItem SMsgDirection d
_ ChatItem {Maybe (CIFile d)
file :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIFile d)
file :: Maybe (CIFile d)
file}) -> CIFile d -> CIFileInfo
forall (d :: MsgDirection).
MsgDirectionI d =>
CIFile d -> CIFileInfo
mkCIFileInfo (CIFile d -> CIFileInfo) -> Maybe (CIFile d) -> Maybe CIFileInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CIFile d)
file) [CChatItem 'CTDirect]
items
  User
-> [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
cancelFilesInProgress User
user [CIFileInfo]
ciFilesInfo
  ([ChatError]
errs, [ChatItemDeletion]
deletions) <- ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItemDeletion])
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 ([ChatError], [ChatItemDeletion])
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      ([ChatError], [ChatItemDeletion]))
-> ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItemDeletion])
forall a b. (a -> b) -> a -> b
$ [Either ChatError ChatItemDeletion]
-> ([ChatError], [ChatItemDeletion])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ChatError ChatItemDeletion]
 -> ([ChatError], [ChatItemDeletion]))
-> ReaderT ChatController IO [Either ChatError ChatItemDeletion]
-> ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> [IO ChatItemDeletion])
-> ReaderT ChatController IO [Either ChatError ChatItemDeletion]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' (\Connection
db -> (CChatItem 'CTDirect -> IO ChatItemDeletion)
-> [CChatItem 'CTDirect] -> [IO ChatItemDeletion]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> CChatItem 'CTDirect -> IO ChatItemDeletion
markDeleted Connection
db) [CChatItem 'CTDirect]
items)
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ [ChatError] -> ChatEvent
CEvtChatErrors [ChatError]
errs
  [ChatItemDeletion] -> CM [ChatItemDeletion]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ChatItemDeletion]
deletions
  where
    markDeleted :: Connection -> CChatItem 'CTDirect -> IO ChatItemDeletion
markDeleted Connection
db (CChatItem SMsgDirection d
md ChatItem 'CTDirect d
ci) = do
      ChatItem 'CTDirect d
ci' <- Connection
-> User
-> Contact
-> ChatItem 'CTDirect d
-> UTCTime
-> IO (ChatItem 'CTDirect d)
forall (d :: MsgDirection).
Connection
-> User
-> Contact
-> ChatItem 'CTDirect d
-> UTCTime
-> IO (ChatItem 'CTDirect d)
markDirectChatItemDeleted Connection
db User
user Contact
ct ChatItem 'CTDirect d
ci UTCTime
deletedTs
      ChatItemDeletion -> IO ChatItemDeletion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatItemDeletion -> IO ChatItemDeletion)
-> ChatItemDeletion -> IO ChatItemDeletion
forall a b. (a -> b) -> a -> b
$ SMsgDirection d
-> Contact
-> ChatItem 'CTDirect d
-> Maybe (ChatItem 'CTDirect d)
-> ChatItemDeletion
forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d
-> Contact
-> ChatItem 'CTDirect d
-> Maybe (ChatItem 'CTDirect d)
-> ChatItemDeletion
contactDeletion SMsgDirection d
md Contact
ct ChatItem 'CTDirect d
ci (ChatItem 'CTDirect d -> Maybe (ChatItem 'CTDirect d)
forall a. a -> Maybe a
Just ChatItem 'CTDirect d
ci')

markGroupCIsDeleted :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [CChatItem 'CTGroup] -> Maybe GroupMember -> UTCTime -> CM [ChatItemDeletion]
markGroupCIsDeleted :: User
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> [CChatItem 'CTGroup]
-> Maybe GroupMember
-> UTCTime
-> CM [ChatItemDeletion]
markGroupCIsDeleted User
user GroupInfo
gInfo Maybe GroupChatScopeInfo
chatScopeInfo [CChatItem 'CTGroup]
items Maybe GroupMember
byGroupMember_ UTCTime
deletedTs = do
  let ciFilesInfo :: [CIFileInfo]
ciFilesInfo = (CChatItem 'CTGroup -> Maybe CIFileInfo)
-> [CChatItem 'CTGroup] -> [CIFileInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(CChatItem SMsgDirection d
_ ChatItem {Maybe (CIFile d)
file :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIFile d)
file :: Maybe (CIFile d)
file}) -> CIFile d -> CIFileInfo
forall (d :: MsgDirection).
MsgDirectionI d =>
CIFile d -> CIFileInfo
mkCIFileInfo (CIFile d -> CIFileInfo) -> Maybe (CIFile d) -> Maybe CIFileInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CIFile d)
file) [CChatItem 'CTGroup]
items
  User
-> [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
cancelFilesInProgress User
user [CIFileInfo]
ciFilesInfo
  ([ChatError]
errs, [ChatItemDeletion]
deletions) <- ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItemDeletion])
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 ([ChatError], [ChatItemDeletion])
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      ([ChatError], [ChatItemDeletion]))
-> ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItemDeletion])
forall a b. (a -> b) -> a -> b
$ [Either ChatError ChatItemDeletion]
-> ([ChatError], [ChatItemDeletion])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ChatError ChatItemDeletion]
 -> ([ChatError], [ChatItemDeletion]))
-> ReaderT ChatController IO [Either ChatError ChatItemDeletion]
-> ReaderT ChatController IO ([ChatError], [ChatItemDeletion])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> [IO ChatItemDeletion])
-> ReaderT ChatController IO [Either ChatError ChatItemDeletion]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' (\Connection
db -> (CChatItem 'CTGroup -> IO ChatItemDeletion)
-> [CChatItem 'CTGroup] -> [IO ChatItemDeletion]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> CChatItem 'CTGroup -> IO ChatItemDeletion
markDeleted Connection
db) [CChatItem 'CTGroup]
items)
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ [ChatError] -> ChatEvent
CEvtChatErrors [ChatError]
errs
  [ChatItemDeletion] -> CM [ChatItemDeletion]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ChatItemDeletion]
deletions
  -- pure $ CRChatItemsDeleted user deletions byUser False
  where
    markDeleted :: Connection -> CChatItem 'CTGroup -> IO ChatItemDeletion
markDeleted Connection
db (CChatItem SMsgDirection d
md ChatItem 'CTGroup d
ci) = do
      ChatItem 'CTGroup d
ci' <- Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup d
-> Maybe GroupMember
-> UTCTime
-> IO (ChatItem 'CTGroup d)
forall (d :: MsgDirection).
Connection
-> User
-> GroupInfo
-> ChatItem 'CTGroup d
-> Maybe GroupMember
-> UTCTime
-> IO (ChatItem 'CTGroup d)
markGroupChatItemDeleted Connection
db User
user GroupInfo
gInfo ChatItem 'CTGroup d
ci Maybe GroupMember
byGroupMember_ UTCTime
deletedTs
      ChatItemDeletion -> IO ChatItemDeletion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatItemDeletion -> IO ChatItemDeletion)
-> ChatItemDeletion -> IO ChatItemDeletion
forall a b. (a -> b) -> a -> b
$ SMsgDirection d
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> ChatItem 'CTGroup d
-> Maybe (ChatItem 'CTGroup d)
-> ChatItemDeletion
forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> ChatItem 'CTGroup d
-> Maybe (ChatItem 'CTGroup d)
-> ChatItemDeletion
groupDeletion SMsgDirection d
md GroupInfo
gInfo Maybe GroupChatScopeInfo
chatScopeInfo ChatItem 'CTGroup d
ci (ChatItem 'CTGroup d -> Maybe (ChatItem 'CTGroup d)
forall a. a -> Maybe a
Just ChatItem 'CTGroup d
ci')

markGroupMemberCIsDeleted :: User -> GroupInfo -> GroupMember -> GroupMember -> CM ()
markGroupMemberCIsDeleted :: User
-> GroupInfo
-> GroupMember
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) ()
markGroupMemberCIsDeleted User
user GroupInfo
gInfo GroupMember
member GroupMember
byGroupMember = do
  UTCTime
deletedTs <- 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
  [CIFileInfo]
filesInfo <- (Connection -> IO [CIFileInfo]) -> CM [CIFileInfo]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [CIFileInfo]) -> CM [CIFileInfo])
-> (Connection -> IO [CIFileInfo]) -> CM [CIFileInfo]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupMember
-> UTCTime
-> IO [CIFileInfo]
markGroupMemberCIsDeleted_ Connection
db User
user GroupInfo
gInfo GroupMember
member GroupMember
byGroupMember UTCTime
deletedTs
  User
-> [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
cancelFilesInProgress User
user [CIFileInfo]
filesInfo

markGroupMembersCIsDeleted :: User -> GroupInfo -> [GroupMember] -> GroupMember -> CM ()
markGroupMembersCIsDeleted :: User
-> GroupInfo
-> [GroupMember]
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) ()
markGroupMembersCIsDeleted User
user GroupInfo
gInfo [GroupMember]
members GroupMember
byGroupMember = do
  UTCTime
deletedTs <- 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
  [CIFileInfo]
filesInfo <- (Connection -> IO [CIFileInfo]) -> CM [CIFileInfo]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [CIFileInfo]) -> CM [CIFileInfo])
-> (Connection -> IO [CIFileInfo]) -> CM [CIFileInfo]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ([[CIFileInfo]] -> [CIFileInfo])
-> IO [[CIFileInfo]] -> IO [CIFileInfo]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[CIFileInfo]] -> [CIFileInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[CIFileInfo]] -> IO [CIFileInfo])
-> IO [[CIFileInfo]] -> IO [CIFileInfo]
forall a b. (a -> b) -> a -> b
$ [GroupMember]
-> (GroupMember -> IO [CIFileInfo]) -> IO [[CIFileInfo]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GroupMember]
members ((GroupMember -> IO [CIFileInfo]) -> IO [[CIFileInfo]])
-> (GroupMember -> IO [CIFileInfo]) -> IO [[CIFileInfo]]
forall a b. (a -> b) -> a -> b
$ \GroupMember
m -> Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupMember
-> UTCTime
-> IO [CIFileInfo]
markGroupMemberCIsDeleted_ Connection
db User
user GroupInfo
gInfo GroupMember
m GroupMember
byGroupMember UTCTime
deletedTs
  User
-> [CIFileInfo] -> ExceptT ChatError (ReaderT ChatController IO) ()
cancelFilesInProgress User
user [CIFileInfo]
filesInfo

markGroupMemberCIsDeleted_ :: DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> UTCTime -> IO [CIFileInfo]
markGroupMemberCIsDeleted_ :: Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupMember
-> UTCTime
-> IO [CIFileInfo]
markGroupMemberCIsDeleted_ Connection
db User
user GroupInfo
gInfo GroupMember
member GroupMember
byGroupMember UTCTime
deletedTs = do
  [CIFileInfo]
fs <- Connection -> User -> GroupInfo -> GroupMember -> IO [CIFileInfo]
getGroupMemberFileInfo Connection
db User
user GroupInfo
gInfo GroupMember
member
  Connection
-> User
-> GroupInfo
-> GroupMember
-> GroupMember
-> UTCTime
-> IO ()
markMemberCIsDeleted Connection
db User
user GroupInfo
gInfo GroupMember
member GroupMember
byGroupMember UTCTime
deletedTs
  [CIFileInfo] -> IO [CIFileInfo]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CIFileInfo]
fs

groupDeletion :: MsgDirectionI d => SMsgDirection d -> GroupInfo -> Maybe GroupChatScopeInfo -> ChatItem 'CTGroup d -> Maybe (ChatItem 'CTGroup d) -> ChatItemDeletion
groupDeletion :: forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> ChatItem 'CTGroup d
-> Maybe (ChatItem 'CTGroup d)
-> ChatItemDeletion
groupDeletion SMsgDirection d
md GroupInfo
g Maybe GroupChatScopeInfo
chatScopeInfo ChatItem 'CTGroup d
ci Maybe (ChatItem 'CTGroup d)
ci' = AChatItem -> Maybe AChatItem -> ChatItemDeletion
ChatItemDeletion (ChatItem 'CTGroup d -> AChatItem
gItem ChatItem 'CTGroup d
ci) (ChatItem 'CTGroup d -> AChatItem
gItem (ChatItem 'CTGroup d -> AChatItem)
-> Maybe (ChatItem 'CTGroup d) -> Maybe AChatItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ChatItem 'CTGroup d)
ci')
  where
    gItem :: ChatItem 'CTGroup d -> AChatItem
gItem = 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 SMsgDirection d
md (GroupInfo -> Maybe GroupChatScopeInfo -> ChatInfo 'CTGroup
GroupChat GroupInfo
g Maybe GroupChatScopeInfo
chatScopeInfo)

contactDeletion :: MsgDirectionI d => SMsgDirection d -> Contact -> ChatItem 'CTDirect d -> Maybe (ChatItem 'CTDirect d) -> ChatItemDeletion
contactDeletion :: forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d
-> Contact
-> ChatItem 'CTDirect d
-> Maybe (ChatItem 'CTDirect d)
-> ChatItemDeletion
contactDeletion SMsgDirection d
md Contact
ct ChatItem 'CTDirect d
ci Maybe (ChatItem 'CTDirect d)
ci' = AChatItem -> Maybe AChatItem -> ChatItemDeletion
ChatItemDeletion (ChatItem 'CTDirect d -> AChatItem
ctItem ChatItem 'CTDirect d
ci) (ChatItem 'CTDirect d -> AChatItem
ctItem (ChatItem 'CTDirect d -> AChatItem)
-> Maybe (ChatItem 'CTDirect d) -> Maybe AChatItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ChatItem 'CTDirect d)
ci')
  where
    ctItem :: ChatItem 'CTDirect d -> AChatItem
ctItem = SChatType 'CTDirect
-> SMsgDirection d
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect d
-> 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 d
md (Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct)

updateCallItemStatus :: User -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> CM ()
updateCallItemStatus :: User
-> Contact
-> Call
-> WebRTCCallStatus
-> Maybe UserId
-> ExceptT ChatError (ReaderT ChatController IO) ()
updateCallItemStatus User
user ct :: Contact
ct@Contact {UserId
contactId :: UserId
contactId :: Contact -> UserId
contactId} Call {UserId
chatItemId :: UserId
chatItemId :: Call -> UserId
chatItemId} WebRTCCallStatus
receivedStatus Maybe UserId
msgId_ = do
  Maybe ACIContent
aciContent_ <- User
-> Contact -> UserId -> WebRTCCallStatus -> CM (Maybe ACIContent)
callStatusItemContent User
user Contact
ct UserId
chatItemId WebRTCCallStatus
receivedStatus
  Maybe ACIContent
-> (ACIContent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ACIContent
aciContent_ ((ACIContent -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (ACIContent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
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
-> UserId
-> ACIContent
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe UserId
-> ExceptT ChatError (ReaderT ChatController IO) ()
updateDirectChatItemView User
user Contact
ct UserId
chatItemId ACIContent
aciContent Bool
False Bool
False Maybe CITimed
timed_ Maybe UserId
msgId_
    Maybe UTCTime
-> (UTCTime -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (UTCTime -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$
      User
-> (ChatRef, UserId)
-> UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
startProximateTimedItemThread User
user (ChatType -> UserId -> Maybe GroupChatScope -> ChatRef
ChatRef ChatType
CTDirect UserId
contactId Maybe GroupChatScope
forall a. Maybe a
Nothing, UserId
chatItemId)

updateDirectChatItemView :: User -> Contact -> ChatItemId -> ACIContent -> Bool -> Bool -> Maybe CITimed -> Maybe MessageId -> CM ()
updateDirectChatItemView :: User
-> Contact
-> UserId
-> ACIContent
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe UserId
-> ExceptT ChatError (ReaderT ChatController IO) ()
updateDirectChatItemView User
user Contact
ct UserId
chatItemId (ACIContent SMsgDirection d
msgDir CIContent d
ciContent) Bool
edited Bool
live Maybe CITimed
timed_ Maybe UserId
msgId_ = do
  ChatItem 'CTDirect d
ci' <- (Connection -> ExceptT StoreError IO (ChatItem 'CTDirect d))
-> CM (ChatItem 'CTDirect d)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (ChatItem 'CTDirect d))
 -> CM (ChatItem 'CTDirect d))
-> (Connection -> ExceptT StoreError IO (ChatItem 'CTDirect d))
-> CM (ChatItem 'CTDirect d)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> Contact
-> UserId
-> CIContent d
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe UserId
-> ExceptT StoreError IO (ChatItem 'CTDirect d)
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> Contact
-> UserId
-> CIContent d
-> Bool
-> Bool
-> Maybe CITimed
-> Maybe UserId
-> ExceptT StoreError IO (ChatItem 'CTDirect d)
updateDirectChatItem Connection
db User
user Contact
ct UserId
chatItemId CIContent d
ciContent Bool
edited Bool
live Maybe CITimed
timed_ Maybe UserId
msgId_
  ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemUpdated User
user (SChatType 'CTDirect
-> SMsgDirection d
-> ChatInfo 'CTDirect
-> ChatItem 'CTDirect d
-> 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 d
msgDir (Contact -> ChatInfo 'CTDirect
DirectChat Contact
ct) ChatItem 'CTDirect d
ci')

callStatusItemContent :: User -> Contact -> ChatItemId -> WebRTCCallStatus -> CM (Maybe ACIContent)
callStatusItemContent :: User
-> Contact -> UserId -> WebRTCCallStatus -> CM (Maybe ACIContent)
callStatusItemContent User
user Contact {UserId
contactId :: Contact -> UserId
contactId :: UserId
contactId} UserId
chatItemId WebRTCCallStatus
receivedStatus = do
  CChatItem SMsgDirection d
msgDir ChatItem {meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta = CIMeta {UTCTime
updatedAt :: UTCTime
updatedAt :: forall (c :: ChatType) (d :: MsgDirection). CIMeta c d -> UTCTime
updatedAt}, CIContent d
content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content :: CIContent d
content} <-
    (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
-> UserId
-> UserId
-> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItem Connection
db User
user UserId
contactId UserId
chatItemId
  UTCTime
ts <- 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
  let Int
callDuration :: Int = NominalDiffTime -> Pico
nominalDiffTimeToSeconds (UTCTime
ts UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
updatedAt) Pico -> Pico -> Int
forall a b. (Real a, Integral b) => a -> a -> b
`div'` Pico
1
      callStatus :: Maybe CICallStatus
callStatus = case CIContent d
content of
        CISndCall CICallStatus
st Int
_ -> CICallStatus -> Maybe CICallStatus
forall a. a -> Maybe a
Just CICallStatus
st
        CIRcvCall CICallStatus
st Int
_ -> CICallStatus -> Maybe CICallStatus
forall a. a -> Maybe a
Just CICallStatus
st
        CIContent d
_ -> Maybe CICallStatus
forall a. Maybe a
Nothing
      newState_ :: Maybe (CICallStatus, Int)
newState_ = case (Maybe CICallStatus
callStatus, WebRTCCallStatus
receivedStatus) of
        (Just CICallStatus
CISCallProgress, WebRTCCallStatus
WCSConnected) -> Maybe (CICallStatus, Int)
forall a. Maybe a
Nothing -- if call in-progress received connected -> no change
        (Just CICallStatus
CISCallProgress, WebRTCCallStatus
WCSDisconnected) -> (CICallStatus, Int) -> Maybe (CICallStatus, Int)
forall a. a -> Maybe a
Just (CICallStatus
CISCallEnded, Int
callDuration) -- calculate in-progress duration
        (Just CICallStatus
CISCallProgress, WebRTCCallStatus
WCSFailed) -> (CICallStatus, Int) -> Maybe (CICallStatus, Int)
forall a. a -> Maybe a
Just (CICallStatus
CISCallEnded, Int
callDuration) -- whether call disconnected or failed
        (Just CICallStatus
CISCallPending, WebRTCCallStatus
WCSDisconnected) -> (CICallStatus, Int) -> Maybe (CICallStatus, Int)
forall a. a -> Maybe a
Just (CICallStatus
CISCallMissed, Int
0)
        (Just CICallStatus
CISCallEnded, WebRTCCallStatus
_) -> Maybe (CICallStatus, Int)
forall a. Maybe a
Nothing -- if call already ended or failed -> no change
        (Just CICallStatus
CISCallError, WebRTCCallStatus
_) -> Maybe (CICallStatus, Int)
forall a. Maybe a
Nothing
        (Just CICallStatus
_, WebRTCCallStatus
WCSConnecting) -> (CICallStatus, Int) -> Maybe (CICallStatus, Int)
forall a. a -> Maybe a
Just (CICallStatus
CISCallNegotiated, Int
0)
        (Just CICallStatus
_, WebRTCCallStatus
WCSConnected) -> (CICallStatus, Int) -> Maybe (CICallStatus, Int)
forall a. a -> Maybe a
Just (CICallStatus
CISCallProgress, Int
0) -- if call ended that was never connected, duration = 0
        (Just CICallStatus
_, WebRTCCallStatus
WCSDisconnected) -> (CICallStatus, Int) -> Maybe (CICallStatus, Int)
forall a. a -> Maybe a
Just (CICallStatus
CISCallEnded, Int
0)
        (Just CICallStatus
_, WebRTCCallStatus
WCSFailed) -> (CICallStatus, Int) -> Maybe (CICallStatus, Int)
forall a. a -> Maybe a
Just (CICallStatus
CISCallError, Int
0)
        (Maybe CICallStatus
Nothing, WebRTCCallStatus
_) -> Maybe (CICallStatus, Int)
forall a. Maybe a
Nothing -- some other content - we should never get here, but no exception is thrown
  Maybe ACIContent -> CM (Maybe ACIContent)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ACIContent -> CM (Maybe ACIContent))
-> Maybe ACIContent -> CM (Maybe ACIContent)
forall a b. (a -> b) -> a -> b
$ SMsgDirection d -> (CICallStatus, Int) -> ACIContent
forall (d :: MsgDirection).
SMsgDirection d -> (CICallStatus, Int) -> ACIContent
aciContent SMsgDirection d
msgDir ((CICallStatus, Int) -> ACIContent)
-> Maybe (CICallStatus, Int) -> Maybe ACIContent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CICallStatus, Int)
newState_
  where
    aciContent :: forall d. SMsgDirection d -> (CICallStatus, Int) -> ACIContent
    aciContent :: forall (d :: MsgDirection).
SMsgDirection d -> (CICallStatus, Int) -> ACIContent
aciContent SMsgDirection d
msgDir (CICallStatus
callStatus', Int
duration) = case SMsgDirection d
msgDir of
      SMsgDirection d
SMDSnd -> SMsgDirection 'MDSnd -> CIContent 'MDSnd -> ACIContent
forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d -> CIContent d -> ACIContent
ACIContent SMsgDirection 'MDSnd
SMDSnd (CIContent 'MDSnd -> ACIContent) -> CIContent 'MDSnd -> ACIContent
forall a b. (a -> b) -> a -> b
$ CICallStatus -> Int -> CIContent 'MDSnd
CISndCall CICallStatus
callStatus' Int
duration
      SMsgDirection d
SMDRcv -> SMsgDirection 'MDRcv -> CIContent 'MDRcv -> ACIContent
forall (d :: MsgDirection).
MsgDirectionI d =>
SMsgDirection d -> CIContent d -> ACIContent
ACIContent SMsgDirection 'MDRcv
SMDRcv (CIContent 'MDRcv -> ACIContent) -> CIContent 'MDRcv -> ACIContent
forall a b. (a -> b) -> a -> b
$ CICallStatus -> Int -> CIContent 'MDRcv
CIRcvCall CICallStatus
callStatus' Int
duration

-- mobile clients use file paths relative to app directory (e.g. for the reason ios app directory changes on updates),
-- so we have to differentiate between the file path stored in db and communicated with frontend, and the file path
-- used during file transfer for actual operations with file system
toFSFilePath :: FilePath -> CM' FilePath
toFSFilePath :: String -> ReaderT ChatController IO String
toFSFilePath String
f =
  String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
f (String -> String -> String
</> String
f) (Maybe String -> String)
-> ReaderT ChatController IO (Maybe String)
-> ReaderT ChatController IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ChatController -> TVar (Maybe String))
-> ReaderT ChatController IO (Maybe String)
forall a. (ChatController -> TVar a) -> CM' a
chatReadVar' ChatController -> TVar (Maybe String)
filesFolder)

setFileToEncrypt :: RcvFileTransfer -> CM RcvFileTransfer
setFileToEncrypt :: RcvFileTransfer -> CM RcvFileTransfer
setFileToEncrypt ft :: RcvFileTransfer
ft@RcvFileTransfer {UserId
fileId :: RcvFileTransfer -> UserId
fileId :: UserId
fileId} = do
  CryptoFileArgs
cfArgs <- STM CryptoFileArgs
-> ExceptT ChatError (ReaderT ChatController IO) CryptoFileArgs
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM CryptoFileArgs
 -> ExceptT ChatError (ReaderT ChatController IO) CryptoFileArgs)
-> (TVar ChaChaDRG -> STM CryptoFileArgs)
-> TVar ChaChaDRG
-> ExceptT ChatError (ReaderT ChatController IO) CryptoFileArgs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChaChaDRG -> STM CryptoFileArgs
CF.randomArgs (TVar ChaChaDRG
 -> ExceptT ChatError (ReaderT ChatController IO) CryptoFileArgs)
-> ExceptT ChatError (ReaderT ChatController IO) (TVar ChaChaDRG)
-> ExceptT ChatError (ReaderT ChatController IO) CryptoFileArgs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (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 -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> CryptoFileArgs -> IO ()
setFileCryptoArgs Connection
db UserId
fileId CryptoFileArgs
cfArgs
  RcvFileTransfer -> CM RcvFileTransfer
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RcvFileTransfer
ft :: RcvFileTransfer) {cryptoArgs = Just cfArgs}

receiveFile' :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM ChatResponse
receiveFile' :: User
-> RcvFileTransfer
-> Bool
-> Maybe Bool
-> Maybe String
-> CM ChatResponse
receiveFile' User
user RcvFileTransfer
ft Bool
userApprovedRelays Maybe Bool
rcvInline_ Maybe String
filePath_ = do
  (User -> AChatItem -> ChatResponse
CRRcvFileAccepted User
user (AChatItem -> ChatResponse)
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
-> CM ChatResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> User
-> RcvFileTransfer
-> Bool
-> Maybe Bool
-> Maybe String
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
acceptFileReceive User
user RcvFileTransfer
ft Bool
userApprovedRelays Maybe Bool
rcvInline_ Maybe String
filePath_) CM ChatResponse
-> (ChatError -> CM ChatResponse) -> CM ChatResponse
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> CM ChatResponse
processError
  where
    -- TODO AChatItem in Cancelled events
    processError :: ChatError -> CM ChatResponse
processError ChatError
e
      | ChatError -> Bool
rctFileCancelled ChatError
e = ChatResponse -> CM ChatResponse
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatResponse -> CM ChatResponse)
-> ChatResponse -> CM ChatResponse
forall a b. (a -> b) -> a -> b
$ User -> RcvFileTransfer -> ChatResponse
CRRcvFileAcceptedSndCancelled User
user RcvFileTransfer
ft
      | Bool
otherwise = ChatError -> CM ChatResponse
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
e

receiveFileEvt' :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM ChatEvent
receiveFileEvt' :: User
-> RcvFileTransfer
-> Bool
-> Maybe Bool
-> Maybe String
-> CM ChatEvent
receiveFileEvt' User
user RcvFileTransfer
ft Bool
userApprovedRelays Maybe Bool
rcvInline_ Maybe String
filePath_ = do
  (User -> AChatItem -> ChatEvent
CEvtRcvFileAccepted User
user (AChatItem -> ChatEvent)
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
-> CM ChatEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> User
-> RcvFileTransfer
-> Bool
-> Maybe Bool
-> Maybe String
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
acceptFileReceive User
user RcvFileTransfer
ft Bool
userApprovedRelays Maybe Bool
rcvInline_ Maybe String
filePath_) CM ChatEvent -> (ChatError -> CM ChatEvent) -> CM ChatEvent
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> CM ChatEvent
processError
  where
    -- TODO AChatItem in Cancelled events
    processError :: ChatError -> CM ChatEvent
processError ChatError
e
      | ChatError -> Bool
rctFileCancelled ChatError
e = ChatEvent -> CM ChatEvent
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatEvent -> CM ChatEvent) -> ChatEvent -> CM ChatEvent
forall a b. (a -> b) -> a -> b
$ User -> RcvFileTransfer -> ChatEvent
CEvtRcvFileAcceptedSndCancelled User
user RcvFileTransfer
ft
      | Bool
otherwise = ChatError -> CM ChatEvent
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
e

rctFileCancelled :: ChatError -> Bool
rctFileCancelled :: ChatError -> Bool
rctFileCancelled = \case
  ChatErrorAgent (SMP String
_ ErrorType
SMP.AUTH) AgentConnId
_ Maybe ConnectionEntity
_ -> Bool
True
  ChatErrorAgent (CONN ConnectionErrorType
DUPLICATE String
_) AgentConnId
_ Maybe ConnectionEntity
_ -> Bool
True
  ChatError
_ -> Bool
False

acceptFileReceive :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM AChatItem
acceptFileReceive :: User
-> RcvFileTransfer
-> Bool
-> Maybe Bool
-> Maybe String
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
acceptFileReceive user :: User
user@User {UserId
userId :: UserId
userId :: User -> UserId
userId} RcvFileTransfer {UserId
fileId :: RcvFileTransfer -> UserId
fileId :: UserId
fileId, Maybe XFTPRcvFile
xftpRcvFile :: RcvFileTransfer -> Maybe XFTPRcvFile
xftpRcvFile :: Maybe XFTPRcvFile
xftpRcvFile, fileInvitation :: RcvFileTransfer -> FileInvitation
fileInvitation = FileInvitation {fileName :: FileInvitation -> String
fileName = String
fName, Maybe ConnReqInvitation
fileConnReq :: Maybe ConnReqInvitation
fileConnReq :: FileInvitation -> Maybe ConnReqInvitation
fileConnReq, Maybe InlineFileMode
fileInline :: Maybe InlineFileMode
fileInline :: FileInvitation -> Maybe InlineFileMode
fileInline, Integer
fileSize :: Integer
fileSize :: FileInvitation -> Integer
fileSize}, RcvFileStatus
fileStatus :: RcvFileStatus
fileStatus :: RcvFileTransfer -> RcvFileStatus
fileStatus, Maybe UserId
grpMemberId :: Maybe UserId
grpMemberId :: RcvFileTransfer -> Maybe UserId
grpMemberId, Maybe CryptoFileArgs
cryptoArgs :: Maybe CryptoFileArgs
cryptoArgs :: RcvFileTransfer -> Maybe CryptoFileArgs
cryptoArgs} Bool
userApprovedRelays Maybe Bool
rcvInline_ Maybe String
filePath_ = do
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RcvFileStatus
fileStatus RcvFileStatus -> RcvFileStatus -> Bool
forall a. Eq a => a -> a -> Bool
== RcvFileStatus
RFSNew) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ case RcvFileStatus
fileStatus of
    RFSCancelled Maybe String
_ -> ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEFileCancelled String
fName
    RcvFileStatus
_ -> ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEFileAlreadyReceiving String
fName
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  case (Maybe XFTPRcvFile
xftpRcvFile, Maybe ConnReqInvitation
fileConnReq) of
    -- XFTP
    (Just XFTPRcvFile {userApprovedRelays :: XFTPRcvFile -> Bool
userApprovedRelays = Bool
approvedBeforeReady}, Maybe ConnReqInvitation
_) -> do
      let userApproved :: Bool
userApproved = Bool
approvedBeforeReady Bool -> Bool -> Bool
|| Bool
userApprovedRelays
      String
filePath <- UserId
-> Maybe String
-> String
-> Bool
-> ExceptT ChatError (ReaderT ChatController IO) String
getRcvFilePath UserId
fileId Maybe String
filePath_ String
fName Bool
False
      (AChatItem
ci, RcvFileDescr
rfd) <- (Connection -> ExceptT StoreError IO (AChatItem, RcvFileDescr))
-> CM (AChatItem, RcvFileDescr)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (AChatItem, RcvFileDescr))
 -> CM (AChatItem, RcvFileDescr))
-> (Connection -> ExceptT StoreError IO (AChatItem, RcvFileDescr))
-> CM (AChatItem, RcvFileDescr)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
        -- marking file as accepted and reading description in the same transaction
        -- to prevent race condition with appending description
        AChatItem
ci <- Connection
-> VersionRangeChat
-> User
-> UserId
-> String
-> Bool
-> ExceptT StoreError IO AChatItem
xftpAcceptRcvFT Connection
db VersionRangeChat
vr User
user UserId
fileId String
filePath Bool
userApproved
        RcvFileDescr
rfd <- Connection -> UserId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrByRcvFileId Connection
db UserId
fileId
        (AChatItem, RcvFileDescr)
-> ExceptT StoreError IO (AChatItem, RcvFileDescr)
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AChatItem
ci, RcvFileDescr
rfd)
      User
-> UserId
-> RcvFileDescr
-> Bool
-> Maybe CryptoFileArgs
-> ExceptT ChatError (ReaderT ChatController IO) ()
receiveViaCompleteFD User
user UserId
fileId RcvFileDescr
rfd Bool
userApproved Maybe CryptoFileArgs
cryptoArgs
      AChatItem
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AChatItem
ci
    (Maybe XFTPRcvFile
Nothing, Just ConnReqInvitation
_fileConnReq) -> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType
 -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEException String
"accepting file via a separate connection is deprecated"
    -- group & direct file protocol
    (Maybe XFTPRcvFile, Maybe ConnReqInvitation)
_ -> do
      ChatRef
chatRef <- (Connection -> ExceptT StoreError IO ChatRef) -> CM ChatRef
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO ChatRef) -> CM ChatRef)
-> (Connection -> ExceptT StoreError IO ChatRef) -> CM ChatRef
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> UserId -> ExceptT StoreError IO ChatRef
getChatRefByFileId Connection
db User
user UserId
fileId
      case (ChatRef
chatRef, Maybe UserId
grpMemberId) of
        (ChatRef ChatType
CTDirect UserId
contactId Maybe GroupChatScope
_, Maybe UserId
Nothing) -> 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
-> UserId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user UserId
contactId
          (ChatMsgEvent 'Json
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
acceptFile ((ChatMsgEvent 'Json
  -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> (ChatMsgEvent 'Json
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a b. (a -> b) -> a -> b
$ \ChatMsgEvent 'Json
msg -> ExceptT ChatError (ReaderT ChatController IO) (SndMessage, UserId)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) (SndMessage, UserId)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User
-> Contact
-> ChatMsgEvent 'Json
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> ChatMsgEvent e
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
sendDirectContactMessage User
user Contact
ct ChatMsgEvent 'Json
msg
        (ChatRef ChatType
CTGroup UserId
groupId Maybe GroupChatScope
_, Just UserId
memId) -> do
          GroupMember {Maybe Connection
activeConn :: Maybe Connection
activeConn :: GroupMember -> Maybe Connection
activeConn} <- (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
-> UserId
-> UserId
-> ExceptT StoreError IO GroupMember
getGroupMember Connection
db VersionRangeChat
vr User
user UserId
groupId UserId
memId
          case Maybe Connection
activeConn of
            Just Connection
conn -> do
              (ChatMsgEvent 'Json
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
acceptFile ((ChatMsgEvent 'Json
  -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> (ChatMsgEvent 'Json
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a b. (a -> b) -> a -> b
$ \ChatMsgEvent 'Json
msg -> ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, UserId, PQEncryption)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
sendDirectMemberMessage Connection
conn ChatMsgEvent 'Json
msg UserId
groupId
            Maybe Connection
_ -> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType
 -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEFileInternal String
"member connection not active"
        (ChatRef, Maybe UserId)
_ -> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType
 -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEFileInternal String
"invalid chat ref for file transfer"
  where
    acceptFile :: (ChatMsgEvent 'Json -> CM ()) -> CM AChatItem
    acceptFile :: (ChatMsgEvent 'Json
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
acceptFile ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) ()
send = do
      String
filePath <- UserId
-> Maybe String
-> String
-> Bool
-> ExceptT ChatError (ReaderT ChatController IO) String
getRcvFilePath UserId
fileId Maybe String
filePath_ String
fName Bool
True
      Bool
inline <- CM Bool
receiveInline
      VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
      if
        | Bool
inline -> do
            -- accepting inline
            AChatItem
ci <- (Connection -> ExceptT StoreError IO AChatItem)
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO AChatItem)
 -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> (Connection -> ExceptT StoreError IO AChatItem)
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> UserId
-> String
-> ExceptT StoreError IO AChatItem
acceptRcvInlineFT Connection
db VersionRangeChat
vr User
user UserId
fileId String
filePath
            SharedMsgId
sharedMsgId <- (Connection -> ExceptT StoreError IO SharedMsgId) -> CM SharedMsgId
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO SharedMsgId)
 -> CM SharedMsgId)
-> (Connection -> ExceptT StoreError IO SharedMsgId)
-> CM SharedMsgId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> UserId -> ExceptT StoreError IO SharedMsgId
getSharedMsgIdByFileId Connection
db UserId
userId UserId
fileId
            ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) ()
send (ChatMsgEvent 'Json
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ SharedMsgId
-> Maybe ConnReqInvitation -> String -> ChatMsgEvent 'Json
XFileAcptInv SharedMsgId
sharedMsgId Maybe ConnReqInvitation
forall a. Maybe a
Nothing String
fName
            AChatItem
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AChatItem
ci
        | Maybe InlineFileMode
fileInline Maybe InlineFileMode -> Maybe InlineFileMode -> Bool
forall a. Eq a => a -> a -> Bool
== InlineFileMode -> Maybe InlineFileMode
forall a. a -> Maybe a
Just InlineFileMode
IFMSent -> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType
 -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEFileAlreadyReceiving String
fName
        | Bool
otherwise -> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType
 -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEException String
"accepting file via a separate connection is deprecated"
    receiveInline :: CM Bool
    receiveInline :: CM Bool
receiveInline = do
      ChatConfig {Integer
fileChunkSize :: ChatConfig -> Integer
fileChunkSize :: Integer
fileChunkSize, inlineFiles :: ChatConfig -> InlineFilesConfig
inlineFiles = InlineFilesConfig {Integer
receiveChunks :: Integer
receiveChunks :: InlineFilesConfig -> Integer
receiveChunks, Integer
offerChunks :: Integer
offerChunks :: InlineFilesConfig -> Integer
offerChunks}} <- (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 Bool
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> CM Bool) -> Bool -> CM Bool
forall a b. (a -> b) -> a -> b
$
        Maybe Bool
rcvInline_ Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
          Bool -> Bool -> Bool
&& Maybe InlineFileMode
fileInline Maybe InlineFileMode -> Maybe InlineFileMode -> Bool
forall a. Eq a => a -> a -> Bool
== InlineFileMode -> Maybe InlineFileMode
forall a. a -> Maybe a
Just InlineFileMode
IFMOffer
          Bool -> Bool -> Bool
&& ( Integer
fileSize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
fileChunkSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
receiveChunks
                Bool -> Bool -> Bool
|| (Maybe Bool
rcvInline_ Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Bool -> Bool -> Bool
&& Integer
fileSize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
fileChunkSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
offerChunks)
             )

receiveViaCompleteFD :: User -> FileTransferId -> RcvFileDescr -> Bool -> Maybe CryptoFileArgs -> CM ()
receiveViaCompleteFD :: User
-> UserId
-> RcvFileDescr
-> Bool
-> Maybe CryptoFileArgs
-> ExceptT ChatError (ReaderT ChatController IO) ()
receiveViaCompleteFD User
user UserId
fileId RcvFileDescr {ContactName
fileDescrText :: ContactName
fileDescrText :: RcvFileDescr -> ContactName
fileDescrText, Bool
fileDescrComplete :: Bool
fileDescrComplete :: RcvFileDescr -> Bool
fileDescrComplete} Bool
userApprovedRelays Maybe CryptoFileArgs
cfArgs =
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fileDescrComplete (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ do
    ValidFileDescription 'FRecipient
rd <- ContactName -> CM (ValidFileDescription 'FRecipient)
forall (p :: FileParty).
FilePartyI p =>
ContactName -> CM (ValidFileDescription p)
parseFileDescription ContactName
fileDescrText
    if Bool
userApprovedRelays
      then ValidFileDescription 'FRecipient
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
receive' ValidFileDescription 'FRecipient
rd Bool
True
      else do
        let srvs :: [XFTPServer]
srvs = ValidFileDescription 'FRecipient -> [XFTPServer]
fileServers ValidFileDescription 'FRecipient
rd
        [XFTPServer]
unknownSrvs <- [XFTPServer] -> CM [XFTPServer]
getUnknownSrvs [XFTPServer]
srvs
        let approved :: Bool
approved = [XFTPServer] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [XFTPServer]
unknownSrvs
        CM Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
          ((Bool
approved Bool -> Bool -> Bool
||) (Bool -> Bool) -> CM Bool -> CM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [XFTPServer] -> CM Bool
ipProtectedForSrvs [XFTPServer]
srvs)
          (ValidFileDescription 'FRecipient
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
receive' ValidFileDescription 'FRecipient
rd Bool
approved)
          ([XFTPServer] -> ExceptT ChatError (ReaderT ChatController IO) ()
relaysNotApproved [XFTPServer]
unknownSrvs)
  where
    receive' :: ValidFileDescription 'FRecipient -> Bool -> CM ()
    receive' :: ValidFileDescription 'FRecipient
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
receive' ValidFileDescription 'FRecipient
rd Bool
approved = do
      ByteString
aFileId <- (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ByteString)
 -> CM ByteString)
-> (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> UserId
-> ValidFileDescription 'FRecipient
-> Maybe CryptoFileArgs
-> Bool
-> ExceptT AgentErrorType IO ByteString
xftpReceiveFile AgentClient
a (User -> UserId
aUserId User
user) ValidFileDescription 'FRecipient
rd Maybe CryptoFileArgs
cfArgs Bool
approved
      User -> UserId -> ExceptT ChatError (ReaderT ChatController IO) ()
startReceivingFile User
user UserId
fileId
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> Maybe AgentRcvFileId -> IO ()
updateRcvFileAgentId Connection
db UserId
fileId (AgentRcvFileId -> Maybe AgentRcvFileId
forall a. a -> Maybe a
Just (AgentRcvFileId -> Maybe AgentRcvFileId)
-> AgentRcvFileId -> Maybe AgentRcvFileId
forall a b. (a -> b) -> a -> b
$ ByteString -> AgentRcvFileId
AgentRcvFileId ByteString
aFileId)
    fileServers :: ValidFileDescription 'FRecipient -> [XFTPServer]
    fileServers :: ValidFileDescription 'FRecipient -> [XFTPServer]
fileServers (FD.ValidFileDescription FD.FileDescription {[FileChunk]
chunks :: [FileChunk]
chunks :: forall (p :: FileParty). FileDescription p -> [FileChunk]
chunks}) =
      Set XFTPServer -> [XFTPServer]
forall a. Set a -> [a]
S.toList (Set XFTPServer -> [XFTPServer]) -> Set XFTPServer -> [XFTPServer]
forall a b. (a -> b) -> a -> b
$ [XFTPServer] -> Set XFTPServer
forall a. Ord a => [a] -> Set a
S.fromList ([XFTPServer] -> Set XFTPServer) -> [XFTPServer] -> Set XFTPServer
forall a b. (a -> b) -> a -> b
$ (FileChunk -> [XFTPServer]) -> [FileChunk] -> [XFTPServer]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\FD.FileChunk {[FileChunkReplica]
replicas :: [FileChunkReplica]
replicas :: FileChunk -> [FileChunkReplica]
replicas} -> (FileChunkReplica -> XFTPServer)
-> [FileChunkReplica] -> [XFTPServer]
forall a b. (a -> b) -> [a] -> [b]
map (\FD.FileChunkReplica {XFTPServer
server :: XFTPServer
server :: FileChunkReplica -> XFTPServer
server} -> XFTPServer
server) [FileChunkReplica]
replicas) [FileChunk]
chunks
    getUnknownSrvs :: [XFTPServer] -> CM [XFTPServer]
    getUnknownSrvs :: [XFTPServer] -> CM [XFTPServer]
getUnknownSrvs [XFTPServer]
srvs = do
      NonEmpty XFTPServer
knownSrvs <- (ServerCfg 'PXFTP -> XFTPServer)
-> NonEmpty (ServerCfg 'PXFTP) -> NonEmpty XFTPServer
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map ServerCfg 'PXFTP -> XFTPServer
forall (p :: ProtocolType). ServerCfg p -> ProtocolServer p
protoServer' (NonEmpty (ServerCfg 'PXFTP) -> NonEmpty XFTPServer)
-> ExceptT
     ChatError (ReaderT ChatController IO) (NonEmpty (ServerCfg 'PXFTP))
-> ExceptT
     ChatError (ReaderT ChatController IO) (NonEmpty XFTPServer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SProtocolType 'PXFTP
-> User
-> ExceptT
     ChatError (ReaderT ChatController IO) (NonEmpty (ServerCfg 'PXFTP))
forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
SProtocolType p -> User -> CM (NonEmpty (ServerCfg p))
getKnownAgentServers SProtocolType 'PXFTP
SPXFTP User
user
      [XFTPServer] -> CM [XFTPServer]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([XFTPServer] -> CM [XFTPServer])
-> [XFTPServer] -> CM [XFTPServer]
forall a b. (a -> b) -> a -> b
$ (XFTPServer -> Bool) -> [XFTPServer] -> [XFTPServer]
forall a. (a -> Bool) -> [a] -> [a]
filter (XFTPServer -> NonEmpty XFTPServer -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` NonEmpty XFTPServer
knownSrvs) [XFTPServer]
srvs
    ipProtectedForSrvs :: [XFTPServer] -> CM Bool
    ipProtectedForSrvs :: [XFTPServer] -> CM Bool
ipProtectedForSrvs [XFTPServer]
srvs = do
      NetworkConfig
netCfg <- ReaderT ChatController IO NetworkConfig
-> ExceptT ChatError (ReaderT ChatController IO) NetworkConfig
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 NetworkConfig
getNetworkConfig
      Bool -> CM Bool
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> CM Bool) -> Bool -> CM Bool
forall a b. (a -> b) -> a -> b
$ (XFTPServer -> Bool) -> [XFTPServer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (NetworkConfig -> XFTPServer -> Bool
forall (p :: ProtocolType).
NetworkConfig -> ProtocolServer p -> Bool
ipAddressProtected NetworkConfig
netCfg) [XFTPServer]
srvs
    relaysNotApproved :: [XFTPServer] -> CM ()
    relaysNotApproved :: [XFTPServer] -> ExceptT ChatError (ReaderT ChatController IO) ()
relaysNotApproved [XFTPServer]
unknownSrvs = do
      Maybe AChatItem
aci_ <- User -> UserId -> CIFileStatus 'MDRcv -> CM (Maybe AChatItem)
resetRcvCIFileStatus User
user UserId
fileId CIFileStatus 'MDRcv
CIFSRcvInvitation
      Maybe AChatItem
-> (AChatItem -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe AChatItem
aci_ ((AChatItem -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (AChatItem -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \AChatItem
aci -> do
        AChatItem -> ExceptT ChatError (ReaderT ChatController IO) ()
cleanupACIFile AChatItem
aci
        ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtChatItemUpdated User
user AChatItem
aci
      ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ UserId -> [XFTPServer] -> ChatErrorType
CEFileNotApproved UserId
fileId [XFTPServer]
unknownSrvs

cleanupACIFile :: AChatItem -> CM ()
cleanupACIFile :: AChatItem -> ExceptT ChatError (ReaderT ChatController IO) ()
cleanupACIFile (AChatItem SChatType c
_ SMsgDirection d
_ ChatInfo c
_ ChatItem {file :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIFile d)
file = Just CIFile {fileSource :: forall (d :: MsgDirection). CIFile d -> Maybe CryptoFile
fileSource = Just CryptoFile {String
filePath :: String
filePath :: CryptoFile -> String
filePath}}}) = do
  String
fsFilePath <- 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
filePath
  String -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
fsFilePath ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
_ -> () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
cleanupACIFile AChatItem
_ = () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

getKnownAgentServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> User -> CM (NonEmpty (ServerCfg p))
getKnownAgentServers :: forall (p :: ProtocolType).
(ProtocolTypeI p, UserProtocol p) =>
SProtocolType p -> User -> CM (NonEmpty (ServerCfg p))
getKnownAgentServers SProtocolType p
p User
user = do
  RandomAgentServers
as <- (ChatController -> RandomAgentServers)
-> ExceptT ChatError (ReaderT ChatController IO) RandomAgentServers
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> RandomAgentServers
randomAgentServers
  (Connection -> ExceptT StoreError IO (NonEmpty (ServerCfg p)))
-> CM (NonEmpty (ServerCfg p))
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (NonEmpty (ServerCfg p)))
 -> CM (NonEmpty (ServerCfg p)))
-> (Connection -> ExceptT StoreError IO (NonEmpty (ServerCfg p)))
-> CM (NonEmpty (ServerCfg p))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
    [(ContactName, ServerOperator)]
opDomains <- [ServerOperator] -> [(ContactName, ServerOperator)]
forall (s :: DBStored).
[ServerOperator' s] -> [(ContactName, ServerOperator' s)]
operatorDomains ([ServerOperator] -> [(ContactName, ServerOperator)])
-> (ServerOperatorConditions -> [ServerOperator])
-> ServerOperatorConditions
-> [(ContactName, ServerOperator)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerOperatorConditions -> [ServerOperator]
serverOperators (ServerOperatorConditions -> [(ContactName, ServerOperator)])
-> ExceptT StoreError IO ServerOperatorConditions
-> ExceptT StoreError IO [(ContactName, ServerOperator)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> ExceptT StoreError IO ServerOperatorConditions
getServerOperators Connection
db
    [UserServer p]
srvs <- IO [UserServer p] -> ExceptT StoreError IO [UserServer p]
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [UserServer p] -> ExceptT StoreError IO [UserServer p])
-> IO [UserServer p] -> ExceptT StoreError IO [UserServer p]
forall a b. (a -> b) -> a -> b
$ Connection -> SProtocolType p -> User -> IO [UserServer p]
forall (p :: ProtocolType).
ProtocolTypeI p =>
Connection -> SProtocolType p -> User -> IO [UserServer p]
getProtocolServers Connection
db SProtocolType p
p User
user
    NonEmpty (ServerCfg p)
-> ExceptT StoreError IO (NonEmpty (ServerCfg p))
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (ServerCfg p)
 -> ExceptT StoreError IO (NonEmpty (ServerCfg p)))
-> NonEmpty (ServerCfg p)
-> ExceptT StoreError IO (NonEmpty (ServerCfg p))
forall a b. (a -> b) -> a -> b
$ SProtocolType p
-> RandomAgentServers
-> [(ContactName, ServerOperator)]
-> [UserServer p]
-> NonEmpty (ServerCfg p)
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p
-> RandomAgentServers
-> [(ContactName, ServerOperator)]
-> [UserServer p]
-> NonEmpty (ServerCfg p)
useServerCfgs SProtocolType p
p RandomAgentServers
as [(ContactName, ServerOperator)]
opDomains [UserServer p]
srvs

protoServer' :: ServerCfg p -> ProtocolServer p
protoServer' :: forall (p :: ProtocolType). ServerCfg p -> ProtocolServer p
protoServer' ServerCfg {ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server :: forall (p :: ProtocolType). ServerCfg p -> ProtoServerWithAuth p
server} = ProtoServerWithAuth p -> ProtocolServer p
forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtocolServer p
protoServer ProtoServerWithAuth p
server

getNetworkConfig :: CM' NetworkConfig
getNetworkConfig :: ReaderT ChatController IO NetworkConfig
getNetworkConfig = (AgentClient -> IO NetworkConfig)
-> ReaderT ChatController IO NetworkConfig
forall a. (AgentClient -> IO a) -> CM' a
withAgent' ((AgentClient -> IO NetworkConfig)
 -> ReaderT ChatController IO NetworkConfig)
-> (AgentClient -> IO NetworkConfig)
-> ReaderT ChatController IO NetworkConfig
forall a b. (a -> b) -> a -> b
$ IO NetworkConfig -> IO NetworkConfig
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO NetworkConfig -> IO NetworkConfig)
-> (AgentClient -> IO NetworkConfig)
-> AgentClient
-> IO NetworkConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> IO NetworkConfig
getFastNetworkConfig

resetRcvCIFileStatus :: User -> FileTransferId -> CIFileStatus 'MDRcv -> CM (Maybe AChatItem)
resetRcvCIFileStatus :: User -> UserId -> CIFileStatus 'MDRcv -> CM (Maybe AChatItem)
resetRcvCIFileStatus User
user UserId
fileId CIFileStatus 'MDRcv
ciFileStatus = do
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  (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 -> User -> UserId -> CIFileStatus 'MDRcv -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> UserId -> CIFileStatus d -> IO ()
updateCIFileStatus Connection
db User
user UserId
fileId CIFileStatus 'MDRcv
ciFileStatus
      Connection -> UserId -> FileStatus -> IO ()
updateRcvFileStatus Connection
db UserId
fileId FileStatus
FSNew
      Connection -> UserId -> Maybe AgentRcvFileId -> IO ()
updateRcvFileAgentId Connection
db UserId
fileId Maybe AgentRcvFileId
forall a. Maybe a
Nothing
    Connection
-> VersionRangeChat
-> User
-> UserId
-> ExceptT StoreError IO (Maybe AChatItem)
lookupChatItemByFileId Connection
db VersionRangeChat
vr User
user UserId
fileId

receiveViaURI :: User -> FileDescriptionURI -> CryptoFile -> CM RcvFileTransfer
receiveViaURI :: User -> FileDescriptionURI -> CryptoFile -> CM RcvFileTransfer
receiveViaURI user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId} FileDescriptionURI {ValidFileDescription 'FRecipient
description :: ValidFileDescription 'FRecipient
description :: FileDescriptionURI -> ValidFileDescription 'FRecipient
description} cf :: CryptoFile
cf@CryptoFile {Maybe CryptoFileArgs
cryptoArgs :: Maybe CryptoFileArgs
cryptoArgs :: CryptoFile -> Maybe CryptoFileArgs
cryptoArgs} = do
  UserId
fileId <- (Connection -> ExceptT StoreError IO UserId) -> CM UserId
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO UserId) -> CM UserId)
-> (Connection -> ExceptT StoreError IO UserId) -> CM UserId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> UserId
-> CryptoFile
-> UserId
-> Word32
-> ExceptT StoreError IO UserId
createRcvStandaloneFileTransfer Connection
db UserId
userId CryptoFile
cf UserId
fileSize Word32
chunkSize
  -- currently the only use case is user migrating via their configured servers, so we pass approvedRelays = True
  ByteString
aFileId <- (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ByteString)
 -> CM ByteString)
-> (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> UserId
-> ValidFileDescription 'FRecipient
-> Maybe CryptoFileArgs
-> Bool
-> ExceptT AgentErrorType IO ByteString
xftpReceiveFile AgentClient
a (User -> UserId
aUserId User
user) ValidFileDescription 'FRecipient
description Maybe CryptoFileArgs
cryptoArgs Bool
True
  (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 -> 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 -> UserId -> FileStatus -> IO ()
updateRcvFileStatus Connection
db UserId
fileId FileStatus
FSConnected
      Connection -> User -> UserId -> CIFileStatus 'MDRcv -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> UserId -> CIFileStatus d -> IO ()
updateCIFileStatus Connection
db User
user UserId
fileId (CIFileStatus 'MDRcv -> IO ()) -> CIFileStatus 'MDRcv -> IO ()
forall a b. (a -> b) -> a -> b
$ UserId -> UserId -> CIFileStatus 'MDRcv
CIFSRcvTransfer UserId
0 UserId
1
      Connection -> UserId -> Maybe AgentRcvFileId -> IO ()
updateRcvFileAgentId Connection
db UserId
fileId (AgentRcvFileId -> Maybe AgentRcvFileId
forall a. a -> Maybe a
Just (AgentRcvFileId -> Maybe AgentRcvFileId)
-> AgentRcvFileId -> Maybe AgentRcvFileId
forall a b. (a -> b) -> a -> b
$ ByteString -> AgentRcvFileId
AgentRcvFileId ByteString
aFileId)
    Connection
-> User -> UserId -> ExceptT StoreError IO RcvFileTransfer
getRcvFileTransfer Connection
db User
user UserId
fileId
  where
    FD.ValidFileDescription FD.FileDescription {size :: forall (p :: FileParty). FileDescription p -> FileSize UserId
size = FD.FileSize UserId
fileSize, chunkSize :: forall (p :: FileParty). FileDescription p -> FileSize Word32
chunkSize = FD.FileSize Word32
chunkSize} = ValidFileDescription 'FRecipient
description

startReceivingFile :: User -> FileTransferId -> CM ()
startReceivingFile :: User -> UserId -> ExceptT ChatError (ReaderT ChatController IO) ()
startReceivingFile User
user UserId
fileId = do
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  AChatItem
ci <- (Connection -> ExceptT StoreError IO AChatItem)
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO AChatItem)
 -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> (Connection -> ExceptT StoreError IO AChatItem)
-> ExceptT ChatError (ReaderT ChatController IO) 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 -> UserId -> FileStatus -> IO ()
updateRcvFileStatus Connection
db UserId
fileId FileStatus
FSConnected
    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 -> UserId -> CIFileStatus 'MDRcv -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> UserId -> CIFileStatus d -> IO ()
updateCIFileStatus Connection
db User
user UserId
fileId (CIFileStatus 'MDRcv -> IO ()) -> CIFileStatus 'MDRcv -> IO ()
forall a b. (a -> b) -> a -> b
$ UserId -> UserId -> CIFileStatus 'MDRcv
CIFSRcvTransfer UserId
0 UserId
1
    Connection
-> VersionRangeChat
-> User
-> UserId
-> ExceptT StoreError IO AChatItem
getChatItemByFileId Connection
db VersionRangeChat
vr User
user UserId
fileId
  ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> ChatEvent
CEvtRcvFileStart User
user AChatItem
ci

getRcvFilePath :: FileTransferId -> Maybe FilePath -> String -> Bool -> CM FilePath
getRcvFilePath :: UserId
-> Maybe String
-> String
-> Bool
-> ExceptT ChatError (ReaderT ChatController IO) String
getRcvFilePath UserId
fileId Maybe String
fPath_ String
fn Bool
keepHandle = case Maybe String
fPath_ of
  Maybe String
Nothing ->
    (ChatController -> TVar (Maybe String))
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe String)
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar (Maybe String)
filesFolder ExceptT ChatError (ReaderT ChatController IO) (Maybe String)
-> (Maybe String
    -> ExceptT ChatError (ReaderT ChatController IO) String)
-> ExceptT ChatError (ReaderT ChatController IO) String
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 String
Nothing -> do
        String
defaultFolder <- 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
getDefaultFilesFolder
        String
fPath <- IO String -> ExceptT ChatError (ReaderT ChatController IO) String
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT ChatError (ReaderT ChatController IO) String)
-> IO String
-> ExceptT ChatError (ReaderT ChatController IO) String
forall a b. (a -> b) -> a -> b
$ String
defaultFolder String -> String -> IO String
`uniqueCombine` String
fn
        String -> ExceptT ChatError (ReaderT ChatController IO) ()
createEmptyFile String
fPath ExceptT ChatError (ReaderT ChatController IO) ()
-> String -> ExceptT ChatError (ReaderT ChatController IO) String
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String
fPath
      Just String
filesFolder -> do
        String
fPath <- IO String -> ExceptT ChatError (ReaderT ChatController IO) String
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT ChatError (ReaderT ChatController IO) String)
-> IO String
-> ExceptT ChatError (ReaderT ChatController IO) String
forall a b. (a -> b) -> a -> b
$ String
filesFolder String -> String -> IO String
`uniqueCombine` String
fn
        String -> ExceptT ChatError (ReaderT ChatController IO) ()
createEmptyFile String
fPath
        String -> ExceptT ChatError (ReaderT ChatController IO) String
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ExceptT ChatError (ReaderT ChatController IO) String)
-> String -> ExceptT ChatError (ReaderT ChatController IO) String
forall a b. (a -> b) -> a -> b
$ String -> String
takeFileName String
fPath
  Just String
fPath ->
    CM Bool
-> ExceptT ChatError (ReaderT ChatController IO) String
-> ExceptT ChatError (ReaderT ChatController IO) String
-> ExceptT ChatError (ReaderT ChatController IO) String
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
      (String -> CM Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesDirectoryExist String
fPath)
      (String -> ExceptT ChatError (ReaderT ChatController IO) String
createInPassedDirectory String
fPath)
      (ExceptT ChatError (ReaderT ChatController IO) String
 -> ExceptT ChatError (ReaderT ChatController IO) String)
-> ExceptT ChatError (ReaderT ChatController IO) String
-> ExceptT ChatError (ReaderT ChatController IO) String
forall a b. (a -> b) -> a -> b
$ CM Bool
-> ExceptT ChatError (ReaderT ChatController IO) String
-> ExceptT ChatError (ReaderT ChatController IO) String
-> ExceptT ChatError (ReaderT ChatController IO) String
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
        (String -> CM Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
fPath)
        (ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) String
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType
 -> ExceptT ChatError (ReaderT ChatController IO) String)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) String
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEFileAlreadyExists String
fPath)
        (String -> ExceptT ChatError (ReaderT ChatController IO) ()
createEmptyFile String
fPath ExceptT ChatError (ReaderT ChatController IO) ()
-> String -> ExceptT ChatError (ReaderT ChatController IO) String
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String
fPath)
  where
    createInPassedDirectory :: FilePath -> CM FilePath
    createInPassedDirectory :: String -> ExceptT ChatError (ReaderT ChatController IO) String
createInPassedDirectory String
fPathDir = do
      String
fPath <- IO String -> ExceptT ChatError (ReaderT ChatController IO) String
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT ChatError (ReaderT ChatController IO) String)
-> IO String
-> ExceptT ChatError (ReaderT ChatController IO) String
forall a b. (a -> b) -> a -> b
$ String
fPathDir String -> String -> IO String
`uniqueCombine` String
fn
      String -> ExceptT ChatError (ReaderT ChatController IO) ()
createEmptyFile String
fPath ExceptT ChatError (ReaderT ChatController IO) ()
-> String -> ExceptT ChatError (ReaderT ChatController IO) String
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String
fPath
    createEmptyFile :: FilePath -> CM ()
    createEmptyFile :: String -> ExceptT ChatError (ReaderT ChatController IO) ()
createEmptyFile String
fPath = ExceptT ChatError (ReaderT ChatController IO) ()
emptyFile ExceptT ChatError (ReaderT ChatController IO) ()
-> (SomeException -> ChatError)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *) e a.
MonadUnliftIO m =>
ExceptT e m a -> (SomeException -> e) -> ExceptT e m a
`catchThrow` (ChatErrorType -> ChatError
ChatError (ChatErrorType -> ChatError)
-> (SomeException -> ChatErrorType) -> SomeException -> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ChatErrorType
CEFileWrite String
fPath (String -> ChatErrorType)
-> (SomeException -> String) -> SomeException -> ChatErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show)
      where
        emptyFile :: CM ()
        emptyFile :: ExceptT ChatError (ReaderT ChatController IO) ()
emptyFile
          | Bool
keepHandle = do
              Handle
h <- UserId
-> String
-> (ChatController -> TVar (Map UserId Handle))
-> IOMode
-> CM Handle
getFileHandle UserId
fileId String
fPath ChatController -> TVar (Map UserId Handle)
rcvFiles IOMode
AppendMode
              IO () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ChatError (ReaderT ChatController IO) ())
-> IO () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
"" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h
          | Bool
otherwise = IO () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ChatError (ReaderT ChatController IO) ())
-> IO () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
B.writeFile String
fPath ByteString
""

-- TODO [short links]
-- Please note:
-- - the connection here is created as ConnNew, even though when joining it is created as ConnPrepared.
--   (changing it is risky, as there may be existing "prepared" connections that were not accepted in ConnNew status).
-- - after accepted, the status is changed by this func caller to ConnSndReady if it is sndSecure, and not changed otherwise - joined changed to ConnJoined in this case.
-- - xContactId is set on the contact at the first acceptance attempt, not after accept success, which prevents profile updates after such attempt.
--   It may be reasonable to set it when contact is first prepared, but then we can't use it to ignore requests after acceptance,
--   and it may lead to race conditions with XInfo events.
acceptContactRequest :: NetworkRequestMode -> User -> UserContactRequest -> IncognitoEnabled -> CM (Contact, Connection, SndQueueSecured)
acceptContactRequest :: NetworkRequestMode
-> User
-> UserContactRequest
-> Bool
-> CM (Contact, Connection, Bool)
acceptContactRequest NetworkRequestMode
nm user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId} UserContactRequest {agentInvitationId :: UserContactRequest -> AgentInvId
agentInvitationId = AgentInvId ByteString
invId, Maybe UserId
contactId_ :: Maybe UserId
contactId_ :: UserContactRequest -> Maybe UserId
contactId_, VersionRangeChat
cReqChatVRange :: VersionRangeChat
cReqChatVRange :: UserContactRequest -> VersionRangeChat
cReqChatVRange, localDisplayName :: UserContactRequest -> ContactName
localDisplayName = ContactName
cName, UserId
profileId :: UserId
profileId :: UserContactRequest -> UserId
profileId, profile :: UserContactRequest -> Profile
profile = Profile
cp, Maybe UserId
userContactLinkId_ :: Maybe UserId
userContactLinkId_ :: UserContactRequest -> Maybe UserId
userContactLinkId_, Maybe XContactId
xContactId :: Maybe XContactId
xContactId :: UserContactRequest -> Maybe XContactId
xContactId, PQSupport
pqSupport :: PQSupport
pqSupport :: UserContactRequest -> PQSupport
pqSupport} Bool
incognito = do
  SubscriptionMode
subMode <- (ChatController -> TVar SubscriptionMode) -> CM SubscriptionMode
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar SubscriptionMode
subscriptionMode
  let pqSup :: PQSupport
pqSup = PQSupport
PQSupportOn
      pqSup' :: PQSupport
pqSup' = PQSupport
pqSup PQSupport -> PQSupport -> PQSupport
`CR.pqSupportAnd` PQSupport
pqSupport
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  let chatV :: Version ChatVersion
chatV = VersionRangeChat
vr VersionRangeChat -> VersionRangeChat -> Version ChatVersion
`peerConnChatVersion` VersionRangeChat
cReqChatVRange
  (Contact
ct, Connection
conn, Maybe IncognitoProfile
incognitoProfile) <- case Maybe UserId
contactId_ of
    Maybe UserId
Nothing -> do
      Maybe IncognitoProfile
incognitoProfile <- if Bool
incognito 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
      ByteString
connId <- (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ByteString)
 -> CM ByteString)
-> (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> UserId
-> Bool
-> ByteString
-> PQSupport
-> ExceptT AgentErrorType IO ByteString
prepareConnectionToAccept AgentClient
a (User -> UserId
aUserId User
user) Bool
True ByteString
invId PQSupport
pqSup'
      (Contact
ct, Connection
conn) <- (Connection -> IO (Contact, Connection))
-> CM (Contact, Connection)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (Contact, Connection))
 -> CM (Contact, Connection))
-> (Connection -> IO (Contact, Connection))
-> CM (Contact, Connection)
forall a b. (a -> b) -> a -> b
$ \Connection
db ->
        Connection
-> User
-> Maybe UserId
-> ByteString
-> Version ChatVersion
-> VersionRangeChat
-> ContactName
-> UserId
-> Profile
-> Maybe XContactId
-> Maybe IncognitoProfile
-> SubscriptionMode
-> PQSupport
-> Bool
-> IO (Contact, Connection)
createContactFromRequest Connection
db User
user Maybe UserId
userContactLinkId_ ByteString
connId Version ChatVersion
chatV VersionRangeChat
cReqChatVRange ContactName
cName UserId
profileId Profile
cp Maybe XContactId
xContactId Maybe IncognitoProfile
incognitoProfile SubscriptionMode
subMode PQSupport
pqSup' Bool
False
      (Contact, Connection, Maybe IncognitoProfile)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Contact, Connection, Maybe IncognitoProfile)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact
ct, Connection
conn, Maybe IncognitoProfile
incognitoProfile)
    Just UserId
contactId -> do
      Contact
ct <- (Connection -> ExceptT StoreError IO Contact) -> CM Contact
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withFastStore ((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
-> UserId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user UserId
contactId
      case Contact -> Maybe Connection
contactConn Contact
ct of
        Maybe Connection
Nothing -> do
          Maybe IncognitoProfile
incognitoProfile <- if Bool
incognito 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
          ByteString
connId <- (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ByteString)
 -> CM ByteString)
-> (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> UserId
-> Bool
-> ByteString
-> PQSupport
-> ExceptT AgentErrorType IO ByteString
prepareConnectionToAccept AgentClient
a (User -> UserId
aUserId User
user) Bool
True ByteString
invId PQSupport
pqSup'
          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
          Connection
conn <- (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 -> do
            Maybe XContactId -> (XContactId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe XContactId
xContactId ((XContactId -> IO ()) -> IO ()) -> (XContactId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XContactId
xcId -> Connection -> Contact -> XContactId -> IO ()
setContactAcceptedXContactId Connection
db Contact
ct XContactId
xcId
            Connection
-> User
-> Maybe UserId
-> UserId
-> ByteString
-> Version ChatVersion
-> VersionRangeChat
-> PQSupport
-> Maybe IncognitoProfile
-> SubscriptionMode
-> UTCTime
-> IO Connection
createAcceptedContactConn Connection
db User
user Maybe UserId
userContactLinkId_ UserId
contactId ByteString
connId Version ChatVersion
chatV VersionRangeChat
cReqChatVRange PQSupport
pqSup' Maybe IncognitoProfile
incognitoProfile SubscriptionMode
subMode UTCTime
currentTs
          (Contact, Connection, Maybe IncognitoProfile)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Contact, Connection, Maybe IncognitoProfile)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact
ct {activeConn = Just conn} :: Contact, Connection
conn, Maybe IncognitoProfile
incognitoProfile)
        Just conn :: Connection
conn@Connection {Maybe UserId
customUserProfileId :: Maybe UserId
customUserProfileId :: Connection -> Maybe UserId
customUserProfileId} -> do
          Maybe LocalProfile
incognitoProfile <- Maybe UserId
-> (UserId
    -> 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 UserId
customUserProfileId ((UserId
  -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Maybe LocalProfile))
-> (UserId
    -> ExceptT ChatError (ReaderT ChatController IO) LocalProfile)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe LocalProfile)
forall a b. (a -> b) -> a -> b
$ \UserId
pId -> (Connection -> ExceptT StoreError IO LocalProfile)
-> ExceptT ChatError (ReaderT ChatController IO) LocalProfile
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withFastStore ((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
-> UserId -> UserId -> ExceptT StoreError IO LocalProfile
getProfileById Connection
db UserId
userId UserId
pId
          (Contact, Connection, Maybe IncognitoProfile)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Contact, Connection, Maybe IncognitoProfile)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact
ct, Connection
conn, LocalProfile -> IncognitoProfile
ExistingIncognito (LocalProfile -> IncognitoProfile)
-> Maybe LocalProfile -> Maybe IncognitoProfile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LocalProfile
incognitoProfile)
  let profileToSend :: Profile
profileToSend = User -> Maybe Profile -> Maybe Contact -> Bool -> Profile
userProfileDirect User
user (IncognitoProfile -> Profile
fromIncognitoProfile (IncognitoProfile -> Profile)
-> Maybe IncognitoProfile -> Maybe Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe IncognitoProfile
incognitoProfile) (Contact -> Maybe Contact
forall a. a -> Maybe a
Just Contact
ct) Bool
True
  ByteString
dm <- PQSupport
-> Version ChatVersion -> ChatMsgEvent 'Json -> CM ByteString
forall (e :: MsgEncoding).
MsgEncodingI e =>
PQSupport -> Version ChatVersion -> ChatMsgEvent e -> CM ByteString
encodeConnInfoPQ PQSupport
pqSup' Version ChatVersion
chatV (ChatMsgEvent 'Json -> CM ByteString)
-> ChatMsgEvent 'Json -> CM ByteString
forall a b. (a -> b) -> a -> b
$ Profile -> ChatMsgEvent 'Json
XInfo Profile
profileToSend
  -- TODO [certs rcv]
  (Contact
ct,Connection
conn,) (Bool -> (Contact, Connection, Bool))
-> ((Bool, Maybe ClientServiceId) -> Bool)
-> (Bool, Maybe ClientServiceId)
-> (Contact, Connection, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, Maybe ClientServiceId) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Maybe ClientServiceId) -> (Contact, Connection, Bool))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Bool, Maybe ClientServiceId)
-> CM (Contact, Connection, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AgentClient
 -> ExceptT AgentErrorType IO (Bool, Maybe ClientServiceId))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Bool, Maybe ClientServiceId)
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent (\AgentClient
a -> AgentClient
-> NetworkRequestMode
-> UserId
-> ByteString
-> Bool
-> ByteString
-> ByteString
-> PQSupport
-> SubscriptionMode
-> ExceptT AgentErrorType IO (Bool, Maybe ClientServiceId)
acceptContact AgentClient
a NetworkRequestMode
nm (User -> UserId
aUserId User
user) (Connection -> ByteString
aConnId Connection
conn) Bool
True ByteString
invId ByteString
dm PQSupport
pqSup' SubscriptionMode
subMode)

acceptContactRequestAsync :: User -> Int64 -> Contact -> UserContactRequest -> Maybe IncognitoProfile -> CM Contact
acceptContactRequestAsync :: User
-> UserId
-> Contact
-> UserContactRequest
-> Maybe IncognitoProfile
-> CM Contact
acceptContactRequestAsync
  User
user
  UserId
uclId
  ct :: Contact
ct@Contact {UserId
contactId :: Contact -> UserId
contactId :: UserId
contactId}
  UserContactRequest {agentInvitationId :: UserContactRequest -> AgentInvId
agentInvitationId = AgentInvId ByteString
cReqInvId, VersionRangeChat
cReqChatVRange :: UserContactRequest -> VersionRangeChat
cReqChatVRange :: VersionRangeChat
cReqChatVRange, Maybe XContactId
xContactId :: UserContactRequest -> Maybe XContactId
xContactId :: Maybe XContactId
xContactId, pqSupport :: UserContactRequest -> PQSupport
pqSupport = PQSupport
cReqPQSup}
  Maybe IncognitoProfile
incognitoProfile = do
    SubscriptionMode
subMode <- (ChatController -> TVar SubscriptionMode) -> CM SubscriptionMode
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar SubscriptionMode
subscriptionMode
    let profileToSend :: Profile
profileToSend = User -> Maybe Profile -> Maybe Contact -> Bool -> Profile
userProfileDirect User
user (IncognitoProfile -> Profile
fromIncognitoProfile (IncognitoProfile -> Profile)
-> Maybe IncognitoProfile -> Maybe Profile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe IncognitoProfile
incognitoProfile) (Contact -> Maybe Contact
forall a. a -> Maybe a
Just Contact
ct) Bool
True
    VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
    let chatV :: Version ChatVersion
chatV = VersionRangeChat
vr VersionRangeChat -> VersionRangeChat -> Version ChatVersion
`peerConnChatVersion` VersionRangeChat
cReqChatVRange
    (UserId
cmdId, ByteString
acId) <- User
-> Bool
-> ByteString
-> ChatMsgEvent 'Json
-> SubscriptionMode
-> PQSupport
-> Version ChatVersion
-> CM (UserId, ByteString)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Bool
-> ByteString
-> ChatMsgEvent e
-> SubscriptionMode
-> PQSupport
-> Version ChatVersion
-> CM (UserId, ByteString)
agentAcceptContactAsync User
user Bool
True ByteString
cReqInvId (Profile -> ChatMsgEvent 'Json
XInfo Profile
profileToSend) SubscriptionMode
subMode PQSupport
cReqPQSup Version ChatVersion
chatV
    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
    (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
      Maybe XContactId
-> (XContactId -> ExceptT StoreError IO ())
-> ExceptT StoreError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe XContactId
xContactId ((XContactId -> ExceptT StoreError IO ())
 -> ExceptT StoreError IO ())
-> (XContactId -> ExceptT StoreError IO ())
-> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$ \XContactId
xcId -> 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 -> Contact -> XContactId -> IO ()
setContactAcceptedXContactId Connection
db Contact
ct XContactId
xcId
      Connection {UserId
connId :: UserId
connId :: Connection -> UserId
connId} <- IO Connection -> ExceptT StoreError IO Connection
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> ExceptT StoreError IO Connection)
-> IO Connection -> ExceptT StoreError IO Connection
forall a b. (a -> b) -> a -> b
$ Connection
-> User
-> Maybe UserId
-> UserId
-> ByteString
-> Version ChatVersion
-> VersionRangeChat
-> PQSupport
-> Maybe IncognitoProfile
-> SubscriptionMode
-> UTCTime
-> IO Connection
createAcceptedContactConn Connection
db User
user (UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
uclId) UserId
contactId ByteString
acId Version ChatVersion
chatV VersionRangeChat
cReqChatVRange PQSupport
cReqPQSup Maybe IncognitoProfile
incognitoProfile SubscriptionMode
subMode UTCTime
currentTs
      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 -> UserId -> UserId -> IO ()
setCommandConnId Connection
db User
user UserId
cmdId UserId
connId
      Connection
-> VersionRangeChat
-> User
-> UserId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user UserId
contactId

acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> CM GroupMember
acceptGroupJoinRequestAsync :: User
-> UserId
-> GroupInfo
-> ByteString
-> VersionRangeChat
-> Profile
-> Maybe XContactId
-> Maybe SharedMsgId
-> GroupAcceptance
-> GroupMemberRole
-> Maybe IncognitoProfile
-> CM GroupMember
acceptGroupJoinRequestAsync
  User
user
  UserId
uclId
  gInfo :: GroupInfo
gInfo@GroupInfo {GroupProfile
groupProfile :: GroupProfile
groupProfile :: GroupInfo -> GroupProfile
groupProfile, GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership, Maybe BusinessChatInfo
businessChat :: Maybe BusinessChatInfo
businessChat :: GroupInfo -> Maybe BusinessChatInfo
businessChat}
  ByteString
cReqInvId
  VersionRangeChat
cReqChatVRange
  Profile
cReqProfile
  Maybe XContactId
cReqXContactId_
  Maybe SharedMsgId
welcomeMsgId_
  GroupAcceptance
gAccepted
  GroupMemberRole
gLinkMemRole
  Maybe IncognitoProfile
incognitoProfile = 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
    let initialStatus :: GroupMemberStatus
initialStatus = Maybe GroupMemberAdmission -> GroupAcceptance -> GroupMemberStatus
acceptanceToStatus (GroupProfile -> Maybe GroupMemberAdmission
memberAdmission GroupProfile
groupProfile) GroupAcceptance
gAccepted
    (UserId
groupMemberId, MemberId
memberId) <- (Connection -> ExceptT StoreError IO (UserId, MemberId))
-> CM (UserId, MemberId)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (UserId, MemberId))
 -> CM (UserId, MemberId))
-> (Connection -> ExceptT StoreError IO (UserId, MemberId))
-> CM (UserId, MemberId)
forall a b. (a -> b) -> a -> b
$ \Connection
db ->
      Connection
-> TVar ChaChaDRG
-> User
-> GroupInfo
-> VersionRangeChat
-> Profile
-> Maybe XContactId
-> Maybe SharedMsgId
-> GroupMemberRole
-> GroupMemberStatus
-> ExceptT StoreError IO (UserId, MemberId)
createJoiningMember Connection
db TVar ChaChaDRG
gVar User
user GroupInfo
gInfo VersionRangeChat
cReqChatVRange Profile
cReqProfile Maybe XContactId
cReqXContactId_ Maybe SharedMsgId
welcomeMsgId_ GroupMemberRole
gLinkMemRole GroupMemberStatus
initialStatus
    Int
currentMemCount <- (Connection -> IO Int) -> CM Int
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO Int) -> CM Int)
-> (Connection -> IO Int) -> CM Int
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupInfo -> IO Int
getGroupCurrentMembersCount Connection
db User
user GroupInfo
gInfo
    let Profile {ContactName
displayName :: ContactName
displayName :: Profile -> ContactName
displayName} = 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)
        GroupMember {memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
userRole, memberId :: GroupMember -> MemberId
memberId = MemberId
userMemberId} = GroupMember
membership
        msg :: ChatMsgEvent 'Json
msg =
          GroupLinkInvitation -> ChatMsgEvent 'Json
XGrpLinkInv (GroupLinkInvitation -> ChatMsgEvent 'Json)
-> GroupLinkInvitation -> ChatMsgEvent 'Json
forall a b. (a -> b) -> a -> b
$
            GroupLinkInvitation
              { fromMember :: MemberIdRole
fromMember = MemberId -> GroupMemberRole -> MemberIdRole
MemberIdRole MemberId
userMemberId GroupMemberRole
userRole,
                fromMemberName :: ContactName
fromMemberName = ContactName
displayName,
                invitedMember :: MemberIdRole
invitedMember = MemberId -> GroupMemberRole -> MemberIdRole
MemberIdRole MemberId
memberId GroupMemberRole
gLinkMemRole,
                GroupProfile
groupProfile :: GroupProfile
groupProfile :: GroupProfile
groupProfile,
                accepted :: Maybe GroupAcceptance
accepted = GroupAcceptance -> Maybe GroupAcceptance
forall a. a -> Maybe a
Just GroupAcceptance
gAccepted,
                business :: Maybe BusinessChatInfo
business = Maybe BusinessChatInfo
businessChat,
                groupSize :: Maybe Int
groupSize = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
currentMemCount
              }
    SubscriptionMode
subMode <- (ChatController -> TVar SubscriptionMode) -> CM SubscriptionMode
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar SubscriptionMode
subscriptionMode
    VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
    let chatV :: Version ChatVersion
chatV = VersionRangeChat
vr VersionRangeChat -> VersionRangeChat -> Version ChatVersion
`peerConnChatVersion` VersionRangeChat
cReqChatVRange
    (UserId, ByteString)
connIds <- User
-> Bool
-> ByteString
-> ChatMsgEvent 'Json
-> SubscriptionMode
-> PQSupport
-> Version ChatVersion
-> CM (UserId, ByteString)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Bool
-> ByteString
-> ChatMsgEvent e
-> SubscriptionMode
-> PQSupport
-> Version ChatVersion
-> CM (UserId, ByteString)
agentAcceptContactAsync User
user Bool
True ByteString
cReqInvId ChatMsgEvent 'Json
msg SubscriptionMode
subMode PQSupport
PQSupportOff Version ChatVersion
chatV
    (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 -> 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
-> UserId
-> (UserId, ByteString)
-> Version ChatVersion
-> VersionRangeChat
-> UserId
-> SubscriptionMode
-> IO ()
createJoiningMemberConnection Connection
db User
user UserId
uclId (UserId, ByteString)
connIds Version ChatVersion
chatV VersionRangeChat
cReqChatVRange UserId
groupMemberId SubscriptionMode
subMode
      Connection
-> VersionRangeChat
-> User
-> UserId
-> ExceptT StoreError IO GroupMember
getGroupMemberById Connection
db VersionRangeChat
vr User
user UserId
groupMemberId

acceptGroupJoinSendRejectAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> GroupRejectionReason -> CM GroupMember
acceptGroupJoinSendRejectAsync :: User
-> UserId
-> GroupInfo
-> ByteString
-> VersionRangeChat
-> Profile
-> Maybe XContactId
-> GroupRejectionReason
-> CM GroupMember
acceptGroupJoinSendRejectAsync
  User
user
  UserId
uclId
  gInfo :: GroupInfo
gInfo@GroupInfo {GroupProfile
groupProfile :: GroupInfo -> GroupProfile
groupProfile :: GroupProfile
groupProfile, GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership}
  ByteString
cReqInvId
  VersionRangeChat
cReqChatVRange
  Profile
cReqProfile
  Maybe XContactId
cReqXContactId_
  GroupRejectionReason
rejectionReason = 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
    (UserId
groupMemberId, MemberId
memberId) <- (Connection -> ExceptT StoreError IO (UserId, MemberId))
-> CM (UserId, MemberId)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (UserId, MemberId))
 -> CM (UserId, MemberId))
-> (Connection -> ExceptT StoreError IO (UserId, MemberId))
-> CM (UserId, MemberId)
forall a b. (a -> b) -> a -> b
$ \Connection
db ->
      Connection
-> TVar ChaChaDRG
-> User
-> GroupInfo
-> VersionRangeChat
-> Profile
-> Maybe XContactId
-> Maybe SharedMsgId
-> GroupMemberRole
-> GroupMemberStatus
-> ExceptT StoreError IO (UserId, MemberId)
createJoiningMember Connection
db TVar ChaChaDRG
gVar User
user GroupInfo
gInfo VersionRangeChat
cReqChatVRange Profile
cReqProfile Maybe XContactId
cReqXContactId_ Maybe SharedMsgId
forall a. Maybe a
Nothing GroupMemberRole
GRObserver GroupMemberStatus
GSMemRejected
    let GroupMember {memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
userRole, memberId :: GroupMember -> MemberId
memberId = MemberId
userMemberId} = GroupMember
membership
        msg :: ChatMsgEvent 'Json
msg =
          GroupLinkRejection -> ChatMsgEvent 'Json
XGrpLinkReject (GroupLinkRejection -> ChatMsgEvent 'Json)
-> GroupLinkRejection -> ChatMsgEvent 'Json
forall a b. (a -> b) -> a -> b
$
            GroupLinkRejection
              { fromMember :: MemberIdRole
fromMember = MemberId -> GroupMemberRole -> MemberIdRole
MemberIdRole MemberId
userMemberId GroupMemberRole
userRole,
                invitedMember :: MemberIdRole
invitedMember = MemberId -> GroupMemberRole -> MemberIdRole
MemberIdRole MemberId
memberId GroupMemberRole
GRObserver,
                GroupProfile
groupProfile :: GroupProfile
groupProfile :: GroupProfile
groupProfile,
                GroupRejectionReason
rejectionReason :: GroupRejectionReason
rejectionReason :: GroupRejectionReason
rejectionReason
              }
    SubscriptionMode
subMode <- (ChatController -> TVar SubscriptionMode) -> CM SubscriptionMode
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar SubscriptionMode
subscriptionMode
    VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
    let chatV :: Version ChatVersion
chatV = VersionRangeChat
vr VersionRangeChat -> VersionRangeChat -> Version ChatVersion
`peerConnChatVersion` VersionRangeChat
cReqChatVRange
    (UserId, ByteString)
connIds <- User
-> Bool
-> ByteString
-> ChatMsgEvent 'Json
-> SubscriptionMode
-> PQSupport
-> Version ChatVersion
-> CM (UserId, ByteString)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Bool
-> ByteString
-> ChatMsgEvent e
-> SubscriptionMode
-> PQSupport
-> Version ChatVersion
-> CM (UserId, ByteString)
agentAcceptContactAsync User
user Bool
False ByteString
cReqInvId ChatMsgEvent 'Json
msg SubscriptionMode
subMode PQSupport
PQSupportOff Version ChatVersion
chatV
    (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 -> 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
-> UserId
-> (UserId, ByteString)
-> Version ChatVersion
-> VersionRangeChat
-> UserId
-> SubscriptionMode
-> IO ()
createJoiningMemberConnection Connection
db User
user UserId
uclId (UserId, ByteString)
connIds Version ChatVersion
chatV VersionRangeChat
cReqChatVRange UserId
groupMemberId SubscriptionMode
subMode
      Connection
-> VersionRangeChat
-> User
-> UserId
-> ExceptT StoreError IO GroupMember
getGroupMemberById Connection
db VersionRangeChat
vr User
user UserId
groupMemberId

acceptBusinessJoinRequestAsync :: User -> Int64 -> GroupInfo -> GroupMember -> UserContactRequest -> CM (GroupInfo, GroupMember)
acceptBusinessJoinRequestAsync :: User
-> UserId
-> GroupInfo
-> GroupMember
-> UserContactRequest
-> CM (GroupInfo, GroupMember)
acceptBusinessJoinRequestAsync
  User
user
  UserId
uclId
  gInfo :: GroupInfo
gInfo@GroupInfo {membership :: GroupInfo -> GroupMember
membership = GroupMember {memberRole :: GroupMember -> GroupMemberRole
memberRole = GroupMemberRole
userRole, memberId :: GroupMember -> MemberId
memberId = MemberId
userMemberId}}
  clientMember :: GroupMember
clientMember@GroupMember {UserId
groupMemberId :: UserId
groupMemberId :: GroupMember -> UserId
groupMemberId, MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId}
  UserContactRequest {agentInvitationId :: UserContactRequest -> AgentInvId
agentInvitationId = AgentInvId ByteString
cReqInvId, VersionRangeChat
cReqChatVRange :: UserContactRequest -> VersionRangeChat
cReqChatVRange :: VersionRangeChat
cReqChatVRange, Maybe XContactId
xContactId :: UserContactRequest -> Maybe XContactId
xContactId :: Maybe XContactId
xContactId} = do
    VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
    let userProfile :: Profile
userProfile@Profile {ContactName
displayName :: Profile -> ContactName
displayName :: ContactName
displayName, Maybe Preferences
preferences :: Maybe Preferences
preferences :: Profile -> Maybe Preferences
preferences} = LocalProfile -> Profile
fromLocalProfile (LocalProfile -> Profile) -> LocalProfile -> Profile
forall a b. (a -> b) -> a -> b
$ User -> LocalProfile
forall a. IsContact a => a -> LocalProfile
profile' User
user
        -- TODO [short links] take groupPreferences from group info
        groupPreferences :: GroupPreferences
groupPreferences = GroupPreferences
-> (Preferences -> GroupPreferences)
-> Maybe Preferences
-> GroupPreferences
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GroupPreferences
defaultBusinessGroupPrefs Preferences -> GroupPreferences
businessGroupPrefs Maybe Preferences
preferences
        msg :: ChatMsgEvent 'Json
msg =
          GroupLinkInvitation -> ChatMsgEvent 'Json
XGrpLinkInv (GroupLinkInvitation -> ChatMsgEvent 'Json)
-> GroupLinkInvitation -> ChatMsgEvent 'Json
forall a b. (a -> b) -> a -> b
$
            GroupLinkInvitation
              { fromMember :: MemberIdRole
fromMember = MemberId -> GroupMemberRole -> MemberIdRole
MemberIdRole MemberId
userMemberId GroupMemberRole
userRole,
                fromMemberName :: ContactName
fromMemberName = ContactName
displayName,
                invitedMember :: MemberIdRole
invitedMember = MemberId -> GroupMemberRole -> MemberIdRole
MemberIdRole MemberId
memberId GroupMemberRole
GRMember,
                groupProfile :: GroupProfile
groupProfile = Profile -> GroupPreferences -> GroupProfile
businessGroupProfile Profile
userProfile GroupPreferences
groupPreferences,
                accepted :: Maybe GroupAcceptance
accepted = GroupAcceptance -> Maybe GroupAcceptance
forall a. a -> Maybe a
Just GroupAcceptance
GAAccepted,
                -- This refers to the "title member" that defines the group name and profile.
                -- This coincides with fromMember to be current user when accepting the connecting user,
                -- but it will be different when inviting somebody else.
                business :: Maybe BusinessChatInfo
business = BusinessChatInfo -> Maybe BusinessChatInfo
forall a. a -> Maybe a
Just (BusinessChatInfo -> Maybe BusinessChatInfo)
-> BusinessChatInfo -> Maybe BusinessChatInfo
forall a b. (a -> b) -> a -> b
$ BusinessChatInfo {chatType :: BusinessChatType
chatType = BusinessChatType
BCBusiness, businessId :: MemberId
businessId = MemberId
userMemberId, customerId :: MemberId
customerId = MemberId
memberId},
                groupSize :: Maybe Int
groupSize = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
              }
    SubscriptionMode
subMode <- (ChatController -> TVar SubscriptionMode) -> CM SubscriptionMode
forall a. (ChatController -> TVar a) -> CM a
chatReadVar ChatController -> TVar SubscriptionMode
subscriptionMode
    let chatV :: Version ChatVersion
chatV = VersionRangeChat
vr VersionRangeChat -> VersionRangeChat -> Version ChatVersion
`peerConnChatVersion` VersionRangeChat
cReqChatVRange
    (UserId, ByteString)
connIds <- User
-> Bool
-> ByteString
-> ChatMsgEvent 'Json
-> SubscriptionMode
-> PQSupport
-> Version ChatVersion
-> CM (UserId, ByteString)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Bool
-> ByteString
-> ChatMsgEvent e
-> SubscriptionMode
-> PQSupport
-> Version ChatVersion
-> CM (UserId, ByteString)
agentAcceptContactAsync User
user Bool
True ByteString
cReqInvId ChatMsgEvent 'Json
msg SubscriptionMode
subMode PQSupport
PQSupportOff Version ChatVersion
chatV
    (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
      Maybe XContactId -> (XContactId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe XContactId
xContactId ((XContactId -> IO ()) -> IO ()) -> (XContactId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XContactId
xcId -> Connection -> GroupInfo -> XContactId -> IO ()
setBusinessChatAcceptedXContactId Connection
db GroupInfo
gInfo XContactId
xcId
      Connection
-> User
-> UserId
-> (UserId, ByteString)
-> Version ChatVersion
-> VersionRangeChat
-> UserId
-> SubscriptionMode
-> IO ()
createJoiningMemberConnection Connection
db User
user UserId
uclId (UserId, ByteString)
connIds Version ChatVersion
chatV VersionRangeChat
cReqChatVRange UserId
groupMemberId SubscriptionMode
subMode
    let cd :: ChatDirection 'CTGroup 'MDSnd
cd = GroupInfo
-> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDSnd
CDGroupSnd GroupInfo
gInfo Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing
    -- TODO [short links] move to profileContactRequest?
    User
-> ChatDirection 'CTGroup 'MDSnd
-> CIContent 'MDSnd
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> CIContent d
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
createInternalChatItem User
user ChatDirection 'CTGroup 'MDSnd
cd (E2EInfo -> CIContent 'MDSnd
CISndGroupE2EEInfo E2EInfo {pqEnabled :: Maybe PQEncryption
pqEnabled = PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just PQEncryption
PQEncOff}) Maybe UTCTime
forall a. Maybe a
Nothing
    User
-> ChatDirection 'CTGroup 'MDSnd
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent 'MDSnd)
-> GroupInfo
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> ChatDirection 'CTGroup d
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent d)
-> GroupInfo
-> ExceptT ChatError (ReaderT ChatController IO) ()
createGroupFeatureItems User
user ChatDirection 'CTGroup 'MDSnd
cd GroupFeature
-> GroupPreference
-> Maybe Int
-> Maybe GroupMemberRole
-> CIContent 'MDSnd
CISndGroupFeature GroupInfo
gInfo
    -- TODO [short links] get updated business chat group and member? (currently not used)
    (GroupInfo, GroupMember) -> CM (GroupInfo, GroupMember)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo, GroupMember
clientMember)

businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile
businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile
businessGroupProfile Profile {ContactName
displayName :: Profile -> ContactName
displayName :: ContactName
displayName, ContactName
fullName :: ContactName
fullName :: Profile -> ContactName
fullName, Maybe ContactName
shortDescr :: Maybe ContactName
shortDescr :: Profile -> Maybe ContactName
shortDescr, Maybe ImageData
image :: Maybe ImageData
image :: Profile -> Maybe ImageData
image} GroupPreferences
groupPreferences =
  GroupProfile {ContactName
displayName :: ContactName
displayName :: ContactName
displayName, ContactName
fullName :: ContactName
fullName :: ContactName
fullName, description :: Maybe ContactName
description = Maybe ContactName
forall a. Maybe a
Nothing, Maybe ContactName
shortDescr :: Maybe ContactName
shortDescr :: Maybe ContactName
shortDescr, Maybe ImageData
image :: Maybe ImageData
image :: Maybe ImageData
image, groupPreferences :: Maybe GroupPreferences
groupPreferences = GroupPreferences -> Maybe GroupPreferences
forall a. a -> Maybe a
Just GroupPreferences
groupPreferences, memberAdmission :: Maybe GroupMemberAdmission
memberAdmission = Maybe GroupMemberAdmission
forall a. Maybe a
Nothing}

introduceToModerators :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
introduceToModerators :: VersionRangeChat
-> User
-> GroupInfo
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) ()
introduceToModerators VersionRangeChat
vr User
user gInfo :: GroupInfo
gInfo@GroupInfo {UserId
groupId :: GroupInfo -> UserId
groupId :: UserId
groupId} m :: GroupMember
m@GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole, MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId} = do
  Maybe Connection
-> (Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GroupMember -> Maybe Connection
memberConn GroupMember
m) ((Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
mConn -> do
    let msg :: ChatMsgEvent 'Json
msg =
          if 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
            then GroupAcceptance
-> GroupMemberRole -> MemberId -> ChatMsgEvent 'Json
XGrpLinkAcpt GroupAcceptance
GAPendingReview GroupMemberRole
memberRole MemberId
memberId
            else 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 (ContactName -> MsgContent
MCText ContactName
pendingReviewMessage) Maybe FileInvitation
forall a. Maybe a
Nothing
    ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, UserId, PQEncryption)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
sendDirectMemberMessage Connection
mConn ChatMsgEvent 'Json
msg UserId
groupId
  [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 rcpModMs :: [GroupMember]
rcpModMs = (GroupMember -> Bool) -> [GroupMember] -> [GroupMember]
forall a. (a -> Bool) -> [a] -> [a]
filter GroupMember -> Bool
shouldIntroduceToMod [GroupMember]
modMs
  User
-> GroupInfo
-> GroupMember
-> [GroupMember]
-> Maybe MsgScope
-> ExceptT ChatError (ReaderT ChatController IO) ()
introduceMember User
user GroupInfo
gInfo GroupMember
m [GroupMember]
rcpModMs (MsgScope -> Maybe MsgScope
forall a. a -> Maybe a
Just (MsgScope -> Maybe MsgScope) -> MsgScope -> Maybe MsgScope
forall a b. (a -> b) -> a -> b
$ MemberId -> MsgScope
MSMember (MemberId -> MsgScope) -> MemberId -> MsgScope
forall a b. (a -> b) -> a -> b
$ GroupMember -> MemberId
memberId' GroupMember
m)
  where
    shouldIntroduceToMod :: GroupMember -> Bool
    shouldIntroduceToMod :: GroupMember -> Bool
shouldIntroduceToMod GroupMember
mem =
      GroupMember -> Bool
memberCurrent GroupMember
mem
        Bool -> Bool -> Bool
&& GroupMember -> UserId
groupMemberId' GroupMember
mem UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
/= GroupMember -> UserId
groupMemberId' GroupMember
m
        Bool -> Bool -> Bool
&& VersionRangeChat -> Version ChatVersion
forall v. VersionRange v -> Version v
maxVersion (GroupMember -> VersionRangeChat
memberChatVRange GroupMember
mem) Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
groupKnockingVersion

introduceToAll :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
introduceToAll :: VersionRangeChat
-> User
-> GroupInfo
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) ()
introduceToAll VersionRangeChat
vr User
user GroupInfo
gInfo GroupMember
m = do
  [GroupMember]
members <- (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
  ByteString
vector <- (Connection -> ExceptT StoreError IO ByteString) -> CM ByteString
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (Connection -> GroupMember -> ExceptT StoreError IO ByteString
`getMemberRelationsVector` GroupMember
m)
  let recipients :: [GroupMember]
recipients = (GroupMember -> Bool) -> [GroupMember] -> [GroupMember]
forall a. (a -> Bool) -> [a] -> [a]
filter (GroupMember -> ByteString -> GroupMember -> Bool
shouldIntroduce GroupMember
m ByteString
vector) [GroupMember]
members
  User
-> GroupInfo
-> GroupMember
-> [GroupMember]
-> Maybe MsgScope
-> ExceptT ChatError (ReaderT ChatController IO) ()
introduceMember User
user GroupInfo
gInfo GroupMember
m [GroupMember]
recipients Maybe MsgScope
forall a. Maybe a
Nothing

introduceToRemaining :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
introduceToRemaining :: VersionRangeChat
-> User
-> GroupInfo
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) ()
introduceToRemaining VersionRangeChat
vr User
user GroupInfo
gInfo GroupMember
m = do
  [GroupMember]
members <- (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
  ByteString
vector <- (Connection -> ExceptT StoreError IO ByteString) -> CM ByteString
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (Connection -> GroupMember -> ExceptT StoreError IO ByteString
`getMemberRelationsVector` GroupMember
m)
  let recipients :: [GroupMember]
recipients = (GroupMember -> Bool) -> [GroupMember] -> [GroupMember]
forall a. (a -> Bool) -> [a] -> [a]
filter (GroupMember -> ByteString -> GroupMember -> Bool
shouldIntroduce GroupMember
m ByteString
vector) [GroupMember]
members
  User
-> GroupInfo
-> GroupMember
-> [GroupMember]
-> Maybe MsgScope
-> ExceptT ChatError (ReaderT ChatController IO) ()
introduceMember User
user GroupInfo
gInfo GroupMember
m [GroupMember]
recipients Maybe MsgScope
forall a. Maybe a
Nothing

shouldIntroduce :: GroupMember -> ByteString -> GroupMember -> Bool
shouldIntroduce :: GroupMember -> ByteString -> GroupMember -> Bool
shouldIntroduce GroupMember
m ByteString
vec GroupMember
mem =
  GroupMember -> Bool
memberCurrent GroupMember
mem
    Bool -> Bool -> Bool
&& GroupMember -> UserId
groupMemberId' GroupMember
mem UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
/= GroupMember -> UserId
groupMemberId' GroupMember
m
    Bool -> Bool -> Bool
&& UserId -> ByteString -> MemberRelation
getRelation (GroupMember -> UserId
indexInGroup GroupMember
mem) ByteString
vec MemberRelation -> MemberRelation -> Bool
forall a. Eq a => a -> a -> Bool
== MemberRelation
MRNew

introduceMember :: User -> GroupInfo -> GroupMember -> [GroupMember] -> Maybe MsgScope -> CM ()
introduceMember :: User
-> GroupInfo
-> GroupMember
-> [GroupMember]
-> Maybe MsgScope
-> ExceptT ChatError (ReaderT ChatController IO) ()
introduceMember User
_ GroupInfo
_ GroupMember {activeConn :: GroupMember -> Maybe Connection
activeConn = Maybe Connection
Nothing} [GroupMember]
_ Maybe MsgScope
_ = ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError String
"member connection not active"
introduceMember User
user gInfo :: GroupInfo
gInfo@GroupInfo {UserId
groupId :: GroupInfo -> UserId
groupId :: UserId
groupId} toMember :: GroupMember
toMember@GroupMember {activeConn :: GroupMember -> Maybe Connection
activeConn = Just Connection
conn} [GroupMember]
introduceToMembers Maybe MsgScope
msgScope = do
  ExceptT ChatError (ReaderT ChatController IO) SndMessage
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) SndMessage
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (ChatMsgEvent 'Json
    -> ExceptT ChatError (ReaderT ChatController IO) SndMessage)
-> ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 [GroupMember]
introduceToMembers (ChatMsgEvent 'Json
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatMsgEvent 'Json
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ MemberInfo -> Maybe MsgScope -> ChatMsgEvent 'Json
XGrpMemNew (GroupInfo -> GroupMember -> MemberInfo
memberInfo GroupInfo
gInfo GroupMember
toMember) Maybe MsgScope
msgScope
  [GroupMember] -> ExceptT ChatError (ReaderT ChatController IO) ()
sendIntroductions [GroupMember]
introduceToMembers
  where
    sendIntroductions :: [GroupMember] -> ExceptT ChatError (ReaderT ChatController IO) ()
sendIntroductions [GroupMember]
reMembers = do
      [GroupMember] -> ExceptT ChatError (ReaderT ChatController IO) ()
updateToMemberVector [GroupMember]
reMembers
      [GroupMember] -> ExceptT ChatError (ReaderT ChatController IO) ()
updateReMembersVectors [GroupMember]
reMembers
      [GroupMember]
shuffledReMembers <- IO [GroupMember] -> CM [GroupMember]
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [GroupMember] -> CM [GroupMember])
-> IO [GroupMember] -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ [GroupMember] -> IO [GroupMember]
shuffleMembers [GroupMember]
reMembers
      if GroupMember
toMember GroupMember -> Version ChatVersion -> Bool
`supportsVersion` Version ChatVersion
batchSendVersion
        then do
          let events :: [ChatMsgEvent 'Json]
events = (GroupMember -> ChatMsgEvent 'Json)
-> [GroupMember] -> [ChatMsgEvent 'Json]
forall a b. (a -> b) -> [a] -> [b]
map GroupMember -> ChatMsgEvent 'Json
memberIntro [GroupMember]
shuffledReMembers
          Maybe (NonEmpty (ChatMsgEvent 'Json))
-> (NonEmpty (ChatMsgEvent 'Json)
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([ChatMsgEvent 'Json] -> Maybe (NonEmpty (ChatMsgEvent 'Json))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [ChatMsgEvent 'Json]
events) ((NonEmpty (ChatMsgEvent 'Json)
  -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (NonEmpty (ChatMsgEvent 'Json)
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty (ChatMsgEvent 'Json)
events' ->
            User
-> Connection
-> NonEmpty (ChatMsgEvent 'Json)
-> UserId
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Connection
-> NonEmpty (ChatMsgEvent e)
-> UserId
-> ExceptT ChatError (ReaderT ChatController IO) ()
sendGroupMemberMessages User
user Connection
conn NonEmpty (ChatMsgEvent 'Json)
events' UserId
groupId
        else [GroupMember]
-> (GroupMember
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GroupMember]
shuffledReMembers ((GroupMember -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (GroupMember
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \GroupMember
reMember ->
          ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, UserId, PQEncryption)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
sendDirectMemberMessage Connection
conn (GroupMember -> ChatMsgEvent 'Json
memberIntro GroupMember
reMember) UserId
groupId
    updateToMemberVector :: [GroupMember] -> CM ()
    updateToMemberVector :: [GroupMember] -> ExceptT ChatError (ReaderT ChatController IO) ()
updateToMemberVector [GroupMember]
reMembers = do
      let relations :: [(UserId, (IntroductionDirection, MemberRelation))]
relations = (GroupMember -> (UserId, (IntroductionDirection, MemberRelation)))
-> [GroupMember]
-> [(UserId, (IntroductionDirection, MemberRelation))]
forall a b. (a -> b) -> [a] -> [b]
map (\GroupMember {UserId
indexInGroup :: GroupMember -> UserId
indexInGroup :: UserId
indexInGroup} -> (UserId
indexInGroup, (IntroductionDirection
IDReferencedIntroduced, MemberRelation
MRIntroduced))) [GroupMember]
reMembers
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMember
-> [(UserId, (IntroductionDirection, MemberRelation))]
-> IO ()
setMemberVectorNewRelations Connection
db GroupMember
toMember [(UserId, (IntroductionDirection, MemberRelation))]
relations
    updateReMembersVectors :: [GroupMember] -> CM ()
    updateReMembersVectors :: [GroupMember] -> ExceptT ChatError (ReaderT ChatController IO) ()
updateReMembersVectors [GroupMember]
reMembers = do
      let GroupMember {UserId
indexInGroup :: GroupMember -> UserId
indexInGroup :: UserId
indexInGroup} = GroupMember
toMember
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> [GroupMember]
-> UserId
-> IntroductionDirection
-> MemberRelation
-> IO ()
setMembersVectorsNewRelation Connection
db [GroupMember]
reMembers UserId
indexInGroup IntroductionDirection
IDSubjectIntroduced MemberRelation
MRIntroduced
    memberIntro :: GroupMember -> ChatMsgEvent 'Json
    memberIntro :: GroupMember -> ChatMsgEvent 'Json
memberIntro GroupMember
reMember =
      let mInfo :: MemberInfo
mInfo = GroupInfo -> GroupMember -> MemberInfo
memberInfo GroupInfo
gInfo GroupMember
reMember
          mRestrictions :: Maybe MemberRestrictions
mRestrictions = GroupMember -> Maybe MemberRestrictions
memberRestrictions GroupMember
reMember
       in MemberInfo -> Maybe MemberRestrictions -> ChatMsgEvent 'Json
XGrpMemIntro MemberInfo
mInfo Maybe MemberRestrictions
mRestrictions
    shuffleMembers :: [GroupMember] -> IO [GroupMember]
    shuffleMembers :: [GroupMember] -> IO [GroupMember]
shuffleMembers [GroupMember]
reMembers = do
      let ([GroupMember]
admins, [GroupMember]
others) = (GroupMember -> Bool)
-> [GroupMember] -> ([GroupMember], [GroupMember])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition GroupMember -> Bool
isAdmin [GroupMember]
reMembers
          ([GroupMember]
admPics, [GroupMember]
admNoPics) = (GroupMember -> Bool)
-> [GroupMember] -> ([GroupMember], [GroupMember])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition GroupMember -> Bool
hasPicture [GroupMember]
admins
          ([GroupMember]
othPics, [GroupMember]
othNoPics) = (GroupMember -> Bool)
-> [GroupMember] -> ([GroupMember], [GroupMember])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition GroupMember -> Bool
hasPicture [GroupMember]
others
      [[GroupMember]] -> [GroupMember]
forall a. Monoid a => [a] -> a
mconcat ([[GroupMember]] -> [GroupMember])
-> IO [[GroupMember]] -> IO [GroupMember]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([GroupMember] -> IO [GroupMember])
-> [[GroupMember]] -> IO [[GroupMember]]
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 [GroupMember] -> IO [GroupMember]
forall a. [a] -> IO [a]
shuffle [[GroupMember]
Item [[GroupMember]]
admPics, [GroupMember]
Item [[GroupMember]]
admNoPics, [GroupMember]
Item [[GroupMember]]
othPics, [GroupMember]
Item [[GroupMember]]
othNoPics]
      where
        isAdmin :: GroupMember -> Bool
isAdmin GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole} = GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
>= GroupMemberRole
GRAdmin
        hasPicture :: GroupMember -> Bool
hasPicture GroupMember {memberProfile :: GroupMember -> LocalProfile
memberProfile = LocalProfile {Maybe ImageData
image :: Maybe ImageData
image :: LocalProfile -> Maybe ImageData
image}} = Maybe ImageData -> Bool
forall a. Maybe a -> Bool
isJust Maybe ImageData
image

userProfileInGroup :: User -> GroupInfo -> Maybe Profile -> Profile
userProfileInGroup :: User -> GroupInfo -> Maybe Profile -> Profile
userProfileInGroup User
user = User -> Bool -> Maybe Profile -> Profile
userProfileInGroup' User
user (Bool -> Maybe Profile -> Profile)
-> (GroupInfo -> Bool) -> GroupInfo -> Maybe Profile -> Profile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SGroupFeature 'GFSimplexLinks -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupInfo -> Bool
groupFeatureUserAllowed SGroupFeature 'GFSimplexLinks
SGFSimplexLinks
{-# INLINE userProfileInGroup #-}

userProfileInGroup' :: User -> Bool -> Maybe Profile -> Profile
userProfileInGroup' :: User -> Bool -> Maybe Profile -> Profile
userProfileInGroup' User {profile :: User -> LocalProfile
profile = LocalProfile
p} Bool
allowSimplexLinks Maybe Profile
incognitoProfile =
  let p' :: Profile
p' = Profile -> Maybe Profile -> Profile
forall a. a -> Maybe a -> a
fromMaybe (LocalProfile -> Profile
fromLocalProfile LocalProfile
p) Maybe Profile
incognitoProfile
   in Bool -> Profile -> Profile
redactedMemberProfile Bool
allowSimplexLinks Profile
p'

memberInfo :: GroupInfo -> GroupMember -> MemberInfo
memberInfo :: GroupInfo -> GroupMember -> MemberInfo
memberInfo GroupInfo
g m :: GroupMember
m@GroupMember {MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId, GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole, LocalProfile
memberProfile :: GroupMember -> LocalProfile
memberProfile :: LocalProfile
memberProfile, Maybe Connection
activeConn :: GroupMember -> Maybe Connection
activeConn :: Maybe Connection
activeConn} =
  MemberInfo
    { MemberId
memberId :: MemberId
memberId :: MemberId
memberId,
      GroupMemberRole
memberRole :: GroupMemberRole
memberRole :: GroupMemberRole
memberRole,
      v :: Maybe ChatVersionRange
v = VersionRangeChat -> ChatVersionRange
ChatVersionRange (VersionRangeChat -> ChatVersionRange)
-> (Connection -> VersionRangeChat)
-> Connection
-> ChatVersionRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> VersionRangeChat
peerChatVRange (Connection -> ChatVersionRange)
-> Maybe Connection -> Maybe ChatVersionRange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Connection
activeConn,
      profile :: Profile
profile = Bool -> Profile -> Profile
redactedMemberProfile Bool
allowSimplexLinks (Profile -> Profile) -> Profile -> Profile
forall a b. (a -> b) -> a -> b
$ LocalProfile -> Profile
fromLocalProfile LocalProfile
memberProfile
    }
  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
g

redactedMemberProfile :: Bool -> Profile -> Profile
redactedMemberProfile :: Bool -> Profile -> Profile
redactedMemberProfile Bool
allowSimplexLinks Profile {ContactName
displayName :: Profile -> ContactName
displayName :: ContactName
displayName, ContactName
fullName :: Profile -> ContactName
fullName :: ContactName
fullName, Maybe ContactName
shortDescr :: Profile -> Maybe ContactName
shortDescr :: Maybe ContactName
shortDescr, Maybe ImageData
image :: Profile -> Maybe ImageData
image :: Maybe ImageData
image, Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType :: Profile -> Maybe ChatPeerType
peerType} =
  Profile {ContactName
displayName :: ContactName
displayName :: ContactName
displayName, ContactName
fullName :: ContactName
fullName :: ContactName
fullName, shortDescr :: Maybe ContactName
shortDescr = ContactName -> Maybe ContactName
removeSimplexLink (ContactName -> Maybe ContactName)
-> Maybe ContactName -> Maybe ContactName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ContactName
shortDescr, Maybe ImageData
image :: Maybe ImageData
image :: Maybe ImageData
image, contactLink :: Maybe ConnLinkContact
contactLink = Maybe ConnLinkContact
forall a. Maybe a
Nothing, preferences :: Maybe Preferences
preferences = Maybe Preferences
forall a. Maybe a
Nothing, Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType :: Maybe ChatPeerType
peerType}
  where
    removeSimplexLink :: ContactName -> Maybe ContactName
removeSimplexLink ContactName
s
      | Bool
allowSimplexLinks = ContactName -> Maybe ContactName
forall a. a -> Maybe a
Just ContactName
s
      | Bool
otherwise = Maybe ContactName
-> (MarkdownList -> Maybe ContactName)
-> Maybe MarkdownList
-> Maybe ContactName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ContactName -> Maybe ContactName
forall a. a -> Maybe a
Just ContactName
s) (\MarkdownList
fts -> if (FormattedText -> Bool) -> MarkdownList -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any FormattedText -> Bool
ftIsSimplexLink MarkdownList
fts then Maybe ContactName
forall a. Maybe a
Nothing else ContactName -> Maybe ContactName
forall a. a -> Maybe a
Just ContactName
s) (Maybe MarkdownList -> Maybe ContactName)
-> Maybe MarkdownList -> Maybe ContactName
forall a b. (a -> b) -> a -> b
$ ContactName -> Maybe MarkdownList
parseMaybeMarkdownList ContactName
s

sendHistory :: User -> GroupInfo -> GroupMember -> CM ()
sendHistory :: User
-> GroupInfo
-> GroupMember
-> ExceptT ChatError (ReaderT ChatController IO) ()
sendHistory User
_ GroupInfo
_ GroupMember {activeConn :: GroupMember -> Maybe Connection
activeConn = Maybe Connection
Nothing} = ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError String
"member connection not active"
sendHistory User
user gInfo :: GroupInfo
gInfo@GroupInfo {UserId
groupId :: GroupInfo -> UserId
groupId :: UserId
groupId, GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} m :: GroupMember
m@GroupMember {activeConn :: GroupMember -> Maybe Connection
activeConn = Just Connection
conn} =
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupMember
m GroupMember -> Version ChatVersion -> Bool
`supportsVersion` Version ChatVersion
batchSendVersion) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ do
    ([StoreError]
errs, [CChatItem 'CTGroup]
items) <- [Either StoreError (CChatItem 'CTGroup)]
-> ([StoreError], [CChatItem 'CTGroup])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either StoreError (CChatItem 'CTGroup)]
 -> ([StoreError], [CChatItem 'CTGroup]))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Either StoreError (CChatItem 'CTGroup)]
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([StoreError], [CChatItem 'CTGroup])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> IO [Either StoreError (CChatItem 'CTGroup)])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Either StoreError (CChatItem 'CTGroup)]
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> Connection
-> User
-> GroupInfo
-> GroupMember
-> Int
-> IO [Either StoreError (CChatItem 'CTGroup)]
getGroupHistoryItems Connection
db User
user GroupInfo
gInfo GroupMember
m Int
100)
    ([ChatError]
errs', [[ChatMsgEvent 'Json]]
events) <- [Either ChatError [ChatMsgEvent 'Json]]
-> ([ChatError], [[ChatMsgEvent 'Json]])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ChatError [ChatMsgEvent 'Json]]
 -> ([ChatError], [[ChatMsgEvent 'Json]]))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Either ChatError [ChatMsgEvent 'Json]]
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [[ChatMsgEvent 'Json]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CChatItem 'CTGroup
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Either ChatError [ChatMsgEvent 'Json]))
-> [CChatItem 'CTGroup]
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Either ChatError [ChatMsgEvent 'Json]]
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 (ExceptT ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either ChatError [ChatMsgEvent 'Json])
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors (ExceptT ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Either ChatError [ChatMsgEvent 'Json]))
-> (CChatItem 'CTGroup
    -> ExceptT
         ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json])
-> CChatItem 'CTGroup
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either ChatError [ChatMsgEvent 'Json])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CChatItem 'CTGroup
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
itemForwardEvents) [CChatItem 'CTGroup]
items
    let errors :: [ChatError]
errors = (StoreError -> ChatError) -> [StoreError] -> [ChatError]
forall a b. (a -> b) -> [a] -> [b]
map StoreError -> ChatError
ChatErrorStore [StoreError]
errs [ChatError] -> [ChatError] -> [ChatError]
forall a. Semigroup a => a -> a -> a
<> [ChatError]
errs'
    Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ChatError] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ChatError]
errors) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ [ChatError] -> ChatEvent
CEvtChatErrors [ChatError]
errors
    let events' :: [ChatMsgEvent 'Json]
events' = [[ChatMsgEvent 'Json]] -> [ChatMsgEvent 'Json]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ChatMsgEvent 'Json]]
events
    [ChatMsgEvent 'Json]
events_ <- case Maybe (ChatMsgEvent 'Json)
descrEvent_ of
      Just ChatMsgEvent 'Json
descr -> Maybe (Maybe XContactId, Maybe SharedMsgId) -> [ChatMsgEvent 'Json]
mkEvents (Maybe (Maybe XContactId, Maybe SharedMsgId)
 -> [ChatMsgEvent 'Json])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (Maybe XContactId, Maybe SharedMsgId))
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> IO (Maybe (Maybe XContactId, Maybe SharedMsgId)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (Maybe XContactId, Maybe SharedMsgId))
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> Connection
-> User
-> GroupInfo
-> GroupMember
-> IO (Maybe (Maybe XContactId, Maybe SharedMsgId))
getMemberJoinRequest Connection
db User
user GroupInfo
gInfo GroupMember
m)
        where
          mkEvents :: Maybe (Maybe XContactId, Maybe SharedMsgId) -> [ChatMsgEvent 'Json]
mkEvents = \case
            Just (Maybe XContactId
_, Just SharedMsgId
_welcomeMsgId) -> [ChatMsgEvent 'Json]
events'
            Maybe (Maybe XContactId, Maybe SharedMsgId)
_ -> [ChatMsgEvent 'Json]
events' [ChatMsgEvent 'Json]
-> [ChatMsgEvent 'Json] -> [ChatMsgEvent 'Json]
forall a. Semigroup a => a -> a -> a
<> [Item [ChatMsgEvent 'Json]
ChatMsgEvent 'Json
descr]
      Maybe (ChatMsgEvent 'Json)
Nothing -> [ChatMsgEvent 'Json]
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ChatMsgEvent 'Json]
events'
    Maybe (NonEmpty (ChatMsgEvent 'Json))
-> (NonEmpty (ChatMsgEvent 'Json)
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([ChatMsgEvent 'Json] -> Maybe (NonEmpty (ChatMsgEvent 'Json))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [ChatMsgEvent 'Json]
events_) ((NonEmpty (ChatMsgEvent 'Json)
  -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (NonEmpty (ChatMsgEvent 'Json)
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty (ChatMsgEvent 'Json)
events'' ->
      User
-> Connection
-> NonEmpty (ChatMsgEvent 'Json)
-> UserId
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Connection
-> NonEmpty (ChatMsgEvent e)
-> UserId
-> ExceptT ChatError (ReaderT ChatController IO) ()
sendGroupMemberMessages User
user Connection
conn NonEmpty (ChatMsgEvent 'Json)
events'' UserId
groupId
  where
    descrEvent_ :: Maybe (ChatMsgEvent 'Json)
    descrEvent_ :: Maybe (ChatMsgEvent 'Json)
descrEvent_
      | GroupMember
m GroupMember -> Version ChatVersion -> Bool
`supportsVersion` Version ChatVersion
groupHistoryIncludeWelcomeVersion = do
          let GroupInfo {groupProfile :: GroupInfo -> GroupProfile
groupProfile = GroupProfile {Maybe ContactName
description :: GroupProfile -> Maybe ContactName
description :: Maybe ContactName
description}} = GroupInfo
gInfo
          (ContactName -> ChatMsgEvent 'Json)
-> Maybe ContactName -> Maybe (ChatMsgEvent 'Json)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ContactName
descr -> 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 (ContactName -> MsgContent
MCText ContactName
descr) Maybe FileInvitation
forall a. Maybe a
Nothing) Maybe ContactName
description
      | Bool
otherwise = Maybe (ChatMsgEvent 'Json)
forall a. Maybe a
Nothing
    itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json]
    itemForwardEvents :: CChatItem 'CTGroup
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
itemForwardEvents 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
sender, content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content = CIRcvMsgContent MsgContent
mc, Maybe (CIFile d)
file :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIFile d)
file :: Maybe (CIFile d)
file})
        | Bool -> Bool
not (GroupMember -> Bool
blockedByAdmin GroupMember
sender) -> do
            Maybe (FileInvitation, ContactName)
fInvDescr_ <- Maybe (Maybe (FileInvitation, ContactName))
-> Maybe (FileInvitation, ContactName)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (FileInvitation, ContactName))
 -> Maybe (FileInvitation, ContactName))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (Maybe (FileInvitation, ContactName)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CIFile d)
-> (CIFile d
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (Maybe (FileInvitation, ContactName)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (Maybe (FileInvitation, ContactName)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (CIFile d)
file CIFile d
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
CIFile 'MDRcv
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
getRcvFileInvDescr
            GroupMember
-> ChatItem 'CTGroup d
-> MsgContent
-> Maybe (FileInvitation, ContactName)
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
forall (d :: MsgDirection).
GroupMember
-> ChatItem 'CTGroup d
-> MsgContent
-> Maybe (FileInvitation, ContactName)
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
processContentItem GroupMember
sender ChatItem 'CTGroup d
ci MsgContent
mc Maybe (FileInvitation, ContactName)
fInvDescr_
      (CChatItem SMsgDirection d
SMDSnd ci :: ChatItem 'CTGroup d
ci@ChatItem {content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content = CISndMsgContent MsgContent
mc, Maybe (CIFile d)
file :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIFile d)
file :: Maybe (CIFile d)
file}) -> do
        Maybe (FileInvitation, ContactName)
fInvDescr_ <- Maybe (Maybe (FileInvitation, ContactName))
-> Maybe (FileInvitation, ContactName)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (FileInvitation, ContactName))
 -> Maybe (FileInvitation, ContactName))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (Maybe (FileInvitation, ContactName)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CIFile d)
-> (CIFile d
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (Maybe (FileInvitation, ContactName)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (Maybe (FileInvitation, ContactName)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (CIFile d)
file CIFile d
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
CIFile 'MDSnd
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
getSndFileInvDescr
        GroupMember
-> ChatItem 'CTGroup d
-> MsgContent
-> Maybe (FileInvitation, ContactName)
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
forall (d :: MsgDirection).
GroupMember
-> ChatItem 'CTGroup d
-> MsgContent
-> Maybe (FileInvitation, ContactName)
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
processContentItem GroupMember
membership ChatItem 'CTGroup d
ci MsgContent
mc Maybe (FileInvitation, ContactName)
fInvDescr_
      CChatItem 'CTGroup
_ -> [ChatMsgEvent 'Json]
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      where
        getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText))
        getRcvFileInvDescr :: CIFile 'MDRcv
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
getRcvFileInvDescr ciFile :: CIFile 'MDRcv
ciFile@CIFile {UserId
fileId :: forall (d :: MsgDirection). CIFile d -> UserId
fileId :: UserId
fileId, FileProtocol
fileProtocol :: forall (d :: MsgDirection). CIFile d -> FileProtocol
fileProtocol :: FileProtocol
fileProtocol, CIFileStatus 'MDRcv
fileStatus :: forall (d :: MsgDirection). CIFile d -> CIFileStatus d
fileStatus :: CIFileStatus 'MDRcv
fileStatus} = do
          Bool
expired <- CM Bool
fileExpired
          if FileProtocol
fileProtocol FileProtocol -> FileProtocol -> Bool
forall a. Eq a => a -> a -> Bool
/= FileProtocol
FPXFTP Bool -> Bool -> Bool
|| CIFileStatus 'MDRcv
fileStatus CIFileStatus 'MDRcv -> CIFileStatus 'MDRcv -> Bool
forall a. Eq a => a -> a -> Bool
== CIFileStatus 'MDRcv
CIFSRcvCancelled Bool -> Bool -> Bool
|| Bool
expired
            then Maybe (FileInvitation, ContactName)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (FileInvitation, ContactName)
forall a. Maybe a
Nothing
            else do
              RcvFileDescr
rfd <- (Connection -> ExceptT StoreError IO RcvFileDescr)
-> CM RcvFileDescr
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RcvFileDescr)
 -> CM RcvFileDescr)
-> (Connection -> ExceptT StoreError IO RcvFileDescr)
-> CM RcvFileDescr
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrByRcvFileId Connection
db UserId
fileId
              Maybe (FileInvitation, ContactName)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (FileInvitation, ContactName)
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Maybe (FileInvitation, ContactName)))
-> Maybe (FileInvitation, ContactName)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
forall a b. (a -> b) -> a -> b
$ CIFile 'MDRcv
-> RcvFileDescr -> Maybe (FileInvitation, ContactName)
forall (d :: MsgDirection).
CIFile d -> RcvFileDescr -> Maybe (FileInvitation, ContactName)
invCompleteDescr CIFile 'MDRcv
ciFile RcvFileDescr
rfd
        getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe (FileInvitation, RcvFileDescrText))
        getSndFileInvDescr :: CIFile 'MDSnd
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
getSndFileInvDescr ciFile :: CIFile 'MDSnd
ciFile@CIFile {UserId
fileId :: forall (d :: MsgDirection). CIFile d -> UserId
fileId :: UserId
fileId, FileProtocol
fileProtocol :: forall (d :: MsgDirection). CIFile d -> FileProtocol
fileProtocol :: FileProtocol
fileProtocol, CIFileStatus 'MDSnd
fileStatus :: forall (d :: MsgDirection). CIFile d -> CIFileStatus d
fileStatus :: CIFileStatus 'MDSnd
fileStatus} = do
          Bool
expired <- CM Bool
fileExpired
          if FileProtocol
fileProtocol FileProtocol -> FileProtocol -> Bool
forall a. Eq a => a -> a -> Bool
/= FileProtocol
FPXFTP Bool -> Bool -> Bool
|| CIFileStatus 'MDSnd
fileStatus CIFileStatus 'MDSnd -> CIFileStatus 'MDSnd -> Bool
forall a. Eq a => a -> a -> Bool
== CIFileStatus 'MDSnd
CIFSSndCancelled Bool -> Bool -> Bool
|| Bool
expired
            then Maybe (FileInvitation, ContactName)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (FileInvitation, ContactName)
forall a. Maybe a
Nothing
            else do
              -- can also lookup in extra_xftp_file_descriptions, though it can be empty;
              -- would be best if snd file had a single rcv description for all members saved in files table
              RcvFileDescr
rfd <- (Connection -> ExceptT StoreError IO RcvFileDescr)
-> CM RcvFileDescr
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RcvFileDescr)
 -> CM RcvFileDescr)
-> (Connection -> ExceptT StoreError IO RcvFileDescr)
-> CM RcvFileDescr
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrBySndFileId Connection
db UserId
fileId
              Maybe (FileInvitation, ContactName)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (FileInvitation, ContactName)
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Maybe (FileInvitation, ContactName)))
-> Maybe (FileInvitation, ContactName)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (FileInvitation, ContactName))
forall a b. (a -> b) -> a -> b
$ CIFile 'MDSnd
-> RcvFileDescr -> Maybe (FileInvitation, ContactName)
forall (d :: MsgDirection).
CIFile d -> RcvFileDescr -> Maybe (FileInvitation, ContactName)
invCompleteDescr CIFile 'MDSnd
ciFile RcvFileDescr
rfd
        fileExpired :: CM Bool
        fileExpired :: CM Bool
fileExpired = do
          NominalDiffTime
ttl <- (ChatController -> NominalDiffTime)
-> ExceptT ChatError (ReaderT ChatController IO) NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ChatController -> NominalDiffTime)
 -> ExceptT ChatError (ReaderT ChatController IO) NominalDiffTime)
-> (ChatController -> NominalDiffTime)
-> ExceptT ChatError (ReaderT ChatController IO) NominalDiffTime
forall a b. (a -> b) -> a -> b
$ AgentConfig -> NominalDiffTime
rcvFilesTTL (AgentConfig -> NominalDiffTime)
-> (ChatController -> AgentConfig)
-> ChatController
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatConfig -> AgentConfig
agentConfig (ChatConfig -> AgentConfig)
-> (ChatController -> ChatConfig) -> ChatController -> AgentConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config
          UTCTime
cutoffTs <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-NominalDiffTime
ttl) (UTCTime -> UTCTime)
-> ExceptT ChatError (ReaderT ChatController IO) UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
          Bool -> CM Bool
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> CM Bool) -> Bool -> CM Bool
forall a b. (a -> b) -> a -> b
$ CChatItem 'CTGroup -> UTCTime
forall (c :: ChatType). CChatItem c -> UTCTime
chatItemTs CChatItem 'CTGroup
cci UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
cutoffTs
        invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText)
        invCompleteDescr :: forall (d :: MsgDirection).
CIFile d -> RcvFileDescr -> Maybe (FileInvitation, ContactName)
invCompleteDescr CIFile {String
fileName :: forall (d :: MsgDirection). CIFile d -> String
fileName :: String
fileName, Integer
fileSize :: forall (d :: MsgDirection). CIFile d -> Integer
fileSize :: Integer
fileSize} RcvFileDescr {ContactName
fileDescrText :: RcvFileDescr -> ContactName
fileDescrText :: ContactName
fileDescrText, Bool
fileDescrComplete :: RcvFileDescr -> Bool
fileDescrComplete :: Bool
fileDescrComplete}
          | Bool
fileDescrComplete =
              let fInvDescr :: FileDescr
fInvDescr = FileDescr {fileDescrText :: ContactName
fileDescrText = ContactName
"", fileDescrPartNo :: Int
fileDescrPartNo = Int
0, fileDescrComplete :: Bool
fileDescrComplete = Bool
False}
                  fInv :: FileInvitation
fInv = String -> Integer -> FileDescr -> FileInvitation
xftpFileInvitation String
fileName Integer
fileSize FileDescr
fInvDescr
               in (FileInvitation, ContactName)
-> Maybe (FileInvitation, ContactName)
forall a. a -> Maybe a
Just (FileInvitation
fInv, ContactName
fileDescrText)
          | Bool
otherwise = Maybe (FileInvitation, ContactName)
forall a. Maybe a
Nothing
        processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json]
        processContentItem :: forall (d :: MsgDirection).
GroupMember
-> ChatItem 'CTGroup d
-> MsgContent
-> Maybe (FileInvitation, ContactName)
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
processContentItem GroupMember
sender ChatItem {Maybe MarkdownList
formattedText :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe MarkdownList
formattedText :: Maybe MarkdownList
formattedText, CIMeta 'CTGroup d
meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta :: CIMeta 'CTGroup d
meta, Maybe (CIQuote 'CTGroup)
quotedItem :: Maybe (CIQuote 'CTGroup)
quotedItem :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe (CIQuote c)
quotedItem, Map ContactName CIMention
mentions :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Map ContactName CIMention
mentions :: Map ContactName CIMention
mentions} MsgContent
mc Maybe (FileInvitation, ContactName)
fInvDescr_ =
          if Maybe (FileInvitation, ContactName) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (FileInvitation, ContactName)
fInvDescr_ Bool -> Bool -> Bool
&& Bool -> Bool
not (MsgContent -> Bool
msgContentHasText MsgContent
mc)
            then [ChatMsgEvent 'Json]
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            else do
              let CIMeta {UTCTime
itemTs :: forall (c :: ChatType) (d :: MsgDirection). CIMeta c d -> UTCTime
itemTs :: UTCTime
itemTs, Maybe SharedMsgId
itemSharedMsgId :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> Maybe SharedMsgId
itemSharedMsgId :: Maybe SharedMsgId
itemSharedMsgId, Maybe CITimed
itemTimed :: Maybe CITimed
itemTimed :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> Maybe CITimed
itemTimed} = CIMeta 'CTGroup d
meta
                  quotedItemId_ :: Maybe UserId
quotedItemId_ = CIQuote 'CTGroup -> Maybe UserId
forall (c :: ChatType). CIQuote c -> Maybe UserId
quoteItemId (CIQuote 'CTGroup -> Maybe UserId)
-> Maybe (CIQuote 'CTGroup) -> Maybe UserId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (CIQuote 'CTGroup)
quotedItem
                  fInv_ :: Maybe FileInvitation
fInv_ = (FileInvitation, ContactName) -> FileInvitation
forall a b. (a, b) -> a
fst ((FileInvitation, ContactName) -> FileInvitation)
-> Maybe (FileInvitation, ContactName) -> Maybe FileInvitation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (FileInvitation, ContactName)
fInvDescr_
                  (MsgContent
mc', Maybe MarkdownList
_, Map ContactName CIMention
mentions') = MsgContent
-> Maybe MarkdownList
-> Map ContactName CIMention
-> (MsgContent, Maybe MarkdownList, Map ContactName CIMention)
updatedMentionNames MsgContent
mc Maybe MarkdownList
formattedText Map ContactName CIMention
mentions
                  mentions'' :: Map ContactName MsgMention
mentions'' = (CIMention -> MsgMention)
-> Map ContactName CIMention -> Map ContactName MsgMention
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\CIMention {MemberId
memberId :: MemberId
memberId :: CIMention -> MemberId
memberId} -> MsgMention {MemberId
memberId :: MemberId
memberId :: MemberId
memberId}) Map ContactName CIMention
mentions'
              -- TODO [knocking] send history to other scopes too?
              (ChatMsgEvent 'Json
chatMsgEvent, Maybe (CIQuote 'CTGroup)
_) <- (Connection
 -> ExceptT
      StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup)))
-> CM (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection
  -> ExceptT
       StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup)))
 -> CM (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup)))
-> (Connection
    -> ExceptT
         StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup)))
-> CM (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> User
-> GroupInfo
-> Maybe MsgScope
-> MsgContent
-> Map ContactName MsgMention
-> Maybe UserId
-> Maybe CIForwardedFrom
-> Maybe FileInvitation
-> Maybe CITimed
-> Bool
-> ExceptT
     StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
prepareGroupMsg Connection
db User
user GroupInfo
gInfo Maybe MsgScope
forall a. Maybe a
Nothing MsgContent
mc' Map ContactName MsgMention
mentions'' Maybe UserId
quotedItemId_ Maybe CIForwardedFrom
forall a. Maybe a
Nothing Maybe FileInvitation
fInv_ Maybe CITimed
itemTimed Bool
False
              let senderVRange :: VersionRangeChat
senderVRange = GroupMember -> VersionRangeChat
memberChatVRange' GroupMember
sender
                  xMsgNewChatMsg :: ChatMessage 'Json
xMsgNewChatMsg = ChatMessage {chatVRange :: VersionRangeChat
chatVRange = VersionRangeChat
senderVRange, msgId :: Maybe SharedMsgId
msgId = Maybe SharedMsgId
itemSharedMsgId, ChatMsgEvent 'Json
chatMsgEvent :: ChatMsgEvent 'Json
chatMsgEvent :: ChatMsgEvent 'Json
chatMsgEvent}
              [ChatMsgEvent 'Json]
fileDescrEvents <- case ((FileInvitation, ContactName) -> ContactName
forall a b. (a, b) -> b
snd ((FileInvitation, ContactName) -> ContactName)
-> Maybe (FileInvitation, ContactName) -> Maybe ContactName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (FileInvitation, ContactName)
fInvDescr_, Maybe SharedMsgId
itemSharedMsgId) of
                (Just ContactName
fileDescrText, Just SharedMsgId
msgId) -> do
                  Int
partSize <- (ChatController -> Int) -> CM Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ChatController -> Int) -> CM Int)
-> (ChatController -> Int) -> CM 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 parts :: NonEmpty FileDescr
parts = Int -> ContactName -> NonEmpty FileDescr
splitFileDescr Int
partSize ContactName
fileDescrText
                  [ChatMsgEvent 'Json]
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ChatMsgEvent 'Json]
 -> ExceptT
      ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json])
-> (NonEmpty (ChatMsgEvent 'Json) -> [ChatMsgEvent 'Json])
-> NonEmpty (ChatMsgEvent 'Json)
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ChatMsgEvent 'Json) -> [ChatMsgEvent 'Json]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty (ChatMsgEvent 'Json)
 -> ExceptT
      ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json])
-> NonEmpty (ChatMsgEvent 'Json)
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
forall a b. (a -> b) -> a -> b
$ (FileDescr -> ChatMsgEvent 'Json)
-> NonEmpty FileDescr -> NonEmpty (ChatMsgEvent 'Json)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (SharedMsgId -> FileDescr -> ChatMsgEvent 'Json
XMsgFileDescr SharedMsgId
msgId) NonEmpty FileDescr
parts
                (Maybe ContactName, Maybe SharedMsgId)
_ -> [ChatMsgEvent 'Json]
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
              let fileDescrChatMsgs :: [ChatMessage 'Json]
fileDescrChatMsgs = (ChatMsgEvent 'Json -> ChatMessage 'Json)
-> [ChatMsgEvent 'Json] -> [ChatMessage 'Json]
forall a b. (a -> b) -> [a] -> [b]
map (VersionRangeChat
-> Maybe SharedMsgId -> ChatMsgEvent 'Json -> ChatMessage 'Json
forall (e :: MsgEncoding).
VersionRangeChat
-> Maybe SharedMsgId -> ChatMsgEvent e -> ChatMessage e
ChatMessage VersionRangeChat
senderVRange Maybe SharedMsgId
forall a. Maybe a
Nothing) [ChatMsgEvent 'Json]
fileDescrEvents
                  GroupMember {MemberId
memberId :: GroupMember -> MemberId
memberId :: MemberId
memberId} = GroupMember
sender
                  memberName :: Maybe ContactName
memberName = ContactName -> Maybe ContactName
forall a. a -> Maybe a
Just (ContactName -> Maybe ContactName)
-> ContactName -> Maybe ContactName
forall a b. (a -> b) -> a -> b
$ GroupMember -> ContactName
memberShortenedName GroupMember
sender
                  msgForwardEvents :: [ChatMsgEvent 'Json]
msgForwardEvents = (ChatMessage 'Json -> ChatMsgEvent 'Json)
-> [ChatMessage 'Json] -> [ChatMsgEvent 'Json]
forall a b. (a -> b) -> [a] -> [b]
map (\ChatMessage 'Json
cm -> MemberId
-> Maybe ContactName
-> ChatMessage 'Json
-> UTCTime
-> ChatMsgEvent 'Json
XGrpMsgForward MemberId
memberId Maybe ContactName
memberName ChatMessage 'Json
cm UTCTime
itemTs) (ChatMessage 'Json
xMsgNewChatMsg ChatMessage 'Json -> [ChatMessage 'Json] -> [ChatMessage 'Json]
forall a. a -> [a] -> [a]
: [ChatMessage 'Json]
fileDescrChatMsgs)
              [ChatMsgEvent 'Json]
-> ExceptT
     ChatError (ReaderT ChatController IO) [ChatMsgEvent 'Json]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ChatMsgEvent 'Json]
msgForwardEvents

memberShortenedName :: GroupMember -> ContactName
memberShortenedName :: GroupMember -> ContactName
memberShortenedName GroupMember {memberProfile :: GroupMember -> LocalProfile
memberProfile = LocalProfile {ContactName
displayName :: ContactName
displayName :: LocalProfile -> ContactName
displayName}}
  | ContactName -> Int
T.length ContactName
displayName Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
16 = ContactName
displayName
  | Bool
otherwise = Int -> ContactName -> ContactName
T.take Int
16 ContactName
displayName ContactName -> Char -> ContactName
`T.snoc` Char
'…'

splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr
splitFileDescr :: Int -> ContactName -> NonEmpty FileDescr
splitFileDescr Int
partSize ContactName
rfdText = Int -> ContactName -> NonEmpty FileDescr
splitParts Int
1 ContactName
rfdText
  where
    splitParts :: Int -> ContactName -> NonEmpty FileDescr
splitParts Int
partNo ContactName
remText =
      let (ContactName
part, ContactName
rest) = Int -> ContactName -> (ContactName, ContactName)
T.splitAt Int
partSize ContactName
remText
          complete :: Bool
complete = ContactName -> Bool
T.null ContactName
rest
          fileDescr :: FileDescr
fileDescr = FileDescr {fileDescrText :: ContactName
fileDescrText = ContactName
part, fileDescrPartNo :: Int
fileDescrPartNo = Int
partNo, fileDescrComplete :: Bool
fileDescrComplete = Bool
complete}
       in if Bool
complete
            then FileDescr
fileDescr FileDescr -> [FileDescr] -> NonEmpty FileDescr
forall a. a -> [a] -> NonEmpty a
:| []
            else FileDescr
fileDescr FileDescr -> NonEmpty FileDescr -> NonEmpty FileDescr
forall a. a -> NonEmpty a -> NonEmpty a
<| Int -> ContactName -> NonEmpty FileDescr
splitParts (Int
partNo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ContactName
rest

setGroupLinkData' :: NetworkRequestMode -> User -> GroupInfo -> CM ()
setGroupLinkData' :: NetworkRequestMode
-> User
-> GroupInfo
-> ExceptT ChatError (ReaderT ChatController IO) ()
setGroupLinkData' NetworkRequestMode
nm User
user GroupInfo
gInfo =
  (Connection -> IO (Either StoreError GroupLink))
-> CM (Either StoreError GroupLink)
forall a. (Connection -> IO a) -> CM a
withFastStore' (\Connection
db -> ExceptT StoreError IO GroupLink -> IO (Either StoreError GroupLink)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO GroupLink
 -> IO (Either StoreError GroupLink))
-> ExceptT StoreError IO GroupLink
-> IO (Either StoreError GroupLink)
forall a b. (a -> b) -> a -> b
$ Connection -> User -> GroupInfo -> ExceptT StoreError IO GroupLink
getGroupLink Connection
db User
user GroupInfo
gInfo) CM (Either StoreError GroupLink)
-> (Either StoreError GroupLink
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 gLink :: GroupLink
gLink@GroupLink {Bool
shortLinkDataSet :: Bool
shortLinkDataSet :: GroupLink -> Bool
shortLinkDataSet}
      | Bool
shortLinkDataSet -> ExceptT ChatError (ReaderT ChatController IO) GroupLink
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) GroupLink
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) GroupLink
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ NetworkRequestMode
-> User
-> GroupInfo
-> GroupLink
-> ExceptT ChatError (ReaderT ChatController IO) GroupLink
setGroupLinkData NetworkRequestMode
nm User
user GroupInfo
gInfo GroupLink
gLink
    Either StoreError GroupLink
_ -> () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

setGroupLinkData :: NetworkRequestMode -> User -> GroupInfo -> GroupLink -> CM GroupLink
setGroupLinkData :: NetworkRequestMode
-> User
-> GroupInfo
-> GroupLink
-> ExceptT ChatError (ReaderT ChatController IO) GroupLink
setGroupLinkData NetworkRequestMode
nm User
user gInfo :: GroupInfo
gInfo@GroupInfo {GroupProfile
groupProfile :: GroupInfo -> GroupProfile
groupProfile :: GroupProfile
groupProfile} gLink :: GroupLink
gLink@GroupLink {GroupLinkId
groupLinkId :: GroupLinkId
groupLinkId :: GroupLink -> GroupLinkId
groupLinkId} = do
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  Connection
conn <- (Connection -> ExceptT StoreError IO Connection) -> CM Connection
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withFastStore ((Connection -> ExceptT StoreError IO Connection) -> CM Connection)
-> (Connection -> ExceptT StoreError IO Connection)
-> CM Connection
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> ExceptT StoreError IO Connection
getGroupLinkConnection Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo
  let userData :: UserLinkData
userData = GroupShortLinkData -> UserLinkData
forall a. ToJSON a => a -> UserLinkData
encodeShortLinkData (GroupShortLinkData -> UserLinkData)
-> GroupShortLinkData -> UserLinkData
forall a b. (a -> b) -> a -> b
$ GroupProfile -> GroupShortLinkData
GroupShortLinkData GroupProfile
groupProfile
      userLinkData :: UserConnLinkData 'CMContact
userLinkData = UserContactData -> UserConnLinkData 'CMContact
UserContactLinkData UserContactData {direct :: Bool
direct = Bool
True, owners :: [OwnerAuth]
owners = [], relays :: [ConnShortLink 'CMContact]
relays = [], UserLinkData
userData :: UserLinkData
userData :: UserLinkData
userData}
      crClientData :: ContactName
crClientData = CReqClientData -> ContactName
forall a. ToJSON a => a -> ContactName
encodeJSON (CReqClientData -> ContactName) -> CReqClientData -> ContactName
forall a b. (a -> b) -> a -> b
$ GroupLinkId -> CReqClientData
CRDataGroup GroupLinkId
groupLinkId
  ConnShortLink 'CMContact
sLnk <- ConnShortLink 'CMContact -> CM (ConnShortLink 'CMContact)
forall (m :: ConnectionMode).
ConnShortLink m -> CM (ConnShortLink m)
shortenShortLink' (ConnShortLink 'CMContact -> CM (ConnShortLink 'CMContact))
-> (ConnShortLink 'CMContact -> ConnShortLink 'CMContact)
-> ConnShortLink 'CMContact
-> CM (ConnShortLink 'CMContact)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnShortLink 'CMContact -> ConnShortLink 'CMContact
toShortGroupLink (ConnShortLink 'CMContact -> CM (ConnShortLink 'CMContact))
-> CM (ConnShortLink 'CMContact) -> CM (ConnShortLink 'CMContact)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (AgentClient
 -> ExceptT AgentErrorType IO (ConnShortLink 'CMContact))
-> CM (ConnShortLink 'CMContact)
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent (\AgentClient
a -> AgentClient
-> NetworkRequestMode
-> ByteString
-> SConnectionMode 'CMContact
-> UserConnLinkData 'CMContact
-> Maybe ContactName
-> ExceptT AgentErrorType IO (ConnShortLink 'CMContact)
forall (c :: ConnectionMode).
AgentClient
-> NetworkRequestMode
-> ByteString
-> SConnectionMode c
-> UserConnLinkData c
-> Maybe ContactName
-> AE (ConnShortLink c)
setConnShortLink AgentClient
a NetworkRequestMode
nm (Connection -> ByteString
aConnId Connection
conn) SConnectionMode 'CMContact
SCMContact UserConnLinkData 'CMContact
userLinkData (ContactName -> Maybe ContactName
forall a. a -> Maybe a
Just ContactName
crClientData))
  (Connection -> IO GroupLink)
-> ExceptT ChatError (ReaderT ChatController IO) GroupLink
forall a. (Connection -> IO a) -> CM a
withFastStore' ((Connection -> IO GroupLink)
 -> ExceptT ChatError (ReaderT ChatController IO) GroupLink)
-> (Connection -> IO GroupLink)
-> ExceptT ChatError (ReaderT ChatController IO) GroupLink
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> GroupLink -> ConnShortLink 'CMContact -> IO GroupLink
setGroupLinkShortLink Connection
db GroupLink
gLink ConnShortLink 'CMContact
sLnk

encodeShortLinkData :: J.ToJSON a => a -> UserLinkData
encodeShortLinkData :: forall a. ToJSON a => a -> UserLinkData
encodeShortLinkData a
d =
  let s :: ByteString
s = LazyByteString -> ByteString
LB.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
J.encode a
d
      -- 10kb size limit for compression to be used is based on 13784 limit for link data
      -- and the space reserved for the other fields in ConnLinkData encoding (most of these fields are currently unused).
      s' :: ByteString
s'
        | ByteString -> Int
B.length ByteString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10240 = Char -> ByteString -> ByteString
B.cons Char
'X' (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
Z1.compress Int
forall a. Num a => a
compressionLevel ByteString
s
        | Bool
otherwise = ByteString
s
    in ByteString -> UserLinkData
UserLinkData ByteString
s'

decodeShortLinkData :: J.FromJSON a => ConnLinkData c -> IO (Maybe a)
decodeShortLinkData :: forall a (c :: ConnectionMode).
FromJSON a =>
ConnLinkData c -> IO (Maybe a)
decodeShortLinkData ConnLinkData c
cData
  | ByteString -> Bool
B.null ByteString
s = Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  | ByteString -> Char
B.head ByteString
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'X' = case ByteString -> Decompress
Z1.decompress (ByteString -> Decompress) -> ByteString -> Decompress
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
1 ByteString
s of
      Z1.Error String
e -> Maybe a
forall a. Maybe a
Nothing Maybe a -> IO () -> IO (Maybe a)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ContactName -> IO ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ContactName -> m ()
logError (ContactName
"Error decompressing link data: " ContactName -> ContactName -> ContactName
forall a. Semigroup a => a -> a -> a
<> String -> ContactName
forall a. Show a => a -> ContactName
tshow String
e)
      Decompress
Z1.Skip -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
      Z1.Decompress ByteString
s' -> ByteString -> IO (Maybe a)
forall {a} {f :: * -> *}.
(FromJSON a, MonadIO f) =>
ByteString -> f (Maybe a)
decode ByteString
s'
  | Bool
otherwise = ByteString -> IO (Maybe a)
forall {a} {f :: * -> *}.
(FromJSON a, MonadIO f) =>
ByteString -> f (Maybe a)
decode ByteString
s
  where
    decode :: ByteString -> f (Maybe a)
decode ByteString
s' = case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecodeStrict ByteString
s' of
      Right a
d -> Maybe a -> f (Maybe a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> f (Maybe a)) -> Maybe a -> f (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
d
      Left String
e -> Maybe a
forall a. Maybe a
Nothing Maybe a -> f () -> f (Maybe a)
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ContactName -> f ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ContactName -> m ()
logError (ContactName
"Error decoding link data: " ContactName -> ContactName -> ContactName
forall a. Semigroup a => a -> a -> a
<> String -> ContactName
forall a. Show a => a -> ContactName
tshow String
e)
    s :: ByteString
s = ConnLinkData c -> ByteString
forall (c :: ConnectionMode). ConnLinkData c -> ByteString
linkUserData' ConnLinkData c
cData

shortenShortLink' :: ConnShortLink m -> CM (ConnShortLink m)
shortenShortLink' :: forall (m :: ConnectionMode).
ConnShortLink m -> CM (ConnShortLink m)
shortenShortLink' ConnShortLink m
l = (NonEmpty SMPServer -> ConnShortLink m -> ConnShortLink m
forall (m :: ConnectionMode).
NonEmpty SMPServer -> ConnShortLink m -> ConnShortLink m
`shortenShortLink` ConnShortLink m
l) (NonEmpty SMPServer -> ConnShortLink m)
-> ExceptT
     ChatError (ReaderT ChatController IO) (NonEmpty SMPServer)
-> ExceptT ChatError (ReaderT ChatController IO) (ConnShortLink m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ChatController -> NonEmpty SMPServer)
-> ExceptT
     ChatError (ReaderT ChatController IO) (NonEmpty SMPServer)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChatConfig -> NonEmpty SMPServer
shortLinkPresetServers (ChatConfig -> NonEmpty SMPServer)
-> (ChatController -> ChatConfig)
-> ChatController
-> NonEmpty SMPServer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config)

shortenCreatedLink :: CreatedConnLink m -> CM (CreatedConnLink m)
shortenCreatedLink :: forall (m :: ConnectionMode).
CreatedConnLink m -> CM (CreatedConnLink m)
shortenCreatedLink (CCLink ConnectionRequestUri m
cReq Maybe (ConnShortLink m)
sLnk) = ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnectionRequestUri m
cReq (Maybe (ConnShortLink m) -> CreatedConnLink m)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe (ConnShortLink m))
-> ExceptT
     ChatError (ReaderT ChatController IO) (CreatedConnLink m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConnShortLink m
 -> ExceptT ChatError (ReaderT ChatController IO) (ConnShortLink m))
-> Maybe (ConnShortLink m)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe (ConnShortLink m))
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 ConnShortLink m
-> ExceptT ChatError (ReaderT ChatController IO) (ConnShortLink m)
forall (m :: ConnectionMode).
ConnShortLink m -> CM (ConnShortLink m)
shortenShortLink' Maybe (ConnShortLink m)
sLnk

createdGroupLink :: CreatedLinkContact -> CreatedLinkContact
createdGroupLink :: CreatedLinkContact -> CreatedLinkContact
createdGroupLink (CCLink ConnectionRequestUri 'CMContact
cReq Maybe (ConnShortLink 'CMContact)
shortLink) = ConnectionRequestUri 'CMContact
-> Maybe (ConnShortLink 'CMContact) -> CreatedLinkContact
forall (m :: ConnectionMode).
ConnectionRequestUri m
-> Maybe (ConnShortLink m) -> CreatedConnLink m
CCLink ConnectionRequestUri 'CMContact
cReq (ConnShortLink 'CMContact -> ConnShortLink 'CMContact
toShortGroupLink (ConnShortLink 'CMContact -> ConnShortLink 'CMContact)
-> Maybe (ConnShortLink 'CMContact)
-> Maybe (ConnShortLink 'CMContact)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ConnShortLink 'CMContact)
shortLink)

toShortGroupLink :: ShortLinkContact -> ShortLinkContact
toShortGroupLink :: ConnShortLink 'CMContact -> ConnShortLink 'CMContact
toShortGroupLink (CSLContact ShortLinkScheme
sch ContactConnType
_ SMPServer
srv LinkKey
k) = ShortLinkScheme
-> ContactConnType
-> SMPServer
-> LinkKey
-> ConnShortLink 'CMContact
CSLContact ShortLinkScheme
sch ContactConnType
CCTGroup SMPServer
srv LinkKey
k

deleteGroupLink' :: User -> GroupInfo -> CM ()
deleteGroupLink' :: User
-> GroupInfo -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteGroupLink' User
user GroupInfo
gInfo = do
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  Connection
conn <- (Connection -> ExceptT StoreError IO Connection) -> CM Connection
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO Connection) -> CM Connection)
-> (Connection -> ExceptT StoreError IO Connection)
-> CM Connection
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> ExceptT StoreError IO Connection
getGroupLinkConnection Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo
  User
-> GroupInfo
-> Connection
-> ExceptT ChatError (ReaderT ChatController IO) ()
deleteGroupLink_ User
user GroupInfo
gInfo Connection
conn

deleteGroupLinkIfExists :: User -> GroupInfo -> CM ()
deleteGroupLinkIfExists :: User
-> GroupInfo -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteGroupLinkIfExists User
user GroupInfo
gInfo = do
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  Maybe Connection
conn_ <- Either StoreError Connection -> Maybe Connection
forall a b. Either a b -> Maybe b
eitherToMaybe (Either StoreError Connection -> Maybe Connection)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either StoreError Connection)
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Connection)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> IO (Either StoreError Connection))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Either StoreError Connection)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO Connection
-> IO (Either StoreError Connection)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO Connection
 -> IO (Either StoreError Connection))
-> ExceptT StoreError IO Connection
-> IO (Either StoreError Connection)
forall a b. (a -> b) -> a -> b
$ Connection
-> VersionRangeChat
-> User
-> GroupInfo
-> ExceptT StoreError IO Connection
getGroupLinkConnection Connection
db VersionRangeChat
vr User
user GroupInfo
gInfo)
  (Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
-> Maybe Connection
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (User
-> GroupInfo
-> Connection
-> ExceptT ChatError (ReaderT ChatController IO) ()
deleteGroupLink_ User
user GroupInfo
gInfo) Maybe Connection
conn_

deleteGroupLink_ :: User -> GroupInfo -> Connection -> CM ()
deleteGroupLink_ :: User
-> GroupInfo
-> Connection
-> ExceptT ChatError (ReaderT ChatController IO) ()
deleteGroupLink_ User
user GroupInfo
gInfo Connection
conn = do
  ByteString -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteAgentConnectionAsync (ByteString -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ByteString -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString
aConnId Connection
conn
  (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupInfo -> IO ()
deleteGroupLink Connection
db User
user GroupInfo
gInfo

startProximateTimedItemThread :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM ()
startProximateTimedItemThread :: User
-> (ChatRef, UserId)
-> UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
startProximateTimedItemThread User
user (ChatRef, UserId)
itemRef UTCTime
deleteAt = do
  NominalDiffTime
interval <- (ChatController -> NominalDiffTime)
-> ExceptT ChatError (ReaderT ChatController IO) NominalDiffTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ChatConfig -> NominalDiffTime
cleanupManagerInterval (ChatConfig -> NominalDiffTime)
-> (ChatController -> ChatConfig)
-> ChatController
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatController -> ChatConfig
config)
  UTCTime
ts <- 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
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deleteAt UTCTime
ts NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
interval) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$
    User
-> (ChatRef, UserId)
-> UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
startTimedItemThread User
user (ChatRef, UserId)
itemRef UTCTime
deleteAt

startTimedItemThread :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM ()
startTimedItemThread :: User
-> (ChatRef, UserId)
-> UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
startTimedItemThread User
user (ChatRef, UserId)
itemRef UTCTime
deleteAt = do
  TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId)))
itemThreads <- (ChatController
 -> TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId))))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId))))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController
-> TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId)))
timedItemThreads
  Maybe (TVar (Maybe (Weak ThreadId)))
threadTVar_ <- STM (Maybe (TVar (Maybe (Weak ThreadId))))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (TVar (Maybe (Weak ThreadId))))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe (TVar (Maybe (Weak ThreadId))))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      (Maybe (TVar (Maybe (Weak ThreadId)))))
-> STM (Maybe (TVar (Maybe (Weak ThreadId))))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Maybe (TVar (Maybe (Weak ThreadId))))
forall a b. (a -> b) -> a -> b
$ do
    Bool
exists <- (ChatRef, UserId)
-> TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId)))
-> STM Bool
forall k a. Ord k => k -> TMap k a -> STM Bool
TM.member (ChatRef, UserId)
itemRef TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId)))
itemThreads
    if Bool -> Bool
not Bool
exists
      then do
        TVar (Maybe (Weak ThreadId))
threadTVar <- Maybe (Weak ThreadId) -> STM (TVar (Maybe (Weak ThreadId)))
forall a. a -> STM (TVar a)
newTVar Maybe (Weak ThreadId)
forall a. Maybe a
Nothing
        (ChatRef, UserId)
-> TVar (Maybe (Weak ThreadId))
-> TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId)))
-> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert (ChatRef, UserId)
itemRef TVar (Maybe (Weak ThreadId))
threadTVar TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId)))
itemThreads
        Maybe (TVar (Maybe (Weak ThreadId)))
-> STM (Maybe (TVar (Maybe (Weak ThreadId))))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TVar (Maybe (Weak ThreadId)))
 -> STM (Maybe (TVar (Maybe (Weak ThreadId)))))
-> Maybe (TVar (Maybe (Weak ThreadId)))
-> STM (Maybe (TVar (Maybe (Weak ThreadId))))
forall a b. (a -> b) -> a -> b
$ TVar (Maybe (Weak ThreadId))
-> Maybe (TVar (Maybe (Weak ThreadId)))
forall a. a -> Maybe a
Just TVar (Maybe (Weak ThreadId))
threadTVar
      else Maybe (TVar (Maybe (Weak ThreadId)))
-> STM (Maybe (TVar (Maybe (Weak ThreadId))))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TVar (Maybe (Weak ThreadId)))
forall a. Maybe a
Nothing
  Maybe (TVar (Maybe (Weak ThreadId)))
-> (TVar (Maybe (Weak ThreadId))
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (TVar (Maybe (Weak ThreadId)))
threadTVar_ ((TVar (Maybe (Weak ThreadId))
  -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (TVar (Maybe (Weak ThreadId))
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \TVar (Maybe (Weak ThreadId))
threadTVar -> do
    Weak ThreadId
tId <- ThreadId
-> ExceptT ChatError (ReaderT ChatController IO) (Weak ThreadId)
forall (m :: * -> *). MonadIO m => ThreadId -> m (Weak ThreadId)
mkWeakThreadId (ThreadId
 -> ExceptT ChatError (ReaderT ChatController IO) (Weak ThreadId))
-> ExceptT ChatError (ReaderT ChatController IO) ThreadId
-> ExceptT ChatError (ReaderT ChatController IO) (Weak ThreadId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< User
-> (ChatRef, UserId)
-> UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
deleteTimedItem User
user (ChatRef, UserId)
itemRef UTCTime
deleteAt ExceptT ChatError (ReaderT ChatController IO) ()
-> (Either SomeException ()
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ThreadId
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
`forkFinally` ExceptT ChatError (ReaderT ChatController IO) ()
-> Either SomeException ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. a -> b -> a
const (STM () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT ChatError (ReaderT ChatController IO) ())
-> STM () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ (ChatRef, UserId)
-> TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId))) -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete (ChatRef, UserId)
itemRef TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId)))
itemThreads)
    STM () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT ChatError (ReaderT ChatController IO) ())
-> STM () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe (Weak ThreadId)) -> Maybe (Weak ThreadId) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (Weak ThreadId))
threadTVar (Weak ThreadId -> Maybe (Weak ThreadId)
forall a. a -> Maybe a
Just Weak ThreadId
tId)

deleteTimedItem :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM ()
deleteTimedItem :: User
-> (ChatRef, UserId)
-> UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
deleteTimedItem User
user (ChatRef ChatType
cType UserId
chatId Maybe GroupChatScope
scope, UserId
itemId) UTCTime
deleteAt = do
  UTCTime
ts <- 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
  IO () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ChatError (ReaderT ChatController IO) ())
-> IO () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ UserId -> IO ()
threadDelay' (UserId -> IO ()) -> UserId -> IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UserId
diffToMicroseconds (NominalDiffTime -> UserId) -> NominalDiffTime -> UserId
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deleteAt UTCTime
ts
  ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()
waitChatStartedAndActivated
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  case ChatType
cType of
    ChatType
CTDirect -> do
      (Contact
ct, CChatItem 'CTDirect
ci) <- (Connection
 -> ExceptT StoreError IO (Contact, CChatItem 'CTDirect))
-> CM (Contact, CChatItem 'CTDirect)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection
  -> ExceptT StoreError IO (Contact, CChatItem 'CTDirect))
 -> CM (Contact, CChatItem 'CTDirect))
-> (Connection
    -> ExceptT StoreError IO (Contact, CChatItem 'CTDirect))
-> CM (Contact, CChatItem 'CTDirect)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> (,) (Contact -> CChatItem 'CTDirect -> (Contact, CChatItem 'CTDirect))
-> ExceptT StoreError IO Contact
-> ExceptT
     StoreError
     IO
     (CChatItem 'CTDirect -> (Contact, CChatItem 'CTDirect))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> VersionRangeChat
-> User
-> UserId
-> ExceptT StoreError IO Contact
getContact Connection
db VersionRangeChat
vr User
user UserId
chatId ExceptT
  StoreError
  IO
  (CChatItem 'CTDirect -> (Contact, CChatItem 'CTDirect))
-> ExceptT StoreError IO (CChatItem 'CTDirect)
-> ExceptT StoreError IO (Contact, CChatItem 'CTDirect)
forall a b.
ExceptT StoreError IO (a -> b)
-> ExceptT StoreError IO a -> ExceptT StoreError IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Connection
-> User
-> UserId
-> UserId
-> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItem Connection
db User
user UserId
chatId UserId
itemId
      [ChatItemDeletion]
deletions <- User -> Contact -> [CChatItem 'CTDirect] -> CM [ChatItemDeletion]
deleteDirectCIs User
user Contact
ct [Item [CChatItem 'CTDirect]
CChatItem 'CTDirect
ci]
      ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User -> [ChatItemDeletion] -> Bool -> Bool -> ChatEvent
CEvtChatItemsDeleted User
user [ChatItemDeletion]
deletions Bool
True Bool
True
    ChatType
CTGroup -> do
      (GroupInfo
gInfo, CChatItem 'CTGroup
ci) <- (Connection
 -> ExceptT StoreError IO (GroupInfo, CChatItem 'CTGroup))
-> CM (GroupInfo, CChatItem 'CTGroup)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection
  -> ExceptT StoreError IO (GroupInfo, CChatItem 'CTGroup))
 -> CM (GroupInfo, CChatItem 'CTGroup))
-> (Connection
    -> ExceptT StoreError IO (GroupInfo, CChatItem 'CTGroup))
-> CM (GroupInfo, CChatItem 'CTGroup)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> (,) (GroupInfo
 -> CChatItem 'CTGroup -> (GroupInfo, CChatItem 'CTGroup))
-> ExceptT StoreError IO GroupInfo
-> ExceptT
     StoreError
     IO
     (CChatItem 'CTGroup -> (GroupInfo, CChatItem 'CTGroup))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> VersionRangeChat
-> User
-> UserId
-> ExceptT StoreError IO GroupInfo
getGroupInfo Connection
db VersionRangeChat
vr User
user UserId
chatId ExceptT
  StoreError
  IO
  (CChatItem 'CTGroup -> (GroupInfo, CChatItem 'CTGroup))
-> ExceptT StoreError IO (CChatItem 'CTGroup)
-> ExceptT StoreError IO (GroupInfo, CChatItem 'CTGroup)
forall a b.
ExceptT StoreError IO (a -> b)
-> ExceptT StoreError IO a -> ExceptT StoreError IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Connection
-> User
-> UserId
-> UserId
-> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItem Connection
db User
user UserId
chatId UserId
itemId
      UTCTime
deletedTs <- 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
      Maybe GroupChatScopeInfo
chatScopeInfo <- (GroupChatScope
 -> ExceptT
      ChatError (ReaderT ChatController IO) GroupChatScopeInfo)
-> Maybe GroupChatScope
-> ExceptT
     ChatError (ReaderT ChatController IO) (Maybe GroupChatScopeInfo)
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 (VersionRangeChat
-> User
-> GroupChatScope
-> ExceptT ChatError (ReaderT ChatController IO) GroupChatScopeInfo
getChatScopeInfo VersionRangeChat
vr User
user) Maybe GroupChatScope
scope
      [ChatItemDeletion]
deletions <- User
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> [CChatItem 'CTGroup]
-> Maybe GroupMember
-> UTCTime
-> CM [ChatItemDeletion]
deleteGroupCIs User
user GroupInfo
gInfo Maybe GroupChatScopeInfo
chatScopeInfo [Item [CChatItem 'CTGroup]
CChatItem 'CTGroup
ci] Maybe GroupMember
forall a. Maybe a
Nothing UTCTime
deletedTs
      ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User -> [ChatItemDeletion] -> Bool -> Bool -> ChatEvent
CEvtChatItemsDeleted User
user [ChatItemDeletion]
deletions Bool
True Bool
True
    ChatType
_ -> ChatError -> ExceptT ChatError (ReaderT ChatController IO) ()
eToView (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatError -> ExceptT ChatError (ReaderT ChatController IO) ()
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
"bad deleteTimedItem cType"

startUpdatedTimedItemThread :: User -> ChatRef -> ChatItem c d -> ChatItem c d -> CM ()
startUpdatedTimedItemThread :: forall (c :: ChatType) (d :: MsgDirection).
User
-> ChatRef
-> ChatItem c d
-> ChatItem c d
-> ExceptT ChatError (ReaderT ChatController IO) ()
startUpdatedTimedItemThread User
user ChatRef
chatRef ChatItem c d
ci ChatItem c d
ci' =
  case (ChatItem c d -> Maybe CITimed
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe CITimed
chatItemTimed ChatItem c d
ci 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', ChatItem c d -> Maybe CITimed
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe CITimed
chatItemTimed ChatItem c d
ci' 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') of
    (Maybe UTCTime
Nothing, Just UTCTime
deleteAt') ->
      User
-> (ChatRef, UserId)
-> UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
startProximateTimedItemThread User
user (ChatRef
chatRef, ChatItem c d -> UserId
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> UserId
chatItemId' ChatItem c d
ci') UTCTime
deleteAt'
    (Maybe UTCTime, Maybe UTCTime)
_ -> () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

metaBrokerTs :: MsgMeta -> UTCTime
metaBrokerTs :: MsgMeta -> UTCTime
metaBrokerTs MsgMeta {broker :: MsgMeta -> (ByteString, UTCTime)
broker = (ByteString
_, UTCTime
brokerTs)} = UTCTime
brokerTs

createContactPQSndItem :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection)
createContactPQSndItem :: User
-> Contact
-> Connection
-> PQEncryption
-> CM (Contact, Connection)
createContactPQSndItem User
user Contact
ct conn :: Connection
conn@Connection {Maybe PQEncryption
pqSndEnabled :: Maybe PQEncryption
pqSndEnabled :: Connection -> Maybe PQEncryption
pqSndEnabled} PQEncryption
pqSndEnabled' =
  (CM (Contact, Connection)
 -> (ChatError -> CM (Contact, Connection))
 -> CM (Contact, Connection))
-> (ChatError -> CM (Contact, Connection))
-> CM (Contact, Connection)
-> CM (Contact, Connection)
forall a b c. (a -> b -> c) -> b -> a -> c
flip CM (Contact, Connection)
-> (ChatError -> CM (Contact, Connection))
-> CM (Contact, Connection)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchAllErrors (CM (Contact, Connection) -> ChatError -> CM (Contact, Connection)
forall a b. a -> b -> a
const (CM (Contact, Connection) -> ChatError -> CM (Contact, Connection))
-> CM (Contact, Connection)
-> ChatError
-> CM (Contact, Connection)
forall a b. (a -> b) -> a -> b
$ (Contact, Connection) -> CM (Contact, Connection)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact
ct, Connection
conn)) (CM (Contact, Connection) -> CM (Contact, Connection))
-> CM (Contact, Connection) -> CM (Contact, Connection)
forall a b. (a -> b) -> a -> b
$ case (Maybe PQEncryption
pqSndEnabled, PQEncryption
pqSndEnabled') of
    (Just PQEncryption
b, PQEncryption
b') | PQEncryption
b' PQEncryption -> PQEncryption -> Bool
forall a. Eq a => a -> a -> Bool
/= PQEncryption
b -> CIContent 'MDSnd -> CM (Contact, Connection)
createPQItem (CIContent 'MDSnd -> CM (Contact, Connection))
-> CIContent 'MDSnd -> CM (Contact, Connection)
forall a b. (a -> b) -> a -> b
$ SndConnEvent -> CIContent 'MDSnd
CISndConnEvent (PQEncryption -> SndConnEvent
SCEPqEnabled PQEncryption
pqSndEnabled')
    (Maybe PQEncryption
Nothing, PQEncryption
PQEncOn) -> CIContent 'MDSnd -> CM (Contact, Connection)
createPQItem (CIContent 'MDSnd -> CM (Contact, Connection))
-> CIContent 'MDSnd -> CM (Contact, Connection)
forall a b. (a -> b) -> a -> b
$ E2EInfo -> CIContent 'MDSnd
CISndDirectE2EEInfo (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
pqSndEnabled')
    (Maybe PQEncryption, PQEncryption)
_ -> (Contact, Connection) -> CM (Contact, Connection)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact
ct, Connection
conn)
  where
    createPQItem :: CIContent 'MDSnd -> CM (Contact, Connection)
createPQItem CIContent 'MDSnd
ciContent = do
      let conn' :: Connection
conn' = Connection
conn {pqSndEnabled = Just pqSndEnabled'} :: Connection
          ct' :: Contact
ct' = Contact
ct {activeConn = Just conn'} :: Contact
      Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Contact -> PQEncryption
contactPQEnabled Contact
ct PQEncryption -> PQEncryption -> Bool
forall a. Eq a => a -> a -> Bool
/= Contact -> PQEncryption
contactPQEnabled Contact
ct') (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ do
        User
-> ChatDirection 'CTDirect 'MDSnd
-> CIContent 'MDSnd
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> CIContent d
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectSnd Contact
ct') CIContent 'MDSnd
ciContent Maybe UTCTime
forall a. Maybe a
Nothing
        ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> PQEncryption -> ChatEvent
CEvtContactPQEnabled User
user Contact
ct' PQEncryption
pqSndEnabled'
      (Contact, Connection) -> CM (Contact, Connection)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact
ct', Connection
conn')

updateContactPQRcv :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection)
updateContactPQRcv :: User
-> Contact
-> Connection
-> PQEncryption
-> CM (Contact, Connection)
updateContactPQRcv User
user Contact
ct conn :: Connection
conn@Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId, Maybe PQEncryption
pqRcvEnabled :: Maybe PQEncryption
pqRcvEnabled :: Connection -> Maybe PQEncryption
pqRcvEnabled} PQEncryption
pqRcvEnabled' =
  (CM (Contact, Connection)
 -> (ChatError -> CM (Contact, Connection))
 -> CM (Contact, Connection))
-> (ChatError -> CM (Contact, Connection))
-> CM (Contact, Connection)
-> CM (Contact, Connection)
forall a b c. (a -> b -> c) -> b -> a -> c
flip CM (Contact, Connection)
-> (ChatError -> CM (Contact, Connection))
-> CM (Contact, Connection)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchAllErrors (CM (Contact, Connection) -> ChatError -> CM (Contact, Connection)
forall a b. a -> b -> a
const (CM (Contact, Connection) -> ChatError -> CM (Contact, Connection))
-> CM (Contact, Connection)
-> ChatError
-> CM (Contact, Connection)
forall a b. (a -> b) -> a -> b
$ (Contact, Connection) -> CM (Contact, Connection)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact
ct, Connection
conn)) (CM (Contact, Connection) -> CM (Contact, Connection))
-> CM (Contact, Connection) -> CM (Contact, Connection)
forall a b. (a -> b) -> a -> b
$ case (Maybe PQEncryption
pqRcvEnabled, PQEncryption
pqRcvEnabled') of
    (Just PQEncryption
b, PQEncryption
b') | PQEncryption
b' PQEncryption -> PQEncryption -> Bool
forall a. Eq a => a -> a -> Bool
/= PQEncryption
b -> CIContent 'MDRcv -> CM (Contact, Connection)
updatePQ (CIContent 'MDRcv -> CM (Contact, Connection))
-> CIContent 'MDRcv -> CM (Contact, Connection)
forall a b. (a -> b) -> a -> b
$ RcvConnEvent -> CIContent 'MDRcv
CIRcvConnEvent (PQEncryption -> RcvConnEvent
RCEPqEnabled PQEncryption
pqRcvEnabled')
    (Maybe PQEncryption
Nothing, PQEncryption
PQEncOn) -> CIContent 'MDRcv -> CM (Contact, Connection)
updatePQ (CIContent 'MDRcv -> CM (Contact, Connection))
-> CIContent 'MDRcv -> CM (Contact, Connection)
forall a b. (a -> b) -> a -> b
$ E2EInfo -> CIContent 'MDRcv
CIRcvDirectE2EEInfo (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
pqRcvEnabled')
    (Maybe PQEncryption, PQEncryption)
_ -> (Contact, Connection) -> CM (Contact, Connection)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact
ct, Connection
conn)
  where
    updatePQ :: CIContent 'MDRcv -> CM (Contact, Connection)
updatePQ CIContent 'MDRcv
ciContent = do
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> PQEncryption -> IO ()
updateConnPQRcvEnabled Connection
db UserId
connId PQEncryption
pqRcvEnabled'
      let conn' :: Connection
conn' = Connection
conn {pqRcvEnabled = Just pqRcvEnabled'} :: Connection
          ct' :: Contact
ct' = Contact
ct {activeConn = Just conn'} :: Contact
      Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Contact -> PQEncryption
contactPQEnabled Contact
ct PQEncryption -> PQEncryption -> Bool
forall a. Eq a => a -> a -> Bool
/= Contact -> PQEncryption
contactPQEnabled Contact
ct') (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ do
        User
-> ChatDirection 'CTDirect 'MDRcv
-> CIContent 'MDRcv
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> CIContent d
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
createInternalChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct') CIContent 'MDRcv
ciContent Maybe UTCTime
forall a. Maybe a
Nothing
        ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User -> Contact -> PQEncryption -> ChatEvent
CEvtContactPQEnabled User
user Contact
ct' PQEncryption
pqRcvEnabled'
      (Contact, Connection) -> CM (Contact, Connection)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Contact
ct', Connection
conn')

updatePeerChatVRange :: Connection -> VersionRangeChat -> CM Connection
updatePeerChatVRange :: Connection -> VersionRangeChat -> CM Connection
updatePeerChatVRange conn :: Connection
conn@Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId, connChatVersion :: Connection -> Version ChatVersion
connChatVersion = Version ChatVersion
v, VersionRangeChat
peerChatVRange :: Connection -> VersionRangeChat
peerChatVRange :: VersionRangeChat
peerChatVRange, ConnType
connType :: ConnType
connType :: Connection -> ConnType
connType, PQSupport
pqSupport :: PQSupport
pqSupport :: Connection -> PQSupport
pqSupport, PQEncryption
pqEncryption :: PQEncryption
pqEncryption :: Connection -> PQEncryption
pqEncryption} VersionRangeChat
msgVRange = do
  Version ChatVersion
v' <- ReaderT ChatController IO (Version ChatVersion)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Version ChatVersion)
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 (Version ChatVersion)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Version ChatVersion))
-> ReaderT ChatController IO (Version ChatVersion)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Version ChatVersion)
forall a b. (a -> b) -> a -> b
$ Version ChatVersion
-> VersionRangeChat
-> ReaderT ChatController IO (Version ChatVersion)
upgradedConnVersion Version ChatVersion
v VersionRangeChat
msgVRange
  Connection
conn' <-
    if VersionRangeChat
msgVRange VersionRangeChat -> VersionRangeChat -> Bool
forall a. Eq a => a -> a -> Bool
/= VersionRangeChat
peerChatVRange Bool -> Bool -> Bool
|| Version ChatVersion
v' Version ChatVersion -> Version ChatVersion -> Bool
forall a. Eq a => a -> a -> Bool
/= Version ChatVersion
v
      then do
        (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> UserId -> Version ChatVersion -> VersionRangeChat -> IO ()
setPeerChatVRange Connection
db UserId
connId Version ChatVersion
v' VersionRangeChat
msgVRange
        Connection -> CM Connection
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
conn {connChatVersion = v', peerChatVRange = msgVRange}
      else Connection -> CM Connection
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
conn
  -- TODO v6.0 remove/review: for contacts only version upgrade should trigger enabling PQ support/encryption
  if ConnType
connType ConnType -> ConnType -> Bool
forall a. Eq a => a -> a -> Bool
== ConnType
ConnContact Bool -> Bool -> Bool
&& Version ChatVersion
v' Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
pqEncryptionCompressionVersion Bool -> Bool -> Bool
&& (PQSupport
pqSupport PQSupport -> PQSupport -> Bool
forall a. Eq a => a -> a -> Bool
/= PQSupport
PQSupportOn Bool -> Bool -> Bool
|| PQEncryption
pqEncryption PQEncryption -> PQEncryption -> Bool
forall a. Eq a => a -> a -> Bool
/= PQEncryption
PQEncOn)
    then do
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> PQSupport -> PQEncryption -> IO ()
updateConnSupportPQ Connection
db UserId
connId PQSupport
PQSupportOn PQEncryption
PQEncOn
      Connection -> CM Connection
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
conn' {pqSupport = PQSupportOn, pqEncryption = PQEncOn}
    else Connection -> CM Connection
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
conn'

updateMemberChatVRange :: GroupMember -> Connection -> VersionRangeChat -> CM (GroupMember, Connection)
updateMemberChatVRange :: GroupMember
-> Connection -> VersionRangeChat -> CM (GroupMember, Connection)
updateMemberChatVRange mem :: GroupMember
mem@GroupMember {UserId
groupMemberId :: GroupMember -> UserId
groupMemberId :: UserId
groupMemberId, VersionRangeChat
memberChatVRange :: GroupMember -> VersionRangeChat
memberChatVRange :: VersionRangeChat
memberChatVRange} conn :: Connection
conn@Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId, connChatVersion :: Connection -> Version ChatVersion
connChatVersion = Version ChatVersion
v, VersionRangeChat
peerChatVRange :: Connection -> VersionRangeChat
peerChatVRange :: VersionRangeChat
peerChatVRange} VersionRangeChat
msgVRange = do
  Version ChatVersion
v' <- ReaderT ChatController IO (Version ChatVersion)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Version ChatVersion)
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 (Version ChatVersion)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (Version ChatVersion))
-> ReaderT ChatController IO (Version ChatVersion)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Version ChatVersion)
forall a b. (a -> b) -> a -> b
$ Version ChatVersion
-> VersionRangeChat
-> ReaderT ChatController IO (Version ChatVersion)
upgradedConnVersion Version ChatVersion
v VersionRangeChat
msgVRange
  if VersionRangeChat
msgVRange VersionRangeChat -> VersionRangeChat -> Bool
forall a. Eq a => a -> a -> Bool
/= VersionRangeChat
peerChatVRange Bool -> Bool -> Bool
|| Version ChatVersion
v' Version ChatVersion -> Version ChatVersion -> Bool
forall a. Eq a => a -> a -> Bool
/= Version ChatVersion
v Bool -> Bool -> Bool
|| VersionRangeChat
msgVRange VersionRangeChat -> VersionRangeChat -> Bool
forall a. Eq a => a -> a -> Bool
/= VersionRangeChat
memberChatVRange
    then do
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
        Connection
-> UserId -> Version ChatVersion -> VersionRangeChat -> IO ()
setPeerChatVRange Connection
db UserId
connId Version ChatVersion
v' VersionRangeChat
msgVRange
        Connection -> UserId -> VersionRangeChat -> IO ()
setMemberChatVRange Connection
db UserId
groupMemberId VersionRangeChat
msgVRange
      let conn' :: Connection
conn' = Connection
conn {connChatVersion = v', peerChatVRange = msgVRange}
      (GroupMember, Connection) -> CM (GroupMember, Connection)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMember
mem {memberChatVRange = msgVRange, activeConn = Just conn'}, Connection
conn')
    else (GroupMember, Connection) -> CM (GroupMember, Connection)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMember
mem, Connection
conn)

upgradedConnVersion :: VersionChat -> VersionRangeChat -> CM' VersionChat
upgradedConnVersion :: Version ChatVersion
-> VersionRangeChat
-> ReaderT ChatController IO (Version ChatVersion)
upgradedConnVersion Version ChatVersion
v VersionRangeChat
peerVR = do
  VersionRangeChat
vr <- CM' VersionRangeChat
chatVersionRange'
  -- don't allow reducing agreed connection version
  Version ChatVersion
-> ReaderT ChatController IO (Version ChatVersion)
forall a. a -> ReaderT ChatController IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version ChatVersion
 -> ReaderT ChatController IO (Version ChatVersion))
-> Version ChatVersion
-> ReaderT ChatController IO (Version ChatVersion)
forall a b. (a -> b) -> a -> b
$ Version ChatVersion
-> (Compatible (Version ChatVersion) -> Version ChatVersion)
-> Maybe (Compatible (Version ChatVersion))
-> Version ChatVersion
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Version ChatVersion
v (\(Compatible Version ChatVersion
v') -> Version ChatVersion -> Version ChatVersion -> Version ChatVersion
forall a. Ord a => a -> a -> a
max Version ChatVersion
v Version ChatVersion
v') (Maybe (Compatible (Version ChatVersion)) -> Version ChatVersion)
-> Maybe (Compatible (Version ChatVersion)) -> Version ChatVersion
forall a b. (a -> b) -> a -> b
$ VersionRangeChat
vr VersionRangeChat
-> VersionRangeChat
-> Maybe (Compatible (VersionT ChatVersion VersionRangeChat))
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible (VersionT v a))
`compatibleVersion` VersionRangeChat
peerVR

parseFileDescription :: FilePartyI p => Text -> CM (ValidFileDescription p)
parseFileDescription :: forall (p :: FileParty).
FilePartyI p =>
ContactName -> CM (ValidFileDescription p)
parseFileDescription =
  Either ChatError (ValidFileDescription p)
-> ExceptT
     ChatError (ReaderT ChatController IO) (ValidFileDescription p)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either ChatError (ValidFileDescription p)
 -> ExceptT
      ChatError (ReaderT ChatController IO) (ValidFileDescription p))
-> (ContactName -> Either ChatError (ValidFileDescription p))
-> ContactName
-> ExceptT
     ChatError (ReaderT ChatController IO) (ValidFileDescription p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ChatError)
-> Either String (ValidFileDescription p)
-> Either ChatError (ValidFileDescription p)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ChatErrorType -> ChatError
ChatError (ChatErrorType -> ChatError)
-> (String -> ChatErrorType) -> String -> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ChatErrorType
CEInvalidFileDescription) (Either String (ValidFileDescription p)
 -> Either ChatError (ValidFileDescription p))
-> (ContactName -> Either String (ValidFileDescription p))
-> ContactName
-> Either ChatError (ValidFileDescription p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Either String (ValidFileDescription p)
forall a. StrEncoding a => ByteString -> Either String a
strDecode (ByteString -> Either String (ValidFileDescription p))
-> (ContactName -> ByteString)
-> ContactName
-> Either String (ValidFileDescription p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContactName -> ByteString
encodeUtf8)

sendDirectFileInline :: User -> Contact -> FileTransferMeta -> SharedMsgId -> CM ()
sendDirectFileInline :: User
-> Contact
-> FileTransferMeta
-> SharedMsgId
-> ExceptT ChatError (ReaderT ChatController IO) ()
sendDirectFileInline User
user Contact
ct FileTransferMeta
ft SharedMsgId
sharedMsgId = do
  UserId
msgDeliveryId <- FileTransferMeta
-> SharedMsgId
-> (ChatMsgEvent 'Binary
    -> ExceptT
         ChatError (ReaderT ChatController IO) (SndMessage, UserId))
-> CM UserId
sendFileInline_ FileTransferMeta
ft SharedMsgId
sharedMsgId ((ChatMsgEvent 'Binary
  -> ExceptT
       ChatError (ReaderT ChatController IO) (SndMessage, UserId))
 -> CM UserId)
-> (ChatMsgEvent 'Binary
    -> ExceptT
         ChatError (ReaderT ChatController IO) (SndMessage, UserId))
-> CM UserId
forall a b. (a -> b) -> a -> b
$ User
-> Contact
-> ChatMsgEvent 'Binary
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> ChatMsgEvent e
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
sendDirectContactMessage User
user Contact
ct
  (Connection -> ExceptT StoreError IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> ExceptT StoreError IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> Contact
-> FileTransferMeta
-> UserId
-> ExceptT StoreError IO ()
updateSndDirectFTDelivery Connection
db Contact
ct FileTransferMeta
ft UserId
msgDeliveryId

sendMemberFileInline :: GroupMember -> Connection -> FileTransferMeta -> SharedMsgId -> CM ()
sendMemberFileInline :: GroupMember
-> Connection
-> FileTransferMeta
-> SharedMsgId
-> ExceptT ChatError (ReaderT ChatController IO) ()
sendMemberFileInline m :: GroupMember
m@GroupMember {UserId
groupId :: UserId
groupId :: GroupMember -> UserId
groupId} Connection
conn FileTransferMeta
ft SharedMsgId
sharedMsgId = do
  UserId
msgDeliveryId <- FileTransferMeta
-> SharedMsgId
-> (ChatMsgEvent 'Binary
    -> ExceptT
         ChatError (ReaderT ChatController IO) (SndMessage, UserId))
-> CM UserId
sendFileInline_ FileTransferMeta
ft SharedMsgId
sharedMsgId ((ChatMsgEvent 'Binary
  -> ExceptT
       ChatError (ReaderT ChatController IO) (SndMessage, UserId))
 -> CM UserId)
-> (ChatMsgEvent 'Binary
    -> ExceptT
         ChatError (ReaderT ChatController IO) (SndMessage, UserId))
-> CM UserId
forall a b. (a -> b) -> a -> b
$ \ChatMsgEvent 'Binary
msg -> do
    (SndMessage
sndMsg, UserId
msgDeliveryId, PQEncryption
_) <- Connection
-> ChatMsgEvent 'Binary
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
sendDirectMemberMessage Connection
conn ChatMsgEvent 'Binary
msg UserId
groupId
    (SndMessage, UserId)
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SndMessage
sndMsg, UserId
msgDeliveryId)
  (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> GroupMember -> Connection -> FileTransferMeta -> UserId -> IO ()
updateSndGroupFTDelivery Connection
db GroupMember
m Connection
conn FileTransferMeta
ft UserId
msgDeliveryId

sendFileInline_ :: FileTransferMeta -> SharedMsgId -> (ChatMsgEvent 'Binary -> CM (SndMessage, Int64)) -> CM Int64
sendFileInline_ :: FileTransferMeta
-> SharedMsgId
-> (ChatMsgEvent 'Binary
    -> ExceptT
         ChatError (ReaderT ChatController IO) (SndMessage, UserId))
-> CM UserId
sendFileInline_ FileTransferMeta {String
filePath :: String
filePath :: FileTransferMeta -> String
filePath, Integer
chunkSize :: Integer
chunkSize :: FileTransferMeta -> Integer
chunkSize} SharedMsgId
sharedMsgId ChatMsgEvent 'Binary
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
sendMsg =
  Integer -> ByteString -> CM UserId
sendChunks Integer
1 (ByteString -> CM UserId) -> CM ByteString -> CM UserId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString -> CM ByteString
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> CM ByteString)
-> (String -> IO ByteString) -> String -> CM ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
B.readFile (String -> CM ByteString)
-> ExceptT ChatError (ReaderT ChatController IO) String
-> CM ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 (String -> ReaderT ChatController IO String
toFSFilePath String
filePath)
  where
    sendChunks :: Integer -> ByteString -> CM UserId
sendChunks Integer
chunkNo ByteString
bytes = do
      let (ByteString
chunk, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
chSize ByteString
bytes
      (SndMessage
_, UserId
msgDeliveryId) <- ChatMsgEvent 'Binary
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
sendMsg (ChatMsgEvent 'Binary
 -> ExceptT
      ChatError (ReaderT ChatController IO) (SndMessage, UserId))
-> ChatMsgEvent 'Binary
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
forall a b. (a -> b) -> a -> b
$ SharedMsgId -> FileChunk -> ChatMsgEvent 'Binary
BFileChunk SharedMsgId
sharedMsgId (FileChunk -> ChatMsgEvent 'Binary)
-> FileChunk -> ChatMsgEvent 'Binary
forall a b. (a -> b) -> a -> b
$ Integer -> ByteString -> FileChunk
FileChunk Integer
chunkNo ByteString
chunk
      if ByteString -> Bool
B.null ByteString
rest
        then UserId -> CM UserId
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserId
msgDeliveryId
        else Integer -> ByteString -> CM UserId
sendChunks (Integer
chunkNo Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) ByteString
rest
    chSize :: Int
chSize = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
chunkSize

parseChatMessage :: Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage :: Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage Connection
conn ByteString
s = do
  case ByteString -> [Either String AChatMessage]
parseChatMessages ByteString
s of
    [Item [Either String AChatMessage]
msg] -> Either ChatError (ChatMessage 'Json) -> CM (ChatMessage 'Json)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either ChatError (ChatMessage 'Json) -> CM (ChatMessage 'Json))
-> (Either String (ChatMessage 'Json)
    -> Either ChatError (ChatMessage 'Json))
-> Either String (ChatMessage 'Json)
-> CM (ChatMessage 'Json)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ChatError)
-> Either String (ChatMessage 'Json)
-> Either ChatError (ChatMessage 'Json)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ChatErrorType -> ChatError
ChatError (ChatErrorType -> ChatError)
-> (String -> ChatErrorType) -> String -> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ChatErrorType
errType) (Either String (ChatMessage 'Json) -> CM (ChatMessage 'Json))
-> Either String (ChatMessage 'Json) -> CM (ChatMessage 'Json)
forall a b. (a -> b) -> a -> b
$ (\(ACMsg SMsgEncoding e
_ ChatMessage e
m) -> ChatMessage e -> Either String (ChatMessage 'Json)
forall (t :: MsgEncoding -> *) (e :: MsgEncoding)
       (e' :: MsgEncoding).
(MsgEncodingI e, MsgEncodingI e') =>
t e' -> Either String (t e)
checkEncoding ChatMessage e
m) (AChatMessage -> Either String (ChatMessage 'Json))
-> Either String AChatMessage -> Either String (ChatMessage 'Json)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either String AChatMessage
Item [Either String AChatMessage]
msg
    [Either String AChatMessage]
_ -> ChatErrorType -> CM (ChatMessage 'Json)
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM (ChatMessage 'Json))
-> ChatErrorType -> CM (ChatMessage 'Json)
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEException String
"parseChatMessage: single message is expected"
  where
    errType :: String -> ChatErrorType
errType = Connection
-> Maybe MsgMetaJSON -> ContactName -> String -> ChatErrorType
CEInvalidChatMessage Connection
conn Maybe MsgMetaJSON
forall a. Maybe a
Nothing (ByteString -> ContactName
safeDecodeUtf8 ByteString
s)
{-# INLINE parseChatMessage #-}

getChatScopeInfo :: VersionRangeChat -> User -> GroupChatScope -> CM GroupChatScopeInfo
getChatScopeInfo :: VersionRangeChat
-> User
-> GroupChatScope
-> ExceptT ChatError (ReaderT ChatController IO) GroupChatScopeInfo
getChatScopeInfo VersionRangeChat
vr User
user = \case
  GCSMemberSupport Maybe UserId
Nothing -> GroupChatScopeInfo
-> ExceptT ChatError (ReaderT ChatController IO) GroupChatScopeInfo
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupChatScopeInfo
 -> ExceptT
      ChatError (ReaderT ChatController IO) GroupChatScopeInfo)
-> GroupChatScopeInfo
-> ExceptT ChatError (ReaderT ChatController IO) GroupChatScopeInfo
forall a b. (a -> b) -> a -> b
$ Maybe GroupMember -> GroupChatScopeInfo
GCSIMemberSupport Maybe GroupMember
forall a. Maybe a
Nothing
  GCSMemberSupport (Just UserId
gmId) -> do
    GroupMember
supportMem <- (Connection -> ExceptT StoreError IO GroupMember) -> CM GroupMember
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withFastStore ((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
-> UserId
-> ExceptT StoreError IO GroupMember
getGroupMemberById Connection
db VersionRangeChat
vr User
user UserId
gmId
    GroupChatScopeInfo
-> ExceptT ChatError (ReaderT ChatController IO) GroupChatScopeInfo
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupChatScopeInfo
 -> ExceptT
      ChatError (ReaderT ChatController IO) GroupChatScopeInfo)
-> GroupChatScopeInfo
-> ExceptT ChatError (ReaderT ChatController IO) GroupChatScopeInfo
forall a b. (a -> b) -> a -> b
$ Maybe GroupMember -> GroupChatScopeInfo
GCSIMemberSupport (GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
supportMem)

getGroupRecipients :: VersionRangeChat -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> VersionChat -> CM [GroupMember]
getGroupRecipients :: VersionRangeChat
-> User
-> GroupInfo
-> Maybe GroupChatScopeInfo
-> Version ChatVersion
-> CM [GroupMember]
getGroupRecipients VersionRangeChat
vr User
user gInfo :: GroupInfo
gInfo@GroupInfo {BoolDef
useRelays :: BoolDef
useRelays :: GroupInfo -> BoolDef
useRelays, GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} Maybe GroupChatScopeInfo
scopeInfo Version ChatVersion
modsCompatVersion
  | BoolDef -> Bool
isTrue BoolDef
useRelays Bool -> Bool -> Bool
&& Bool -> Bool
not (GroupMember -> Bool
isMemberRelay GroupMember
membership) = do
      Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupMember -> Bool
memberCurrent GroupMember
membership Bool -> Bool -> Bool
&& GroupMember -> Bool
memberActive GroupMember
membership) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CECommandError String
"not current member"
      (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withFastStore' ((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 = case Maybe GroupChatScopeInfo
scopeInfo of
      Maybe GroupChatScopeInfo
Nothing -> do
        Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupMember -> Bool
memberCurrent GroupMember
membership Bool -> Bool -> Bool
&& GroupMember -> Bool
memberActive GroupMember
membership) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CECommandError String
"not current member"
        [GroupMember]
ms <- (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withFastStore' ((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
        [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
memberCurrent [GroupMember]
ms
      Just (GCSIMemberSupport Maybe GroupMember
Nothing) -> do
        [GroupMember]
modMs <- (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withFastStore' ((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 rcpModMs' :: [GroupMember]
rcpModMs' = (GroupMember -> Bool) -> [GroupMember] -> [GroupMember]
forall a. (a -> Bool) -> [a] -> [a]
filter (\GroupMember
m -> GroupMember -> Bool
compatible GroupMember
m Bool -> Bool -> Bool
&& GroupMember -> Bool
memberCurrent GroupMember
m) [GroupMember]
modMs
        Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([GroupMember] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GroupMember]
rcpModMs') (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CECommandError String
"no admins support this message"
        [GroupMember] -> CM [GroupMember]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [GroupMember]
rcpModMs'
      Just (GCSIMemberSupport (Just GroupMember
supportMem)) -> do
        Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupMember -> Bool
memberCurrent GroupMember
membership Bool -> Bool -> Bool
&& GroupMember -> Bool
memberActive GroupMember
membership) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CECommandError String
"not current member"
        Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GroupMember -> Bool
memberCurrentOrPending GroupMember
supportMem) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CECommandError String
"support member not current or pending"
        if GroupMember -> GroupMemberStatus
memberStatus GroupMember
supportMem GroupMemberStatus -> GroupMemberStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberStatus
GSMemPendingApproval
          then [GroupMember] -> CM [GroupMember]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Item [GroupMember]
GroupMember
supportMem]
          else do
            [GroupMember]
modMs <- (Connection -> IO [GroupMember]) -> CM [GroupMember]
forall a. (Connection -> IO a) -> CM a
withFastStore' ((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 rcpModMs' :: [GroupMember]
rcpModMs' = (GroupMember -> Bool) -> [GroupMember] -> [GroupMember]
forall a. (a -> Bool) -> [a] -> [a]
filter (\GroupMember
m -> GroupMember -> Bool
compatible GroupMember
m Bool -> Bool -> Bool
&& GroupMember -> Bool
memberCurrent GroupMember
m) [GroupMember]
modMs
            [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
$ [Item [GroupMember]
GroupMember
supportMem] [GroupMember] -> [GroupMember] -> [GroupMember]
forall a. Semigroup a => a -> a -> a
<> [GroupMember]
rcpModMs'
  where
    compatible :: GroupMember -> Bool
compatible GroupMember {Maybe Connection
activeConn :: GroupMember -> Maybe Connection
activeConn :: Maybe Connection
activeConn, VersionRangeChat
memberChatVRange :: GroupMember -> VersionRangeChat
memberChatVRange :: VersionRangeChat
memberChatVRange} =
      VersionRangeChat -> Version ChatVersion
forall v. VersionRange v -> Version v
maxVersion (VersionRangeChat
-> (Connection -> VersionRangeChat)
-> Maybe Connection
-> VersionRangeChat
forall b a. b -> (a -> b) -> Maybe a -> b
maybe VersionRangeChat
memberChatVRange Connection -> VersionRangeChat
peerChatVRange Maybe Connection
activeConn) Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
modsCompatVersion

mkLocalGroupChatScope :: GroupInfo -> CM (GroupInfo, Maybe GroupChatScopeInfo)
mkLocalGroupChatScope :: GroupInfo -> CM (GroupInfo, Maybe GroupChatScopeInfo)
mkLocalGroupChatScope gInfo :: GroupInfo
gInfo@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership}
  | GroupMember -> Bool
memberPending GroupMember
membership = do
      (GroupInfo
gInfo', GroupChatScopeInfo
scopeInfo) <- GroupInfo -> CM (GroupInfo, GroupChatScopeInfo)
mkGroupSupportChatInfo GroupInfo
gInfo
      (GroupInfo, Maybe GroupChatScopeInfo)
-> CM (GroupInfo, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo', GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a. a -> Maybe a
Just GroupChatScopeInfo
scopeInfo)
  | Bool
otherwise =
      (GroupInfo, Maybe GroupChatScopeInfo)
-> CM (GroupInfo, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo, Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing)

mkGroupChatScope :: GroupInfo -> GroupMember -> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope :: GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope gInfo :: GroupInfo
gInfo@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} GroupMember
m
  | GroupMember -> Bool
memberPending GroupMember
membership = do
      (GroupInfo
gInfo', GroupChatScopeInfo
scopeInfo) <- GroupInfo -> CM (GroupInfo, GroupChatScopeInfo)
mkGroupSupportChatInfo GroupInfo
gInfo
      (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo', GroupMember
m, GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a. a -> Maybe a
Just GroupChatScopeInfo
scopeInfo)
  | GroupMember -> Bool
memberPending GroupMember
m = do
      (GroupMember
m', GroupChatScopeInfo
scopeInfo) <- GroupMember -> CM (GroupMember, GroupChatScopeInfo)
mkMemberSupportChatInfo GroupMember
m
      (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo, GroupMember
m', GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a. a -> Maybe a
Just GroupChatScopeInfo
scopeInfo)
  | Bool
otherwise =
      (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo, GroupMember
m, Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing)

mkGetMessageChatScope :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> MsgContent -> Maybe MsgScope -> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGetMessageChatScope :: VersionRangeChat
-> User
-> GroupInfo
-> GroupMember
-> MsgContent
-> Maybe MsgScope
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGetMessageChatScope VersionRangeChat
vr User
user gInfo :: GroupInfo
gInfo@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} GroupMember
m MsgContent
mc Maybe MsgScope
msgScope_ =
  GroupInfo
-> GroupMember
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
mkGroupChatScope GroupInfo
gInfo GroupMember
m CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
-> ((GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
    -> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo))
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
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
    groupScope :: (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
groupScope@(GroupInfo
_gInfo', GroupMember
_m', Just GroupChatScopeInfo
_scopeInfo) -> (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
groupScope
    (GroupInfo
_, GroupMember
_, Maybe GroupChatScopeInfo
Nothing)
      | MsgContent -> Bool
isReport MsgContent
mc -> do
          -- TODO [knocking] return patched _m'?
          (GroupMember
_m', GroupChatScopeInfo
scopeInfo) <- GroupMember -> CM (GroupMember, GroupChatScopeInfo)
mkMemberSupportChatInfo GroupMember
m -- only support scope member can send a report (m is sender)
          (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo, GroupMember
m, GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a. a -> Maybe a
Just GroupChatScopeInfo
scopeInfo)
      | Bool
otherwise -> case Maybe MsgScope
msgScope_ of
          Maybe MsgScope
Nothing -> (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo, GroupMember
m, Maybe GroupChatScopeInfo
forall a. Maybe a
Nothing)
          Just (MSMember MemberId
mId)
            | MemberId -> GroupMember -> Bool
sameMemberId MemberId
mId GroupMember
membership -> do
                (GroupInfo
gInfo', GroupChatScopeInfo
scopeInfo) <- GroupInfo -> CM (GroupInfo, GroupChatScopeInfo)
mkGroupSupportChatInfo GroupInfo
gInfo
                (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo', GroupMember
m, GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a. a -> Maybe a
Just GroupChatScopeInfo
scopeInfo)
            | Bool
otherwise -> do
                GroupMember
referredMember <- (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
mId
                -- TODO [knocking] return patched _referredMember'?
                (GroupMember
_referredMember', GroupChatScopeInfo
scopeInfo) <- GroupMember -> CM (GroupMember, GroupChatScopeInfo)
mkMemberSupportChatInfo GroupMember
referredMember
                (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
-> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo, GroupMember
m, GroupChatScopeInfo -> Maybe GroupChatScopeInfo
forall a. a -> Maybe a
Just GroupChatScopeInfo
scopeInfo)

mkGroupSupportChatInfo :: GroupInfo -> CM (GroupInfo, GroupChatScopeInfo)
mkGroupSupportChatInfo :: GroupInfo -> CM (GroupInfo, GroupChatScopeInfo)
mkGroupSupportChatInfo gInfo :: GroupInfo
gInfo@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} =
  case GroupMember -> Maybe GroupSupportChat
supportChat GroupMember
membership of
    Maybe GroupSupportChat
Nothing -> do
      UTCTime
chatTs <- 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
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> UTCTime -> IO ()
setSupportChatTs Connection
db (GroupMember -> UserId
groupMemberId' GroupMember
membership) UTCTime
chatTs
      let gInfo' :: GroupInfo
gInfo' = GroupInfo
gInfo {membership = membership {supportChat = Just $ GroupSupportChat chatTs 0 0 0 Nothing}}
          scopeInfo :: GroupChatScopeInfo
scopeInfo = GCSIMemberSupport {groupMember_ :: Maybe GroupMember
groupMember_ = Maybe GroupMember
forall a. Maybe a
Nothing}
      (GroupInfo, GroupChatScopeInfo)
-> CM (GroupInfo, GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo', GroupChatScopeInfo
scopeInfo)
    Just GroupSupportChat
_supportChat ->
      let scopeInfo :: GroupChatScopeInfo
scopeInfo = GCSIMemberSupport {groupMember_ :: Maybe GroupMember
groupMember_ = Maybe GroupMember
forall a. Maybe a
Nothing}
       in (GroupInfo, GroupChatScopeInfo)
-> CM (GroupInfo, GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo, GroupChatScopeInfo
scopeInfo)

mkMemberSupportChatInfo :: GroupMember -> CM (GroupMember, GroupChatScopeInfo)
mkMemberSupportChatInfo :: GroupMember -> CM (GroupMember, GroupChatScopeInfo)
mkMemberSupportChatInfo m :: GroupMember
m@GroupMember {UserId
groupMemberId :: GroupMember -> UserId
groupMemberId :: UserId
groupMemberId, Maybe GroupSupportChat
supportChat :: GroupMember -> Maybe GroupSupportChat
supportChat :: Maybe GroupSupportChat
supportChat} =
  case Maybe GroupSupportChat
supportChat of
    Maybe GroupSupportChat
Nothing -> do
      UTCTime
chatTs <- 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
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> UTCTime -> IO ()
setSupportChatTs Connection
db UserId
groupMemberId UTCTime
chatTs
      let m' :: GroupMember
m' = GroupMember
m {supportChat = Just $ GroupSupportChat chatTs 0 0 0 Nothing}
          scopeInfo :: GroupChatScopeInfo
scopeInfo = GCSIMemberSupport {groupMember_ :: Maybe GroupMember
groupMember_ = GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
m'}
      (GroupMember, GroupChatScopeInfo)
-> CM (GroupMember, GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMember
m', GroupChatScopeInfo
scopeInfo)
    Just GroupSupportChat
_supportChat ->
      let scopeInfo :: GroupChatScopeInfo
scopeInfo = GCSIMemberSupport {groupMember_ :: Maybe GroupMember
groupMember_ = GroupMember -> Maybe GroupMember
forall a. a -> Maybe a
Just GroupMember
m}
       in (GroupMember, GroupChatScopeInfo)
-> CM (GroupMember, GroupChatScopeInfo)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMember
m, GroupChatScopeInfo
scopeInfo)

appendFileChunk :: RcvFileTransfer -> Integer -> ByteString -> Bool -> CM ()
appendFileChunk :: RcvFileTransfer
-> Integer
-> ByteString
-> Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
appendFileChunk ft :: RcvFileTransfer
ft@RcvFileTransfer {UserId
fileId :: RcvFileTransfer -> UserId
fileId :: UserId
fileId, RcvFileStatus
fileStatus :: RcvFileTransfer -> RcvFileStatus
fileStatus :: RcvFileStatus
fileStatus, Maybe CryptoFileArgs
cryptoArgs :: RcvFileTransfer -> Maybe CryptoFileArgs
cryptoArgs :: Maybe CryptoFileArgs
cryptoArgs, fileInvitation :: RcvFileTransfer -> FileInvitation
fileInvitation = FileInvitation {String
fileName :: FileInvitation -> String
fileName :: String
fileName}} Integer
chunkNo ByteString
chunk Bool
final =
  case RcvFileStatus
fileStatus of
    RFSConnected String
filePath -> String -> ExceptT ChatError (ReaderT ChatController IO) ()
append_ String
filePath
    -- sometimes update of file transfer status to FSConnected
    -- doesn't complete in time before MSG with first file chunk
    RFSAccepted String
filePath -> String -> ExceptT ChatError (ReaderT ChatController IO) ()
append_ String
filePath
    RFSCancelled Maybe String
_ -> () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    RcvFileStatus
_ -> ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEFileInternal String
"receiving file transfer not in progress"
  where
    append_ :: FilePath -> CM ()
    append_ :: String -> ExceptT ChatError (ReaderT ChatController IO) ()
append_ String
filePath = do
      String
fsFilePath <- 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
filePath
      Handle
h <- UserId
-> String
-> (ChatController -> TVar (Map UserId Handle))
-> IOMode
-> CM Handle
getFileHandle UserId
fileId String
fsFilePath ChatController -> TVar (Map UserId Handle)
rcvFiles IOMode
AppendMode
      IO () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
chunk IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h) ExceptT ChatError (ReaderT ChatController IO) ()
-> (SomeException -> ChatError)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *) e a.
MonadUnliftIO m =>
ExceptT e m a -> (SomeException -> e) -> ExceptT e m a
`catchThrow` (String -> ChatError
fileErr (String -> ChatError)
-> (SomeException -> String) -> SomeException -> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show)
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> RcvFileTransfer -> Integer -> IO ()
updatedRcvFileChunkStored Connection
db RcvFileTransfer
ft Integer
chunkNo
      Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
final (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ do
        ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ UserId
-> (ChatController -> TVar (Map UserId Handle))
-> ReaderT ChatController IO ()
closeFileHandle UserId
fileId ChatController -> TVar (Map UserId Handle)
rcvFiles
        Maybe CryptoFileArgs
-> (CryptoFileArgs
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe CryptoFileArgs
cryptoArgs ((CryptoFileArgs
  -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (CryptoFileArgs
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \CryptoFileArgs
cfArgs -> do
          String
tmpFile <- 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
getChatTempDirectory ExceptT ChatError (ReaderT ChatController IO) String
-> (String -> ExceptT ChatError (ReaderT ChatController IO) String)
-> ExceptT ChatError (ReaderT ChatController IO) String
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
>>= IO String -> ExceptT ChatError (ReaderT ChatController IO) String
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT ChatError (ReaderT ChatController IO) String)
-> (String -> IO String)
-> String
-> ExceptT ChatError (ReaderT ChatController IO) String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> IO String
`uniqueCombine` String
fileName)
          ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT
     ChatError (ReaderT ChatController IO) (Either ChatError ())
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors ((String -> ChatError)
-> ExceptT String IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> ExceptT e IO a -> ExceptT e' m a
liftError String -> ChatError
encryptErr (ExceptT String IO ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT String IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> CryptoFileArgs -> ExceptT String IO ()
encryptFile String
fsFilePath String
tmpFile CryptoFileArgs
cfArgs) ExceptT ChatError (ReaderT ChatController IO) (Either ChatError ())
-> (Either ChatError ()
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 () -> do
              String -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
fsFilePath ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
_ -> () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              String
-> String -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
renameFile String
tmpFile String
fsFilePath
            Left ChatError
e -> do
              ChatError -> ExceptT ChatError (ReaderT ChatController IO) ()
eToView ChatError
e
              String -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
tmpFile ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
_ -> () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' (Connection -> UserId -> IO ()
`removeFileCryptoArgs` UserId
fileId)
      where
        encryptErr :: String -> ChatError
encryptErr String
e = String -> ChatError
fileErr (String -> ChatError) -> String -> ChatError
forall a b. (a -> b) -> a -> b
$ String
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", received file not encrypted"
        fileErr :: String -> ChatError
fileErr = ChatErrorType -> ChatError
ChatError (ChatErrorType -> ChatError)
-> (String -> ChatErrorType) -> String -> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ChatErrorType
CEFileWrite String
filePath

getFileHandle :: Int64 -> FilePath -> (ChatController -> TVar (Map Int64 Handle)) -> IOMode -> CM Handle
getFileHandle :: UserId
-> String
-> (ChatController -> TVar (Map UserId Handle))
-> IOMode
-> CM Handle
getFileHandle UserId
fileId String
filePath ChatController -> TVar (Map UserId Handle)
files IOMode
ioMode = do
  TVar (Map UserId Handle)
fs <- (ChatController -> TVar (Map UserId Handle))
-> ExceptT
     ChatError (ReaderT ChatController IO) (TVar (Map UserId Handle))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Map UserId Handle)
files
  Maybe Handle
h_ <- UserId -> Map UserId Handle -> Maybe Handle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup UserId
fileId (Map UserId Handle -> Maybe Handle)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Map UserId Handle)
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map UserId Handle)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Map UserId Handle)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map UserId Handle)
fs
  CM Handle -> (Handle -> CM Handle) -> Maybe Handle -> CM Handle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TVar (Map UserId Handle) -> CM Handle
newHandle TVar (Map UserId Handle)
fs) Handle -> CM Handle
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Handle
h_
  where
    newHandle :: TVar (Map UserId Handle) -> CM Handle
newHandle TVar (Map UserId Handle)
fs = do
      Handle
h <- String -> IOMode -> CM Handle
forall (m :: * -> *). MonadIO m => String -> IOMode -> m Handle
openFile String
filePath IOMode
ioMode CM Handle -> (SomeException -> ChatError) -> CM Handle
forall (m :: * -> *) e a.
MonadUnliftIO m =>
ExceptT e m a -> (SomeException -> e) -> ExceptT e m a
`catchThrow` (ChatErrorType -> ChatError
ChatError (ChatErrorType -> ChatError)
-> (SomeException -> ChatErrorType) -> SomeException -> ChatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ChatErrorType
CEFileInternal (String -> ChatErrorType)
-> (SomeException -> String) -> SomeException -> ChatErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show)
      STM () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ((Map UserId Handle -> Map UserId Handle) -> STM ())
-> (Map UserId Handle -> Map UserId Handle)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map UserId Handle)
-> (Map UserId Handle -> Map UserId Handle) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map UserId Handle)
fs ((Map UserId Handle -> Map UserId Handle)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Map UserId Handle -> Map UserId Handle)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ UserId -> Handle -> Map UserId Handle -> Map UserId Handle
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert UserId
fileId Handle
h
      Handle -> CM Handle
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h

isFileActive :: Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> CM Bool
isFileActive :: UserId -> (ChatController -> TVar (Map UserId Handle)) -> CM Bool
isFileActive UserId
fileId ChatController -> TVar (Map UserId Handle)
files = do
  TVar (Map UserId Handle)
fs <- (ChatController -> TVar (Map UserId Handle))
-> ExceptT
     ChatError (ReaderT ChatController IO) (TVar (Map UserId Handle))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Map UserId Handle)
files
  Maybe Handle -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Handle -> Bool)
-> (Map UserId Handle -> Maybe Handle) -> Map UserId Handle -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserId -> Map UserId Handle -> Maybe Handle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup UserId
fileId (Map UserId Handle -> Bool)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Map UserId Handle)
-> CM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map UserId Handle)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Map UserId Handle)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map UserId Handle)
fs

cancelRcvFileTransfer :: User -> RcvFileTransfer -> CM ()
cancelRcvFileTransfer :: User
-> RcvFileTransfer
-> ExceptT ChatError (ReaderT ChatController IO) ()
cancelRcvFileTransfer User
user ft :: RcvFileTransfer
ft@RcvFileTransfer {UserId
fileId :: RcvFileTransfer -> UserId
fileId :: UserId
fileId, Maybe XFTPRcvFile
xftpRcvFile :: RcvFileTransfer -> Maybe XFTPRcvFile
xftpRcvFile :: Maybe XFTPRcvFile
xftpRcvFile} =
  ExceptT ChatError (ReaderT ChatController IO) ()
cancel' ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 -> ExceptT ChatError (ReaderT ChatController IO) ()
eToView ChatError
e
  where
    cancel' :: ExceptT ChatError (ReaderT ChatController IO) ()
cancel' = do
      ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ UserId
-> (ChatController -> TVar (Map UserId Handle))
-> ReaderT ChatController IO ()
closeFileHandle UserId
fileId ChatController -> TVar (Map UserId Handle)
rcvFiles
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
        Connection -> User -> UserId -> CIFileStatus 'MDRcv -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> UserId -> CIFileStatus d -> IO ()
updateFileCancelled Connection
db User
user UserId
fileId CIFileStatus 'MDRcv
CIFSRcvCancelled
        Connection -> UserId -> FileStatus -> IO ()
updateRcvFileStatus Connection
db UserId
fileId FileStatus
FSCancelled
        Connection -> RcvFileTransfer -> IO ()
deleteRcvFileChunks Connection
db RcvFileTransfer
ft
      case Maybe XFTPRcvFile
xftpRcvFile of
        Just XFTPRcvFile {agentRcvFileId :: XFTPRcvFile -> Maybe AgentRcvFileId
agentRcvFileId = Just (AgentRcvFileId ByteString
aFileId), Bool
agentRcvFileDeleted :: Bool
agentRcvFileDeleted :: XFTPRcvFile -> Bool
agentRcvFileDeleted} ->
          Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
agentRcvFileDeleted (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ByteString
-> UserId -> ExceptT ChatError (ReaderT ChatController IO) ()
agentXFTPDeleteRcvFile ByteString
aFileId UserId
fileId
        Maybe XFTPRcvFile
_ -> () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

cancelSndFile :: User -> FileTransferMeta -> [SndFileTransfer] -> Bool -> CM ()
cancelSndFile :: User
-> FileTransferMeta
-> [SndFileTransfer]
-> Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
cancelSndFile User
user FileTransferMeta {UserId
fileId :: FileTransferMeta -> UserId
fileId :: UserId
fileId, Maybe XFTPSndFile
xftpSndFile :: FileTransferMeta -> Maybe XFTPSndFile
xftpSndFile :: Maybe XFTPSndFile
xftpSndFile} [SndFileTransfer]
fts Bool
sendCancel = do
  (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> Connection -> User -> UserId -> CIFileStatus 'MDSnd -> IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
Connection -> User -> UserId -> CIFileStatus d -> IO ()
updateFileCancelled Connection
db User
user UserId
fileId CIFileStatus 'MDSnd
CIFSSndCancelled)
    ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> ExceptT ChatError (ReaderT ChatController IO) ()
eToView
  case Maybe XFTPSndFile
xftpSndFile of
    Maybe XFTPSndFile
Nothing ->
      [SndFileTransfer]
-> (SndFileTransfer
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SndFileTransfer]
fts (\SndFileTransfer
ft -> User
-> SndFileTransfer
-> Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
cancelSndFileTransfer User
user SndFileTransfer
ft Bool
sendCancel)
    Just XFTPSndFile
xsf -> do
      [SndFileTransfer]
-> (SndFileTransfer
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SndFileTransfer]
fts (\SndFileTransfer
ft -> User
-> SndFileTransfer
-> Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
cancelSndFileTransfer User
user SndFileTransfer
ft Bool
False)
      ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 (User -> XFTPSndFile -> UserId -> ReaderT ChatController IO ()
agentXFTPDeleteSndFileRemote User
user XFTPSndFile
xsf UserId
fileId) ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> ExceptT ChatError (ReaderT ChatController IO) ()
eToView

cancelSndFileTransfer :: User -> SndFileTransfer -> Bool -> CM ()
cancelSndFileTransfer :: User
-> SndFileTransfer
-> Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
cancelSndFileTransfer user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId} ft :: SndFileTransfer
ft@SndFileTransfer {UserId
fileId :: UserId
fileId :: SndFileTransfer -> UserId
fileId, UserId
connId :: UserId
connId :: SndFileTransfer -> UserId
connId, FileStatus
fileStatus :: SndFileTransfer -> FileStatus
fileStatus :: FileStatus
fileStatus, Maybe InlineFileMode
fileInline :: Maybe InlineFileMode
fileInline :: SndFileTransfer -> Maybe InlineFileMode
fileInline} Bool
sendCancel =
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FileStatus
fileStatus FileStatus -> FileStatus -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus
FSCancelled Bool -> Bool -> Bool
|| FileStatus
fileStatus FileStatus -> FileStatus -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus
FSComplete) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$
    ExceptT ChatError (ReaderT ChatController IO) ()
cancel' ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 -> ExceptT ChatError (ReaderT ChatController IO) ()
eToView ChatError
e
  where
    cancel' :: ExceptT ChatError (ReaderT ChatController IO) ()
cancel' = do
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> SndFileTransfer -> FileStatus -> IO ()
updateSndFileStatus Connection
db SndFileTransfer
ft FileStatus
FSCancelled
      Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sendCancel (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ case Maybe InlineFileMode
fileInline of
        Just InlineFileMode
_ -> do
          VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
          (SharedMsgId
sharedMsgId, Connection
conn) <- (Connection -> ExceptT StoreError IO (SharedMsgId, Connection))
-> CM (SharedMsgId, Connection)
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO (SharedMsgId, Connection))
 -> CM (SharedMsgId, Connection))
-> (Connection -> ExceptT StoreError IO (SharedMsgId, Connection))
-> CM (SharedMsgId, Connection)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> (,) (SharedMsgId -> Connection -> (SharedMsgId, Connection))
-> ExceptT StoreError IO SharedMsgId
-> ExceptT StoreError IO (Connection -> (SharedMsgId, Connection))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> UserId -> UserId -> ExceptT StoreError IO SharedMsgId
getSharedMsgIdByFileId Connection
db UserId
userId UserId
fileId ExceptT StoreError IO (Connection -> (SharedMsgId, Connection))
-> ExceptT StoreError IO Connection
-> ExceptT StoreError IO (SharedMsgId, Connection)
forall a b.
ExceptT StoreError IO (a -> b)
-> ExceptT StoreError IO a -> ExceptT StoreError IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Connection
-> VersionRangeChat
-> User
-> UserId
-> ExceptT StoreError IO Connection
getConnectionById Connection
db VersionRangeChat
vr User
user UserId
connId
          ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, UserId, PQEncryption)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Binary
-> ConnOrGroupId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> ConnOrGroupId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
sendDirectMessage_ Connection
conn (SharedMsgId -> FileChunk -> ChatMsgEvent 'Binary
BFileChunk SharedMsgId
sharedMsgId FileChunk
FileChunkCancel) (UserId -> ConnOrGroupId
ConnectionId UserId
connId)
        Maybe InlineFileMode
_ -> ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEException String
"cancelSndFileTransfer: cancelling file via a separate connection is deprecated"

closeFileHandle :: Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> CM' ()
closeFileHandle :: UserId
-> (ChatController -> TVar (Map UserId Handle))
-> ReaderT ChatController IO ()
closeFileHandle UserId
fileId ChatController -> TVar (Map UserId Handle)
files = do
  TVar (Map UserId Handle)
fs <- (ChatController -> TVar (Map UserId Handle))
-> ReaderT ChatController IO (TVar (Map UserId Handle))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Map UserId Handle)
files
  Maybe Handle
h_ <- STM (Maybe Handle) -> ReaderT ChatController IO (Maybe Handle)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe Handle) -> ReaderT ChatController IO (Maybe Handle))
-> ((Map UserId Handle -> (Maybe Handle, Map UserId Handle))
    -> STM (Maybe Handle))
-> (Map UserId Handle -> (Maybe Handle, Map UserId Handle))
-> ReaderT ChatController IO (Maybe Handle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map UserId Handle)
-> (Map UserId Handle -> (Maybe Handle, Map UserId Handle))
-> STM (Maybe Handle)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar (Map UserId Handle)
fs ((Map UserId Handle -> (Maybe Handle, Map UserId Handle))
 -> ReaderT ChatController IO (Maybe Handle))
-> (Map UserId Handle -> (Maybe Handle, Map UserId Handle))
-> ReaderT ChatController IO (Maybe Handle)
forall a b. (a -> b) -> a -> b
$ \Map UserId Handle
m -> (UserId -> Map UserId Handle -> Maybe Handle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup UserId
fileId Map UserId Handle
m, UserId -> Map UserId Handle -> Map UserId Handle
forall k a. Ord k => k -> Map k a -> Map k a
M.delete UserId
fileId Map UserId Handle
m)
  IO () -> ReaderT ChatController IO ()
forall a. IO a -> ReaderT ChatController IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT ChatController IO ())
-> IO () -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ (Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Maybe Handle
h_ 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 ()

deleteMembersConnections :: User -> [GroupMember] -> CM ()
deleteMembersConnections :: User
-> [GroupMember]
-> ExceptT ChatError (ReaderT ChatController IO) ()
deleteMembersConnections User
user [GroupMember]
members = User
-> [GroupMember]
-> Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
deleteMembersConnections' User
user [GroupMember]
members Bool
False

deleteMembersConnections' :: User -> [GroupMember] -> Bool -> CM ()
deleteMembersConnections' :: User
-> [GroupMember]
-> Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
deleteMembersConnections' User
user [GroupMember]
members Bool
waitDelivery = do
  let memberConns :: [Connection]
memberConns = (GroupMember -> Maybe Connection) -> [GroupMember] -> [Connection]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\GroupMember {Maybe Connection
activeConn :: GroupMember -> Maybe Connection
activeConn :: Maybe Connection
activeConn} -> Maybe Connection
activeConn) [GroupMember]
members
  [ByteString]
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteAgentConnectionsAsync' ((Connection -> ByteString) -> [Connection] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Connection -> ByteString
aConnId [Connection]
memberConns) Bool
waitDelivery
  ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ((Connection -> [IO ()]) -> ReaderT ChatController IO ())
-> (Connection -> [IO ()])
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ChatController IO [Either ChatError ()]
-> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO [Either ChatError ()]
 -> ReaderT ChatController IO ())
-> ((Connection -> [IO ()])
    -> ReaderT ChatController IO [Either ChatError ()])
-> (Connection -> [IO ()])
-> ReaderT ChatController IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> [IO ()])
-> ReaderT ChatController IO [Either ChatError ()]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' ((Connection -> [IO ()])
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> [IO ()])
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> (Connection -> IO ()) -> [Connection] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (\Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId} -> Connection -> User -> UserId -> IO ()
deleteConnectionRecord Connection
db User
user UserId
connId) [Connection]
memberConns

deleteMemberConnection :: GroupMember -> CM ()
deleteMemberConnection :: GroupMember -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteMemberConnection GroupMember
mem = GroupMember
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteMemberConnection' GroupMember
mem Bool
False

deleteMemberConnection' :: GroupMember -> Bool -> CM ()
deleteMemberConnection' :: GroupMember
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteMemberConnection' GroupMember {Maybe Connection
activeConn :: GroupMember -> Maybe Connection
activeConn :: Maybe Connection
activeConn} Bool
waitDelivery = do
  Maybe Connection
-> (Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Connection
activeConn ((Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
    ByteString
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteAgentConnectionAsync' (Connection -> ByteString
aConnId Connection
conn) Bool
waitDelivery
    (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> Connection -> ConnStatus -> IO ()
updateConnectionStatus Connection
db Connection
conn ConnStatus
ConnDeleted

deleteOrUpdateMemberRecord :: User -> GroupInfo -> GroupMember -> CM GroupInfo
deleteOrUpdateMemberRecord :: User -> GroupInfo -> GroupMember -> CM GroupInfo
deleteOrUpdateMemberRecord User
user GroupInfo
gInfo GroupMember
m =
  (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 -> GroupMember -> IO GroupInfo
deleteOrUpdateMemberRecordIO Connection
db User
user GroupInfo
gInfo GroupMember
m

deleteOrUpdateMemberRecordIO :: DB.Connection -> User -> GroupInfo -> GroupMember -> IO GroupInfo
deleteOrUpdateMemberRecordIO :: Connection -> User -> GroupInfo -> GroupMember -> IO GroupInfo
deleteOrUpdateMemberRecordIO Connection
db user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId} GroupInfo
gInfo GroupMember
m = do
  (GroupInfo
gInfo', GroupMember
m') <- Connection
-> User -> GroupInfo -> GroupMember -> IO (GroupInfo, GroupMember)
deleteSupportChatIfExists Connection
db User
user GroupInfo
gInfo GroupMember
m
  Connection -> User -> GroupMember -> IO (Maybe UserId)
checkGroupMemberHasItems Connection
db User
user GroupMember
m' IO (Maybe UserId) -> (Maybe UserId -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just UserId
_ -> Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO ()
updateGroupMemberStatus Connection
db UserId
userId GroupMember
m' GroupMemberStatus
GSMemRemoved
    Maybe UserId
Nothing -> Connection -> User -> GroupMember -> IO ()
deleteGroupMember Connection
db User
user GroupMember
m'
  GroupInfo -> IO GroupInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupInfo
gInfo'

updateMemberRecordDeleted :: User -> GroupInfo -> GroupMember -> GroupMemberStatus -> CM GroupInfo
updateMemberRecordDeleted :: User
-> GroupInfo -> GroupMember -> GroupMemberStatus -> CM GroupInfo
updateMemberRecordDeleted user :: User
user@User {UserId
userId :: User -> UserId
userId :: UserId
userId} GroupInfo
gInfo GroupMember
m GroupMemberStatus
newStatus =
  (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 -> do
    (GroupInfo
gInfo', GroupMember
m') <- Connection
-> User -> GroupInfo -> GroupMember -> IO (GroupInfo, GroupMember)
deleteSupportChatIfExists Connection
db User
user GroupInfo
gInfo GroupMember
m
    Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO ()
updateGroupMemberStatus Connection
db UserId
userId GroupMember
m' GroupMemberStatus
newStatus
    GroupInfo -> IO GroupInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupInfo
gInfo'

deleteSupportChatIfExists :: DB.Connection -> User -> GroupInfo -> GroupMember -> IO (GroupInfo, GroupMember)
deleteSupportChatIfExists :: Connection
-> User -> GroupInfo -> GroupMember -> IO (GroupInfo, GroupMember)
deleteSupportChatIfExists Connection
db User
user GroupInfo
gInfo GroupMember
m = do
  GroupInfo
gInfo' <-
    if GroupMember -> Bool
gmRequiresAttention GroupMember
m
      then Connection -> User -> GroupInfo -> IO GroupInfo
decreaseGroupMembersRequireAttention Connection
db User
user GroupInfo
gInfo
      else GroupInfo -> IO GroupInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupInfo
gInfo
  GroupMember
m' <-
    if Maybe GroupSupportChat -> Bool
forall a. Maybe a -> Bool
isJust (GroupMember -> Maybe GroupSupportChat
supportChat GroupMember
m)
      then Connection -> GroupMember -> IO GroupMember
deleteGroupMemberSupportChat Connection
db GroupMember
m
      else GroupMember -> IO GroupMember
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GroupMember
m
  (GroupInfo, GroupMember) -> IO (GroupInfo, GroupMember)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupInfo
gInfo', GroupMember
m')

sendDirectContactMessages :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage]
sendDirectContactMessages :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> NonEmpty (ChatMsgEvent e)
-> CM [Either ChatError SndMessage]
sendDirectContactMessages User
user Contact
ct NonEmpty (ChatMsgEvent e)
events = do
  Connection {connChatVersion :: Connection -> Version ChatVersion
connChatVersion = Version ChatVersion
v} <- Either ChatError Connection -> CM Connection
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either ChatError Connection -> CM Connection)
-> Either ChatError Connection -> CM Connection
forall a b. (a -> b) -> a -> b
$ Contact -> Either ChatError Connection
contactSendConn_ Contact
ct
  if Version ChatVersion
v Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
batchSend2Version
    then User
-> Contact
-> NonEmpty (ChatMsgEvent e)
-> CM [Either ChatError SndMessage]
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> NonEmpty (ChatMsgEvent e)
-> CM [Either ChatError SndMessage]
sendDirectContactMessages' User
user Contact
ct NonEmpty (ChatMsgEvent e)
events
    else [ChatMsgEvent e]
-> (ChatMsgEvent e
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (Either ChatError SndMessage))
-> CM [Either ChatError SndMessage]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (NonEmpty (ChatMsgEvent e) -> [ChatMsgEvent e]
forall a. NonEmpty a -> [a]
L.toList NonEmpty (ChatMsgEvent e)
events) ((ChatMsgEvent e
  -> ExceptT
       ChatError
       (ReaderT ChatController IO)
       (Either ChatError SndMessage))
 -> CM [Either ChatError SndMessage])
-> (ChatMsgEvent e
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (Either ChatError SndMessage))
-> CM [Either ChatError SndMessage]
forall a b. (a -> b) -> a -> b
$ \ChatMsgEvent e
evt ->
      (SndMessage -> Either ChatError SndMessage
forall a b. b -> Either a b
Right (SndMessage -> Either ChatError SndMessage)
-> ((SndMessage, UserId) -> SndMessage)
-> (SndMessage, UserId)
-> Either ChatError SndMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SndMessage, UserId) -> SndMessage
forall a b. (a, b) -> a
fst ((SndMessage, UserId) -> Either ChatError SndMessage)
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
-> ExceptT
     ChatError (ReaderT ChatController IO) (Either ChatError SndMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> User
-> Contact
-> ChatMsgEvent e
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> ChatMsgEvent e
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
sendDirectContactMessage User
user Contact
ct ChatMsgEvent e
evt) ExceptT
  ChatError (ReaderT ChatController IO) (Either ChatError SndMessage)
-> (ChatError
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         (Either ChatError SndMessage))
-> ExceptT
     ChatError (ReaderT ChatController IO) (Either ChatError SndMessage)
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
e -> Either ChatError SndMessage
-> ExceptT
     ChatError (ReaderT ChatController IO) (Either ChatError SndMessage)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatError -> Either ChatError SndMessage
forall a b. a -> Either a b
Left ChatError
e)

sendDirectContactMessages' :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage]
sendDirectContactMessages' :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> NonEmpty (ChatMsgEvent e)
-> CM [Either ChatError SndMessage]
sendDirectContactMessages' User
user Contact
ct NonEmpty (ChatMsgEvent e)
events = do
  conn :: Connection
conn@Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId} <- Either ChatError Connection -> CM Connection
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either ChatError Connection -> CM Connection)
-> Either ChatError Connection -> CM Connection
forall a b. (a -> b) -> a -> b
$ Contact -> Either ChatError Connection
contactSendConn_ Contact
ct
  let idsEvts :: NonEmpty (ConnOrGroupId, ChatMsgEvent e)
idsEvts = (ChatMsgEvent e -> (ConnOrGroupId, ChatMsgEvent e))
-> NonEmpty (ChatMsgEvent e)
-> NonEmpty (ConnOrGroupId, ChatMsgEvent e)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (UserId -> ConnOrGroupId
ConnectionId UserId
connId,) NonEmpty (ChatMsgEvent e)
events
      msgFlags :: MsgFlags
msgFlags = MsgFlags {notification :: Bool
notification = (ChatMsgEvent e -> Bool) -> NonEmpty (ChatMsgEvent e) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CMEventTag e -> Bool
forall (e :: MsgEncoding). CMEventTag e -> Bool
hasNotification (CMEventTag e -> Bool)
-> (ChatMsgEvent e -> CMEventTag e) -> ChatMsgEvent e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatMsgEvent e -> CMEventTag e
forall (e :: MsgEncoding). ChatMsgEvent e -> CMEventTag e
toCMEventTag) NonEmpty (ChatMsgEvent e)
events}
  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 e)
-> 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 e)
idsEvts
  ([Either ChatError SndMessage]
sndMsgs', Maybe PQEncryption
pqEnc_) <- User
-> Connection
-> MsgFlags
-> NonEmpty (Either ChatError SndMessage)
-> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessagesB User
user Connection
conn MsgFlags
msgFlags NonEmpty (Either ChatError SndMessage)
sndMsgs_
  Maybe PQEncryption
-> (PQEncryption
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PQEncryption
pqEnc_ ((PQEncryption -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (PQEncryption
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \PQEncryption
pqEnc' -> CM (Contact, Connection)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM (Contact, Connection)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> CM (Contact, Connection)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User
-> Contact
-> Connection
-> PQEncryption
-> CM (Contact, Connection)
createContactPQSndItem User
user Contact
ct Connection
conn PQEncryption
pqEnc'
  [Either ChatError SndMessage] -> CM [Either ChatError SndMessage]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Either ChatError SndMessage]
sndMsgs'

sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64)
sendDirectContactMessage :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Contact
-> ChatMsgEvent e
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
sendDirectContactMessage User
user Contact
ct ChatMsgEvent e
chatMsgEvent = do
  conn :: Connection
conn@Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId} <- Either ChatError Connection -> CM Connection
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either ChatError Connection -> CM Connection)
-> Either ChatError Connection -> CM Connection
forall a b. (a -> b) -> a -> b
$ Contact -> Either ChatError Connection
contactSendConn_ Contact
ct
  (SndMessage, UserId, PQEncryption)
r <- Connection
-> ChatMsgEvent e
-> ConnOrGroupId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> ConnOrGroupId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
sendDirectMessage_ Connection
conn ChatMsgEvent e
chatMsgEvent (UserId -> ConnOrGroupId
ConnectionId UserId
connId)
  let (SndMessage
sndMessage, UserId
msgDeliveryId, PQEncryption
pqEnc') = (SndMessage, UserId, PQEncryption)
r
  CM (Contact, Connection)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM (Contact, Connection)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> CM (Contact, Connection)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User
-> Contact
-> Connection
-> PQEncryption
-> CM (Contact, Connection)
createContactPQSndItem User
user Contact
ct Connection
conn PQEncryption
pqEnc'
  (SndMessage, UserId)
-> ExceptT
     ChatError (ReaderT ChatController IO) (SndMessage, UserId)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SndMessage
sndMessage, UserId
msgDeliveryId)

contactSendConn_ :: Contact -> Either ChatError Connection
contactSendConn_ :: Contact -> Either ChatError Connection
contactSendConn_ ct :: Contact
ct@Contact {Maybe Connection
activeConn :: Maybe Connection
activeConn :: Contact -> Maybe Connection
activeConn} = case Maybe Connection
activeConn of
  Maybe Connection
Nothing -> ChatErrorType -> Either ChatError Connection
forall {b}. ChatErrorType -> Either ChatError b
err (ChatErrorType -> Either ChatError Connection)
-> ChatErrorType -> Either ChatError Connection
forall a b. (a -> b) -> a -> b
$ Contact -> ChatErrorType
CEContactNotReady Contact
ct
  Just Connection
conn
    | Bool -> Bool
not (Connection -> Bool
connReady Connection
conn) -> ChatErrorType -> Either ChatError Connection
forall {b}. ChatErrorType -> Either ChatError b
err (ChatErrorType -> Either ChatError Connection)
-> ChatErrorType -> Either ChatError Connection
forall a b. (a -> b) -> a -> b
$ Contact -> ChatErrorType
CEContactNotReady Contact
ct
    | Bool -> Bool
not (Contact -> Bool
contactActive Contact
ct) -> ChatErrorType -> Either ChatError Connection
forall {b}. ChatErrorType -> Either ChatError b
err (ChatErrorType -> Either ChatError Connection)
-> ChatErrorType -> Either ChatError Connection
forall a b. (a -> b) -> a -> b
$ Contact -> ChatErrorType
CEContactNotActive Contact
ct
    | Connection -> Bool
connDisabled Connection
conn -> ChatErrorType -> Either ChatError Connection
forall {b}. ChatErrorType -> Either ChatError b
err (ChatErrorType -> Either ChatError Connection)
-> ChatErrorType -> Either ChatError Connection
forall a b. (a -> b) -> a -> b
$ Contact -> ChatErrorType
CEContactDisabled Contact
ct
    | Bool
otherwise -> Connection -> Either ChatError Connection
forall a b. b -> Either a b
Right Connection
conn
  where
    err :: ChatErrorType -> Either ChatError b
err = ChatError -> Either ChatError b
forall a b. a -> Either a b
Left (ChatError -> Either ChatError b)
-> (ChatErrorType -> ChatError)
-> ChatErrorType
-> Either ChatError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatErrorType -> ChatError
ChatError

-- unlike sendGroupMemberMessage, this function will not store message as pending
-- TODO v5.8 we could remove pending messages once all clients support forwarding
sendDirectMemberMessage :: MsgEncodingI e => Connection -> ChatMsgEvent e -> GroupId -> CM (SndMessage, Int64, PQEncryption)
sendDirectMemberMessage :: forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
sendDirectMemberMessage Connection
conn ChatMsgEvent e
chatMsgEvent UserId
groupId = Connection
-> ChatMsgEvent e
-> ConnOrGroupId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> ConnOrGroupId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
sendDirectMessage_ Connection
conn ChatMsgEvent e
chatMsgEvent (UserId -> ConnOrGroupId
GroupId UserId
groupId)

sendDirectMessage_ :: MsgEncodingI e => Connection -> ChatMsgEvent e -> ConnOrGroupId -> CM (SndMessage, Int64, PQEncryption)
sendDirectMessage_ :: forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> ConnOrGroupId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
sendDirectMessage_ Connection
conn ChatMsgEvent e
chatMsgEvent ConnOrGroupId
connOrGroupId = do
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Connection -> Bool
connDisabled Connection
conn) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (Connection -> ChatErrorType
CEConnectionDisabled Connection
conn)
  msg :: SndMessage
msg@SndMessage {UserId
msgId :: UserId
msgId :: SndMessage -> UserId
msgId, ByteString
msgBody :: ByteString
msgBody :: SndMessage -> ByteString
msgBody} <- ChatMsgEvent e
-> ConnOrGroupId
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall (e :: MsgEncoding).
MsgEncodingI e =>
ChatMsgEvent e
-> ConnOrGroupId
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
createSndMessage ChatMsgEvent e
chatMsgEvent ConnOrGroupId
connOrGroupId
  -- TODO move compressed body to SndMessage and compress in createSndMessage
  (UserId
msgDeliveryId, PQEncryption
pqEnc') <- Connection
-> CMEventTag e
-> ByteString
-> UserId
-> CM (UserId, PQEncryption)
forall (e :: MsgEncoding).
Connection
-> CMEventTag e
-> ByteString
-> UserId
-> CM (UserId, PQEncryption)
deliverMessage Connection
conn (ChatMsgEvent e -> CMEventTag e
forall (e :: MsgEncoding). ChatMsgEvent e -> CMEventTag e
toCMEventTag ChatMsgEvent e
chatMsgEvent) ByteString
msgBody UserId
msgId
  (SndMessage, UserId, PQEncryption)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SndMessage
msg, UserId
msgDeliveryId, PQEncryption
pqEnc')

createSndMessage :: MsgEncodingI e => ChatMsgEvent e -> ConnOrGroupId -> CM SndMessage
createSndMessage :: forall (e :: MsgEncoding).
MsgEncodingI e =>
ChatMsgEvent e
-> ConnOrGroupId
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
createSndMessage ChatMsgEvent e
chatMsgEvent ConnOrGroupId
connOrGroupId =
  Either ChatError SndMessage
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either ChatError SndMessage
 -> ExceptT ChatError (ReaderT ChatController IO) SndMessage)
-> (Identity (Either ChatError SndMessage)
    -> Either ChatError SndMessage)
-> Identity (Either ChatError SndMessage)
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Either ChatError SndMessage)
-> Either ChatError SndMessage
forall a. Identity a -> a
runIdentity (Identity (Either ChatError SndMessage)
 -> ExceptT ChatError (ReaderT ChatController IO) SndMessage)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Identity (Either ChatError SndMessage))
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT ChatController IO (Identity (Either ChatError SndMessage))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (Identity (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 (Identity (ConnOrGroupId, ChatMsgEvent e)
-> ReaderT
     ChatController IO (Identity (Either ChatError SndMessage))
forall (e :: MsgEncoding) (t :: * -> *).
(MsgEncodingI e, Traversable t) =>
t (ConnOrGroupId, ChatMsgEvent e)
-> CM' (t (Either ChatError SndMessage))
createSndMessages (Identity (ConnOrGroupId, ChatMsgEvent e)
 -> ReaderT
      ChatController IO (Identity (Either ChatError SndMessage)))
-> Identity (ConnOrGroupId, ChatMsgEvent e)
-> ReaderT
     ChatController IO (Identity (Either ChatError SndMessage))
forall a b. (a -> b) -> a -> b
$ (ConnOrGroupId, ChatMsgEvent e)
-> Identity (ConnOrGroupId, ChatMsgEvent e)
forall a. a -> Identity a
Identity (ConnOrGroupId
connOrGroupId, ChatMsgEvent e
chatMsgEvent))

createSndMessages :: forall e t. (MsgEncodingI e, Traversable t) => t (ConnOrGroupId, ChatMsgEvent e) -> CM' (t (Either ChatError SndMessage))
createSndMessages :: forall (e :: MsgEncoding) (t :: * -> *).
(MsgEncodingI e, Traversable t) =>
t (ConnOrGroupId, ChatMsgEvent e)
-> CM' (t (Either ChatError SndMessage))
createSndMessages t (ConnOrGroupId, ChatMsgEvent e)
idsEvents = do
  TVar ChaChaDRG
g <- (ChatController -> TVar ChaChaDRG)
-> ReaderT ChatController IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar ChaChaDRG
random
  VersionRangeChat
vr <- CM' VersionRangeChat
chatVersionRange'
  (Connection -> t (IO (Either ChatError SndMessage)))
-> CM' (t (Either ChatError SndMessage))
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO (Either ChatError a)))
-> CM' (t (Either ChatError a))
withStoreBatch ((Connection -> t (IO (Either ChatError SndMessage)))
 -> CM' (t (Either ChatError SndMessage)))
-> (Connection -> t (IO (Either ChatError SndMessage)))
-> CM' (t (Either ChatError SndMessage))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ((ConnOrGroupId, ChatMsgEvent e)
 -> IO (Either ChatError SndMessage))
-> t (ConnOrGroupId, ChatMsgEvent e)
-> t (IO (Either ChatError SndMessage))
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Connection
-> TVar ChaChaDRG
-> VersionRangeChat
-> (ConnOrGroupId, ChatMsgEvent e)
-> IO (Either ChatError SndMessage)
createMsg Connection
db TVar ChaChaDRG
g VersionRangeChat
vr) t (ConnOrGroupId, ChatMsgEvent e)
idsEvents
  where
    createMsg :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> (ConnOrGroupId, ChatMsgEvent e) -> IO (Either ChatError SndMessage)
    createMsg :: Connection
-> TVar ChaChaDRG
-> VersionRangeChat
-> (ConnOrGroupId, ChatMsgEvent e)
-> IO (Either ChatError SndMessage)
createMsg Connection
db TVar ChaChaDRG
g VersionRangeChat
vr (ConnOrGroupId
connOrGroupId, ChatMsgEvent e
evnt) = ExceptT ChatError IO SndMessage -> IO (Either ChatError SndMessage)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ChatError IO SndMessage
 -> IO (Either ChatError SndMessage))
-> ExceptT ChatError IO SndMessage
-> IO (Either ChatError SndMessage)
forall a b. (a -> b) -> a -> b
$ do
      (StoreError -> ChatError)
-> ExceptT StoreError IO SndMessage
-> ExceptT ChatError IO SndMessage
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT StoreError -> ChatError
ChatErrorStore (ExceptT StoreError IO SndMessage
 -> ExceptT ChatError IO SndMessage)
-> ExceptT StoreError IO SndMessage
-> ExceptT ChatError IO SndMessage
forall a b. (a -> b) -> a -> b
$ Connection
-> TVar ChaChaDRG
-> ConnOrGroupId
-> ChatMsgEvent e
-> (SharedMsgId -> EncodedChatMessage)
-> ExceptT StoreError IO SndMessage
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> TVar ChaChaDRG
-> ConnOrGroupId
-> ChatMsgEvent e
-> (SharedMsgId -> EncodedChatMessage)
-> ExceptT StoreError IO SndMessage
createNewSndMessage Connection
db TVar ChaChaDRG
g ConnOrGroupId
connOrGroupId ChatMsgEvent e
evnt SharedMsgId -> EncodedChatMessage
encodeMessage
      where
        encodeMessage :: SharedMsgId -> EncodedChatMessage
encodeMessage SharedMsgId
sharedMsgId =
          Int -> ChatMessage e -> EncodedChatMessage
forall (e :: MsgEncoding).
MsgEncodingI e =>
Int -> ChatMessage e -> EncodedChatMessage
encodeChatMessage Int
maxEncodedMsgLength ChatMessage {chatVRange :: VersionRangeChat
chatVRange = VersionRangeChat
vr, msgId :: Maybe SharedMsgId
msgId = SharedMsgId -> Maybe SharedMsgId
forall a. a -> Maybe a
Just SharedMsgId
sharedMsgId, chatMsgEvent :: ChatMsgEvent e
chatMsgEvent = ChatMsgEvent e
evnt}

sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> Connection -> NonEmpty (ChatMsgEvent e) -> GroupId -> CM ()
sendGroupMemberMessages :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Connection
-> NonEmpty (ChatMsgEvent e)
-> UserId
-> ExceptT ChatError (ReaderT ChatController IO) ()
sendGroupMemberMessages User
user Connection
conn NonEmpty (ChatMsgEvent e)
events UserId
groupId = do
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Connection -> Bool
connDisabled Connection
conn) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (Connection -> ChatErrorType
CEConnectionDisabled Connection
conn)
  let idsEvts :: NonEmpty (ConnOrGroupId, ChatMsgEvent e)
idsEvts = (ChatMsgEvent e -> (ConnOrGroupId, ChatMsgEvent e))
-> NonEmpty (ChatMsgEvent e)
-> NonEmpty (ConnOrGroupId, ChatMsgEvent e)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (UserId -> ConnOrGroupId
GroupId UserId
groupId,) NonEmpty (ChatMsgEvent e)
events
  ([ChatError]
errs, [SndMessage]
msgs) <- ReaderT ChatController IO ([ChatError], [SndMessage])
-> ExceptT
     ChatError (ReaderT ChatController IO) ([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 ([ChatError], [SndMessage])
 -> ExceptT
      ChatError (ReaderT ChatController IO) ([ChatError], [SndMessage]))
-> ReaderT ChatController IO ([ChatError], [SndMessage])
-> ExceptT
     ChatError (ReaderT ChatController IO) ([ChatError], [SndMessage])
forall a b. (a -> b) -> a -> b
$ [Either ChatError SndMessage] -> ([ChatError], [SndMessage])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ChatError SndMessage] -> ([ChatError], [SndMessage]))
-> (NonEmpty (Either ChatError SndMessage)
    -> [Either ChatError SndMessage])
-> NonEmpty (Either ChatError SndMessage)
-> ([ChatError], [SndMessage])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Either ChatError SndMessage)
-> [Either ChatError SndMessage]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty (Either ChatError SndMessage)
 -> ([ChatError], [SndMessage]))
-> ReaderT
     ChatController IO (NonEmpty (Either ChatError SndMessage))
-> ReaderT ChatController IO ([ChatError], [SndMessage])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ConnOrGroupId, ChatMsgEvent e)
-> 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 e)
idsEvts
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ [ChatError] -> ChatEvent
CEvtChatErrors [ChatError]
errs
  Maybe (NonEmpty SndMessage)
-> (NonEmpty SndMessage
    -> CM ([Either ChatError SndMessage], Maybe PQEncryption))
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([SndMessage] -> Maybe (NonEmpty SndMessage)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [SndMessage]
msgs) ((NonEmpty SndMessage
  -> CM ([Either ChatError SndMessage], Maybe PQEncryption))
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (NonEmpty SndMessage
    -> CM ([Either ChatError SndMessage], Maybe PQEncryption))
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty SndMessage
msgs' ->
    User
-> Connection
-> MsgFlags
-> NonEmpty SndMessage
-> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessages User
user Connection
conn MsgFlags {notification :: Bool
notification = Bool
True} NonEmpty SndMessage
msgs'

batchSendConnMessages :: User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessages :: User
-> Connection
-> MsgFlags
-> NonEmpty SndMessage
-> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessages User
user Connection
conn MsgFlags
msgFlags NonEmpty SndMessage
msgs =
  User
-> Connection
-> MsgFlags
-> NonEmpty (Either ChatError SndMessage)
-> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessagesB User
user Connection
conn MsgFlags
msgFlags (NonEmpty (Either ChatError SndMessage)
 -> CM ([Either ChatError SndMessage], Maybe PQEncryption))
-> NonEmpty (Either ChatError SndMessage)
-> CM ([Either ChatError SndMessage], Maybe PQEncryption)
forall a b. (a -> b) -> a -> b
$ (SndMessage -> Either ChatError SndMessage)
-> NonEmpty SndMessage -> NonEmpty (Either ChatError SndMessage)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map SndMessage -> Either ChatError SndMessage
forall a b. b -> Either a b
Right NonEmpty SndMessage
msgs

batchSendConnMessagesB :: User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessagesB :: User
-> Connection
-> MsgFlags
-> NonEmpty (Either ChatError SndMessage)
-> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessagesB User
_user Connection
conn MsgFlags
msgFlags NonEmpty (Either ChatError SndMessage)
msgs_ = do
  let batched_ :: [Either ChatError MsgBatch]
batched_ = NonEmpty (Either ChatError SndMessage)
-> [Either ChatError MsgBatch]
batchSndMessagesJSON NonEmpty (Either ChatError SndMessage)
msgs_
  case [Either ChatError MsgBatch]
-> Maybe (NonEmpty (Either ChatError MsgBatch))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [Either ChatError MsgBatch]
batched_ of
    Just NonEmpty (Either ChatError MsgBatch)
batched' -> do
      let msgReqs :: NonEmpty (Either ChatError ChatMsgReq)
msgReqs = (Either ChatError MsgBatch -> Either ChatError ChatMsgReq)
-> NonEmpty (Either ChatError MsgBatch)
-> NonEmpty (Either ChatError ChatMsgReq)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map ((MsgBatch -> ChatMsgReq)
-> Either ChatError MsgBatch -> 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 MsgBatch -> ChatMsgReq
msgBatchReq_) NonEmpty (Either ChatError MsgBatch)
batched'
      NonEmpty (Either ChatError ([UserId], PQEncryption))
delivered <- NonEmpty (Either ChatError ChatMsgReq)
-> CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
deliverMessagesB NonEmpty (Either ChatError ChatMsgReq)
msgReqs
      let msgs' :: [Either ChatError SndMessage]
msgs' = NonEmpty [Either ChatError SndMessage]
-> [Either ChatError SndMessage]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (NonEmpty [Either ChatError SndMessage]
 -> [Either ChatError SndMessage])
-> NonEmpty [Either ChatError SndMessage]
-> [Either ChatError SndMessage]
forall a b. (a -> b) -> a -> b
$ (Either ChatError MsgBatch
 -> Either ChatError ([UserId], PQEncryption)
 -> [Either ChatError SndMessage])
-> NonEmpty (Either ChatError MsgBatch)
-> NonEmpty (Either ChatError ([UserId], PQEncryption))
-> NonEmpty [Either ChatError SndMessage]
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
L.zipWith Either ChatError MsgBatch
-> Either ChatError ([UserId], PQEncryption)
-> [Either ChatError SndMessage]
flattenMsgs NonEmpty (Either ChatError MsgBatch)
batched' NonEmpty (Either ChatError ([UserId], PQEncryption))
delivered
          pqEnc :: Maybe PQEncryption
pqEnc = NonEmpty (Either ChatError ([UserId], PQEncryption))
-> Maybe PQEncryption
findLastPQEnc NonEmpty (Either ChatError ([UserId], PQEncryption))
delivered
      Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Either ChatError SndMessage] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either ChatError SndMessage]
msgs' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= NonEmpty (Either ChatError SndMessage) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (Either ChatError SndMessage)
msgs_) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ContactName -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ContactName -> m ()
logError ContactName
"batchSendConnMessagesB: msgs_ and msgs' length mismatch"
      ([Either ChatError SndMessage], Maybe PQEncryption)
-> CM ([Either ChatError SndMessage], Maybe PQEncryption)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either ChatError SndMessage]
msgs', Maybe PQEncryption
pqEnc)
    Maybe (NonEmpty (Either ChatError MsgBatch))
Nothing -> ([Either ChatError SndMessage], Maybe PQEncryption)
-> CM ([Either ChatError SndMessage], Maybe PQEncryption)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe PQEncryption
forall a. Maybe a
Nothing)
  where
    msgBatchReq_ :: MsgBatch -> ChatMsgReq
    msgBatchReq_ :: MsgBatch -> ChatMsgReq
msgBatchReq_ (MsgBatch ByteString
batchBody [SndMessage]
sndMsgs) =
      (Connection
conn, MsgFlags
msgFlags, (ByteString -> ValueOrRef ByteString
forall a. a -> ValueOrRef a
vrValue ByteString
batchBody, (SndMessage -> UserId) -> [SndMessage] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
map (\SndMessage {UserId
msgId :: SndMessage -> UserId
msgId :: UserId
msgId} -> UserId
msgId) [SndMessage]
sndMsgs))
    flattenMsgs :: Either ChatError MsgBatch -> Either ChatError ([Int64], PQEncryption) -> [Either ChatError SndMessage]
    flattenMsgs :: Either ChatError MsgBatch
-> Either ChatError ([UserId], PQEncryption)
-> [Either ChatError SndMessage]
flattenMsgs (Right (MsgBatch ByteString
_ [SndMessage]
sndMsgs)) (Right ([UserId], PQEncryption)
_) = (SndMessage -> Either ChatError SndMessage)
-> [SndMessage] -> [Either ChatError SndMessage]
forall a b. (a -> b) -> [a] -> [b]
map SndMessage -> Either ChatError SndMessage
forall a b. b -> Either a b
Right [SndMessage]
sndMsgs
    flattenMsgs (Right (MsgBatch ByteString
_ [SndMessage]
sndMsgs)) (Left ChatError
ce) = Int -> Either ChatError SndMessage -> [Either ChatError SndMessage]
forall a. Int -> a -> [a]
replicate ([SndMessage] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SndMessage]
sndMsgs) (ChatError -> Either ChatError SndMessage
forall a b. a -> Either a b
Left ChatError
ce)
    flattenMsgs (Left ChatError
ce) Either ChatError ([UserId], PQEncryption)
_ = [ChatError -> Either ChatError SndMessage
forall a b. a -> Either a b
Left ChatError
ce] -- restore original ChatError
    findLastPQEnc :: NonEmpty (Either ChatError ([Int64], PQEncryption)) -> Maybe PQEncryption
    findLastPQEnc :: NonEmpty (Either ChatError ([UserId], PQEncryption))
-> Maybe PQEncryption
findLastPQEnc = (Either ChatError ([UserId], PQEncryption)
 -> Maybe PQEncryption -> Maybe PQEncryption)
-> Maybe PQEncryption
-> NonEmpty (Either ChatError ([UserId], PQEncryption))
-> Maybe PQEncryption
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (\Either ChatError ([UserId], PQEncryption)
x Maybe PQEncryption
acc -> case Either ChatError ([UserId], PQEncryption)
x of Right ([UserId]
_, PQEncryption
pqEnc) -> PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just PQEncryption
pqEnc; Left ChatError
_ -> Maybe PQEncryption
acc) Maybe PQEncryption
forall a. Maybe a
Nothing

batchSndMessagesJSON :: NonEmpty (Either ChatError SndMessage) -> [Either ChatError MsgBatch]
batchSndMessagesJSON :: NonEmpty (Either ChatError SndMessage)
-> [Either ChatError MsgBatch]
batchSndMessagesJSON = Int -> [Either ChatError SndMessage] -> [Either ChatError MsgBatch]
batchMessages Int
maxEncodedMsgLength ([Either ChatError SndMessage] -> [Either ChatError MsgBatch])
-> (NonEmpty (Either ChatError SndMessage)
    -> [Either ChatError SndMessage])
-> NonEmpty (Either ChatError SndMessage)
-> [Either ChatError MsgBatch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Either ChatError SndMessage)
-> [Either ChatError SndMessage]
forall a. NonEmpty a -> [a]
L.toList

encodeConnInfo :: MsgEncodingI e => ChatMsgEvent e -> CM ByteString
encodeConnInfo :: forall (e :: MsgEncoding).
MsgEncodingI e =>
ChatMsgEvent e -> CM ByteString
encodeConnInfo ChatMsgEvent e
chatMsgEvent = do
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  PQSupport -> Version ChatVersion -> ChatMsgEvent e -> CM ByteString
forall (e :: MsgEncoding).
MsgEncodingI e =>
PQSupport -> Version ChatVersion -> ChatMsgEvent e -> CM ByteString
encodeConnInfoPQ PQSupport
PQSupportOff (VersionRangeChat -> Version ChatVersion
forall v. VersionRange v -> Version v
maxVersion VersionRangeChat
vr) ChatMsgEvent e
chatMsgEvent

encodeConnInfoPQ :: MsgEncodingI e => PQSupport -> VersionChat -> ChatMsgEvent e -> CM ByteString
encodeConnInfoPQ :: forall (e :: MsgEncoding).
MsgEncodingI e =>
PQSupport -> Version ChatVersion -> ChatMsgEvent e -> CM ByteString
encodeConnInfoPQ PQSupport
pqSup Version ChatVersion
v ChatMsgEvent e
chatMsgEvent = do
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  let info :: ChatMessage e
info = ChatMessage {chatVRange :: VersionRangeChat
chatVRange = VersionRangeChat
vr, msgId :: Maybe SharedMsgId
msgId = Maybe SharedMsgId
forall a. Maybe a
Nothing, ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent}
  case Int -> ChatMessage e -> EncodedChatMessage
forall (e :: MsgEncoding).
MsgEncodingI e =>
Int -> ChatMessage e -> EncodedChatMessage
encodeChatMessage Int
maxEncodedInfoLength ChatMessage e
info of
    ECMEncoded ByteString
connInfo -> case PQSupport
pqSup of
      PQSupport
PQSupportOn | Version ChatVersion
v Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
pqEncryptionCompressionVersion Bool -> Bool -> Bool
&& ByteString -> Int
B.length ByteString
connInfo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxCompressedInfoLength -> do
        let connInfo' :: ByteString
connInfo' = ByteString -> ByteString
compressedBatchMsgBody_ ByteString
connInfo
        Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
connInfo' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxCompressedInfoLength) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEException String
"large compressed info"
        ByteString -> CM ByteString
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
connInfo'
      PQSupport
_ -> ByteString -> CM ByteString
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
connInfo
    EncodedChatMessage
ECMLarge -> ChatErrorType -> CM ByteString
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM ByteString) -> ChatErrorType -> CM ByteString
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEException String
"large info"

deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption)
deliverMessage :: forall (e :: MsgEncoding).
Connection
-> CMEventTag e
-> ByteString
-> UserId
-> CM (UserId, PQEncryption)
deliverMessage Connection
conn CMEventTag e
cmEventTag ByteString
msgBody UserId
msgId = do
  let msgFlags :: MsgFlags
msgFlags = MsgFlags {notification :: Bool
notification = CMEventTag e -> Bool
forall (e :: MsgEncoding). CMEventTag e -> Bool
hasNotification CMEventTag e
cmEventTag}
  Connection
-> MsgFlags -> ByteString -> UserId -> CM (UserId, PQEncryption)
deliverMessage' Connection
conn MsgFlags
msgFlags ByteString
msgBody UserId
msgId

deliverMessage' :: Connection -> MsgFlags -> MsgBody -> MessageId -> CM (Int64, PQEncryption)
deliverMessage' :: Connection
-> MsgFlags -> ByteString -> UserId -> CM (UserId, PQEncryption)
deliverMessage' Connection
conn MsgFlags
msgFlags ByteString
msgBody UserId
msgId =
  NonEmpty ChatMsgReq
-> CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
deliverMessages ((Connection
conn, MsgFlags
msgFlags, (ByteString -> ValueOrRef ByteString
forall a. a -> ValueOrRef a
vrValue ByteString
msgBody, [UserId
Item [UserId]
msgId])) ChatMsgReq -> [ChatMsgReq] -> NonEmpty ChatMsgReq
forall a. a -> [a] -> NonEmpty a
:| []) CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
-> (NonEmpty (Either ChatError ([UserId], PQEncryption))
    -> CM (UserId, PQEncryption))
-> CM (UserId, PQEncryption)
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
    Either ChatError ([UserId], PQEncryption)
r :| [] -> case Either ChatError ([UserId], PQEncryption)
r of
      Right ([Item [UserId]
deliveryId], PQEncryption
pqEnc) -> (UserId, PQEncryption) -> CM (UserId, PQEncryption)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserId
Item [UserId]
deliveryId, PQEncryption
pqEnc)
      Right ([UserId]
deliveryIds, PQEncryption
_) -> ChatErrorType -> CM (UserId, PQEncryption)
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM (UserId, PQEncryption))
-> ChatErrorType -> CM (UserId, PQEncryption)
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError (String -> ChatErrorType) -> String -> ChatErrorType
forall a b. (a -> b) -> a -> b
$ String
"deliverMessage: expected 1 delivery id, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([UserId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UserId]
deliveryIds)
      Left ChatError
e -> ChatError -> CM (UserId, PQEncryption)
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
e
    NonEmpty (Either ChatError ([UserId], PQEncryption))
rs -> ChatErrorType -> CM (UserId, PQEncryption)
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM (UserId, PQEncryption))
-> ChatErrorType -> CM (UserId, PQEncryption)
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError (String -> ChatErrorType) -> String -> ChatErrorType
forall a b. (a -> b) -> a -> b
$ String
"deliverMessage: expected 1 result, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (NonEmpty (Either ChatError ([UserId], PQEncryption)) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (Either ChatError ([UserId], PQEncryption))
rs)

-- [MessageId] - SndMessage ids inside MsgBatch, or single message id
type ChatMsgReq = (Connection, MsgFlags, (ValueOrRef MsgBody, [MessageId]))

deliverMessages :: NonEmpty ChatMsgReq -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption)))
deliverMessages :: NonEmpty ChatMsgReq
-> CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
deliverMessages NonEmpty ChatMsgReq
msgs = NonEmpty (Either ChatError ChatMsgReq)
-> CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
deliverMessagesB (NonEmpty (Either ChatError ChatMsgReq)
 -> CM (NonEmpty (Either ChatError ([UserId], PQEncryption))))
-> NonEmpty (Either ChatError ChatMsgReq)
-> CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
forall a b. (a -> b) -> a -> b
$ (ChatMsgReq -> Either ChatError ChatMsgReq)
-> NonEmpty ChatMsgReq -> NonEmpty (Either ChatError ChatMsgReq)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map ChatMsgReq -> Either ChatError ChatMsgReq
forall a b. b -> Either a b
Right NonEmpty ChatMsgReq
msgs

deliverMessagesB :: NonEmpty (Either ChatError ChatMsgReq) -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption)))
deliverMessagesB :: NonEmpty (Either ChatError ChatMsgReq)
-> CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
deliverMessagesB NonEmpty (Either ChatError ChatMsgReq)
msgReqs = do
  NonEmpty (Either ChatError ChatMsgReq)
msgReqs' <- if (Either ChatError ChatMsgReq -> Bool)
-> NonEmpty (Either ChatError ChatMsgReq) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either ChatError ChatMsgReq -> Bool
forall {a} {b} {c}. Either a (Connection, b, c) -> Bool
connSupportsPQ NonEmpty (Either ChatError ChatMsgReq)
msgReqs then IO (NonEmpty (Either ChatError ChatMsgReq))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (NonEmpty (Either ChatError ChatMsgReq))
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (NonEmpty (Either ChatError ChatMsgReq))
compressBodies else NonEmpty (Either ChatError ChatMsgReq)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (NonEmpty (Either ChatError ChatMsgReq))
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty (Either ChatError ChatMsgReq)
msgReqs
  NonEmpty (Either ChatError (ChatMsgReq, (UserId, PQEncryption)))
sent <- (Either ChatError ChatMsgReq
 -> Either AgentErrorType (UserId, PQEncryption)
 -> Either ChatError (ChatMsgReq, (UserId, PQEncryption)))
-> NonEmpty (Either ChatError ChatMsgReq)
-> NonEmpty (Either AgentErrorType (UserId, PQEncryption))
-> NonEmpty (Either ChatError (ChatMsgReq, (UserId, PQEncryption)))
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
L.zipWith Either ChatError ChatMsgReq
-> Either AgentErrorType (UserId, PQEncryption)
-> Either ChatError (ChatMsgReq, (UserId, PQEncryption))
forall {a} {b}.
Either ChatError a
-> Either AgentErrorType b -> Either ChatError (a, b)
prepareBatch NonEmpty (Either ChatError ChatMsgReq)
msgReqs' (NonEmpty (Either AgentErrorType (UserId, PQEncryption))
 -> NonEmpty
      (Either ChatError (ChatMsgReq, (UserId, PQEncryption))))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (NonEmpty (Either AgentErrorType (UserId, PQEncryption)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (NonEmpty (Either ChatError (ChatMsgReq, (UserId, PQEncryption))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AgentClient
 -> ExceptT
      AgentErrorType
      IO
      (NonEmpty (Either AgentErrorType (UserId, PQEncryption))))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (NonEmpty (Either AgentErrorType (UserId, PQEncryption)))
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent (AgentClient
-> NonEmpty (Either AgentErrorType MsgReq)
-> ExceptT
     AgentErrorType
     IO
     (NonEmpty (Either AgentErrorType (UserId, PQEncryption)))
forall (t :: * -> *).
Traversable t =>
AgentClient
-> t (Either AgentErrorType MsgReq)
-> AE (t (Either AgentErrorType (UserId, PQEncryption)))
`sendMessagesB` (Maybe UserId, NonEmpty (Either AgentErrorType MsgReq))
-> NonEmpty (Either AgentErrorType MsgReq)
forall a b. (a, b) -> b
snd ((Maybe UserId
 -> Either ChatError ChatMsgReq
 -> (Maybe UserId, Either AgentErrorType MsgReq))
-> Maybe UserId
-> NonEmpty (Either ChatError ChatMsgReq)
-> (Maybe UserId, NonEmpty (Either AgentErrorType MsgReq))
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Maybe UserId
-> Either ChatError ChatMsgReq
-> (Maybe UserId, Either AgentErrorType MsgReq)
forall {a} {c} {d} {b}.
Maybe UserId
-> Either a (Connection, c, (d, b))
-> (Maybe UserId,
    Either AgentErrorType (ByteString, PQEncryption, c, d))
toAgent Maybe UserId
forall a. Maybe a
Nothing NonEmpty (Either ChatError ChatMsgReq)
msgReqs'))
  ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (ReaderT ChatController IO [Either ChatError ()]
    -> ReaderT ChatController IO ())
-> ReaderT ChatController IO [Either ChatError ()]
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT ChatController IO [Either ChatError ()]
-> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO [Either ChatError ()]
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ReaderT ChatController IO [Either ChatError ()]
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ (Connection -> [IO ()])
-> ReaderT ChatController IO [Either ChatError ()]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' ((Connection -> [IO ()])
 -> ReaderT ChatController IO [Either ChatError ()])
-> (Connection -> [IO ()])
-> ReaderT ChatController IO [Either ChatError ()]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ((ChatMsgReq, (UserId, PQEncryption)) -> IO ())
-> [(ChatMsgReq, (UserId, PQEncryption))] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> (ChatMsgReq, (UserId, PQEncryption)) -> IO ()
updatePQSndEnabled Connection
db) ([Either ChatError (ChatMsgReq, (UserId, PQEncryption))]
-> [(ChatMsgReq, (UserId, PQEncryption))]
forall a b. [Either a b] -> [b]
rights ([Either ChatError (ChatMsgReq, (UserId, PQEncryption))]
 -> [(ChatMsgReq, (UserId, PQEncryption))])
-> (NonEmpty
      (Either ChatError (ChatMsgReq, (UserId, PQEncryption)))
    -> [Either ChatError (ChatMsgReq, (UserId, PQEncryption))])
-> NonEmpty (Either ChatError (ChatMsgReq, (UserId, PQEncryption)))
-> [(ChatMsgReq, (UserId, PQEncryption))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Either ChatError (ChatMsgReq, (UserId, PQEncryption)))
-> [Either ChatError (ChatMsgReq, (UserId, PQEncryption))]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty (Either ChatError (ChatMsgReq, (UserId, PQEncryption)))
 -> [(ChatMsgReq, (UserId, PQEncryption))])
-> NonEmpty (Either ChatError (ChatMsgReq, (UserId, PQEncryption)))
-> [(ChatMsgReq, (UserId, PQEncryption))]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Either ChatError (ChatMsgReq, (UserId, PQEncryption)))
sent)
  ReaderT
  ChatController
  IO
  (NonEmpty (Either ChatError ([UserId], PQEncryption)))
-> CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
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 ([UserId], PQEncryption)))
 -> CM (NonEmpty (Either ChatError ([UserId], PQEncryption))))
-> ((Connection
     -> NonEmpty (IO (Either ChatError ([UserId], PQEncryption))))
    -> ReaderT
         ChatController
         IO
         (NonEmpty (Either ChatError ([UserId], PQEncryption))))
-> (Connection
    -> NonEmpty (IO (Either ChatError ([UserId], PQEncryption))))
-> CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection
 -> NonEmpty (IO (Either ChatError ([UserId], PQEncryption))))
-> ReaderT
     ChatController
     IO
     (NonEmpty (Either ChatError ([UserId], PQEncryption)))
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO (Either ChatError a)))
-> CM' (t (Either ChatError a))
withStoreBatch ((Connection
  -> NonEmpty (IO (Either ChatError ([UserId], PQEncryption))))
 -> CM (NonEmpty (Either ChatError ([UserId], PQEncryption))))
-> (Connection
    -> NonEmpty (IO (Either ChatError ([UserId], PQEncryption))))
-> CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
forall a b. (a -> b) -> a -> b
$ \Connection
db -> (Either ChatError (ChatMsgReq, (UserId, PQEncryption))
 -> IO (Either ChatError ([UserId], PQEncryption)))
-> NonEmpty (Either ChatError (ChatMsgReq, (UserId, PQEncryption)))
-> NonEmpty (IO (Either ChatError ([UserId], PQEncryption)))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (((ChatMsgReq, (UserId, PQEncryption))
 -> IO (Either ChatError ([UserId], PQEncryption)))
-> Either ChatError (ChatMsgReq, (UserId, PQEncryption))
-> IO (Either ChatError ([UserId], PQEncryption))
forall (m :: * -> *) a e b.
Monad m =>
(a -> m (Either e b)) -> Either e a -> m (Either e b)
bindRight (((ChatMsgReq, (UserId, PQEncryption))
  -> IO (Either ChatError ([UserId], PQEncryption)))
 -> Either ChatError (ChatMsgReq, (UserId, PQEncryption))
 -> IO (Either ChatError ([UserId], PQEncryption)))
-> ((ChatMsgReq, (UserId, PQEncryption))
    -> IO (Either ChatError ([UserId], PQEncryption)))
-> Either ChatError (ChatMsgReq, (UserId, PQEncryption))
-> IO (Either ChatError ([UserId], PQEncryption))
forall a b. (a -> b) -> a -> b
$ Connection
-> (ChatMsgReq, (UserId, PQEncryption))
-> IO (Either ChatError ([UserId], PQEncryption))
createDelivery Connection
db) NonEmpty (Either ChatError (ChatMsgReq, (UserId, PQEncryption)))
sent
  where
    connSupportsPQ :: Either a (Connection, b, c) -> Bool
connSupportsPQ = \case
      Right (Connection {pqSupport :: Connection -> PQSupport
pqSupport = PQSupport
PQSupportOn, connChatVersion :: Connection -> Version ChatVersion
connChatVersion = Version ChatVersion
v}, b
_, c
_) -> Version ChatVersion
v Version ChatVersion -> Version ChatVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version ChatVersion
pqEncryptionCompressionVersion
      Either a (Connection, b, c)
_ -> Bool
False
    compressBodies :: IO (NonEmpty (Either ChatError ChatMsgReq))
compressBodies =
      NonEmpty (Either ChatError ChatMsgReq)
-> (ChatMsgReq -> IO (Either ChatError ChatMsgReq))
-> IO (NonEmpty (Either ChatError ChatMsgReq))
forall (m :: * -> *) (t :: * -> *) e a b.
(Monad m, Traversable t) =>
t (Either e a) -> (a -> m (Either e b)) -> m (t (Either e b))
forME NonEmpty (Either ChatError ChatMsgReq)
msgReqs ((ChatMsgReq -> IO (Either ChatError ChatMsgReq))
 -> IO (NonEmpty (Either ChatError ChatMsgReq)))
-> (ChatMsgReq -> IO (Either ChatError ChatMsgReq))
-> IO (NonEmpty (Either ChatError ChatMsgReq))
forall a b. (a -> b) -> a -> b
$ \(Connection
conn, MsgFlags
msgFlags, (ValueOrRef ByteString
mbr, [UserId]
msgIds)) -> ExceptT ChatError IO ChatMsgReq -> IO (Either ChatError ChatMsgReq)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ChatError IO ChatMsgReq
 -> IO (Either ChatError ChatMsgReq))
-> ExceptT ChatError IO ChatMsgReq
-> IO (Either ChatError ChatMsgReq)
forall a b. (a -> b) -> a -> b
$ do
        ValueOrRef ByteString
mbr' <- case ValueOrRef ByteString
mbr of
          VRValue Maybe Int
i ByteString
msgBody | ByteString -> Int
B.length ByteString
msgBody Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxCompressedMsgLength -> do
            let msgBody' :: ByteString
msgBody' = ByteString -> ByteString
compressedBatchMsgBody_ ByteString
msgBody
            Bool -> ExceptT ChatError IO () -> ExceptT ChatError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
msgBody' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxCompressedMsgLength) (ExceptT ChatError IO () -> ExceptT ChatError IO ())
-> ExceptT ChatError IO () -> ExceptT ChatError IO ()
forall a b. (a -> b) -> a -> b
$ ChatError -> ExceptT ChatError IO ()
forall a. ChatError -> ExceptT ChatError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> ExceptT ChatError IO ())
-> ChatError -> ExceptT ChatError IO ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ChatError
ChatError (ChatErrorType -> ChatError) -> ChatErrorType -> ChatError
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEException String
"large compressed message"
            ValueOrRef ByteString
-> ExceptT ChatError IO (ValueOrRef ByteString)
forall a. a -> ExceptT ChatError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValueOrRef ByteString
 -> ExceptT ChatError IO (ValueOrRef ByteString))
-> ValueOrRef ByteString
-> ExceptT ChatError IO (ValueOrRef ByteString)
forall a b. (a -> b) -> a -> b
$ Maybe Int -> ByteString -> ValueOrRef ByteString
forall a. Maybe Int -> a -> ValueOrRef a
VRValue Maybe Int
i ByteString
msgBody'
          ValueOrRef ByteString
v -> ValueOrRef ByteString
-> ExceptT ChatError IO (ValueOrRef ByteString)
forall a. a -> ExceptT ChatError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValueOrRef ByteString
v
        ChatMsgReq -> ExceptT ChatError IO ChatMsgReq
forall a. a -> ExceptT ChatError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Connection
conn, MsgFlags
msgFlags, (ValueOrRef ByteString
mbr', [UserId]
msgIds))
    toAgent :: Maybe UserId
-> Either a (Connection, c, (d, b))
-> (Maybe UserId,
    Either AgentErrorType (ByteString, PQEncryption, c, d))
toAgent Maybe UserId
prev = \case
      Right (conn :: Connection
conn@Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId, PQEncryption
pqEncryption :: Connection -> PQEncryption
pqEncryption :: PQEncryption
pqEncryption}, c
msgFlags, (d
mbr, b
_msgIds)) ->
        let cId :: ByteString
cId = case Maybe UserId
prev of
              Just UserId
prevId | UserId
prevId UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== UserId
connId -> ByteString
""
              Maybe UserId
_ -> Connection -> ByteString
aConnId Connection
conn
         in (UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
connId, (ByteString, PQEncryption, c, d)
-> Either AgentErrorType (ByteString, PQEncryption, c, d)
forall a b. b -> Either a b
Right (ByteString
cId, PQEncryption
pqEncryption, c
msgFlags, d
mbr))
      Left a
_ce -> (Maybe UserId
prev, AgentErrorType
-> Either AgentErrorType (ByteString, PQEncryption, c, d)
forall a b. a -> Either a b
Left (String -> AgentErrorType
AP.INTERNAL String
"ChatError, skip")) -- as long as it is Left, the agent batchers should just step over it
    prepareBatch :: Either ChatError a
-> Either AgentErrorType b -> Either ChatError (a, b)
prepareBatch (Right a
req) (Right b
ar) = (a, b) -> Either ChatError (a, b)
forall a b. b -> Either a b
Right (a
req, b
ar)
    prepareBatch (Left ChatError
ce) Either AgentErrorType b
_ = ChatError -> Either ChatError (a, b)
forall a b. a -> Either a b
Left ChatError
ce -- restore original ChatError
    prepareBatch Either ChatError a
_ (Left AgentErrorType
ae) = ChatError -> Either ChatError (a, b)
forall a b. a -> Either a b
Left (ChatError -> Either ChatError (a, b))
-> ChatError -> Either ChatError (a, b)
forall a b. (a -> b) -> a -> b
$ AgentErrorType
-> AgentConnId -> Maybe ConnectionEntity -> ChatError
ChatErrorAgent AgentErrorType
ae (ByteString -> AgentConnId
AgentConnId ByteString
"") Maybe ConnectionEntity
forall a. Maybe a
Nothing
    createDelivery :: DB.Connection -> (ChatMsgReq, (AgentMsgId, PQEncryption)) -> IO (Either ChatError ([Int64], PQEncryption))
    createDelivery :: Connection
-> (ChatMsgReq, (UserId, PQEncryption))
-> IO (Either ChatError ([UserId], PQEncryption))
createDelivery Connection
db ((Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId}, MsgFlags
_, (ValueOrRef ByteString
_, [UserId]
msgIds)), (UserId
agentMsgId, PQEncryption
pqEnc')) = do
      ([UserId], PQEncryption)
-> Either ChatError ([UserId], PQEncryption)
forall a b. b -> Either a b
Right (([UserId], PQEncryption)
 -> Either ChatError ([UserId], PQEncryption))
-> ([UserId] -> ([UserId], PQEncryption))
-> [UserId]
-> Either ChatError ([UserId], PQEncryption)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,PQEncryption
pqEnc') ([UserId] -> Either ChatError ([UserId], PQEncryption))
-> IO [UserId] -> IO (Either ChatError ([UserId], PQEncryption))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UserId -> IO UserId) -> [UserId] -> IO [UserId]
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 -> SndMsgDelivery -> UserId -> IO UserId
createSndMsgDelivery Connection
db (SndMsgDelivery {UserId
connId :: UserId
connId :: UserId
connId, UserId
agentMsgId :: UserId
agentMsgId :: UserId
agentMsgId})) [UserId]
msgIds
    updatePQSndEnabled :: DB.Connection -> (ChatMsgReq, (AgentMsgId, PQEncryption)) -> IO ()
    updatePQSndEnabled :: Connection -> (ChatMsgReq, (UserId, PQEncryption)) -> IO ()
updatePQSndEnabled Connection
db ((Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId, Maybe PQEncryption
pqSndEnabled :: Connection -> Maybe PQEncryption
pqSndEnabled :: Maybe PQEncryption
pqSndEnabled}, MsgFlags
_, (ValueOrRef ByteString, [UserId])
_), (UserId
_, PQEncryption
pqSndEnabled')) =
      case (Maybe PQEncryption
pqSndEnabled, PQEncryption
pqSndEnabled') of
        (Just PQEncryption
b, PQEncryption
b') | PQEncryption
b' PQEncryption -> PQEncryption -> Bool
forall a. Eq a => a -> a -> Bool
/= PQEncryption
b -> IO ()
updatePQ
        (Maybe PQEncryption
Nothing, PQEncryption
PQEncOn) -> IO ()
updatePQ
        (Maybe PQEncryption, PQEncryption)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        updatePQ :: IO ()
updatePQ = Connection -> UserId -> PQEncryption -> IO ()
updateConnPQSndEnabled Connection
db UserId
connId PQEncryption
pqSndEnabled'

sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage
sendGroupMessage :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupInfo
-> Maybe GroupChatScope
-> [GroupMember]
-> ChatMsgEvent e
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
sendGroupMessage User
user GroupInfo
gInfo Maybe GroupChatScope
gcScope [GroupMember]
members ChatMsgEvent e
chatMsgEvent = do
  User
-> GroupInfo
-> Maybe GroupChatScope
-> [GroupMember]
-> NonEmpty (ChatMsgEvent e)
-> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupInfo
-> Maybe GroupChatScope
-> [GroupMember]
-> NonEmpty (ChatMsgEvent e)
-> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages User
user GroupInfo
gInfo Maybe GroupChatScope
gcScope [GroupMember]
members (ChatMsgEvent e
chatMsgEvent ChatMsgEvent e -> [ChatMsgEvent e] -> NonEmpty (ChatMsgEvent e)
forall a. a -> [a] -> NonEmpty a
:| []) CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
-> ((NonEmpty (Either ChatError SndMessage), GroupSndResult)
    -> ExceptT ChatError (ReaderT ChatController IO) SndMessage)
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
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 SndMessage
msg) :| [], GroupSndResult
_) -> SndMessage
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SndMessage
msg
    (NonEmpty (Either ChatError SndMessage), GroupSndResult)
_ -> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType
 -> ExceptT ChatError (ReaderT ChatController IO) SndMessage)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError String
"sendGroupMessage: expected 1 message"

sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage
sendGroupMessage' :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupInfo
-> [GroupMember]
-> ChatMsgEvent e
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
sendGroupMessage' User
user GroupInfo
gInfo [GroupMember]
members ChatMsgEvent e
chatMsgEvent =
  User
-> GroupInfo
-> [GroupMember]
-> NonEmpty (ChatMsgEvent e)
-> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupInfo
-> [GroupMember]
-> NonEmpty (ChatMsgEvent e)
-> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages_ User
user GroupInfo
gInfo [GroupMember]
members (ChatMsgEvent e
chatMsgEvent ChatMsgEvent e -> [ChatMsgEvent e] -> NonEmpty (ChatMsgEvent e)
forall a. a -> [a] -> NonEmpty a
:| []) CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
-> ((NonEmpty (Either ChatError SndMessage), GroupSndResult)
    -> ExceptT ChatError (ReaderT ChatController IO) SndMessage)
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
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 SndMessage
msg) :| [], GroupSndResult
_) -> SndMessage
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SndMessage
msg
    (NonEmpty (Either ChatError SndMessage), GroupSndResult)
_ -> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType
 -> ExceptT ChatError (ReaderT ChatController IO) SndMessage)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError String
"sendGroupMessage': expected 1 message"

sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupInfo
-> Maybe GroupChatScope
-> [GroupMember]
-> NonEmpty (ChatMsgEvent e)
-> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages User
user GroupInfo
gInfo Maybe GroupChatScope
scope [GroupMember]
members NonEmpty (ChatMsgEvent e)
events = do
  -- TODO [knocking] send current profile to pending member after approval?
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldSendProfileUpdate (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$
    ExceptT ChatError (ReaderT ChatController IO) ()
sendProfileUpdate ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> ExceptT ChatError (ReaderT ChatController IO) ()
eToView
  User
-> GroupInfo
-> [GroupMember]
-> NonEmpty (ChatMsgEvent e)
-> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupInfo
-> [GroupMember]
-> NonEmpty (ChatMsgEvent e)
-> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages_ User
user GroupInfo
gInfo [GroupMember]
members NonEmpty (ChatMsgEvent e)
events
  where
    User {profile :: User -> LocalProfile
profile = LocalProfile
p, Maybe UTCTime
userMemberProfileUpdatedAt :: Maybe UTCTime
userMemberProfileUpdatedAt :: User -> Maybe UTCTime
userMemberProfileUpdatedAt} = User
user
    GroupInfo {Maybe UTCTime
userMemberProfileSentAt :: Maybe UTCTime
userMemberProfileSentAt :: GroupInfo -> Maybe UTCTime
userMemberProfileSentAt} = GroupInfo
gInfo
    shouldSendProfileUpdate :: Bool
shouldSendProfileUpdate
      | Maybe GroupChatScope -> Bool
forall a. Maybe a -> Bool
isJust Maybe GroupChatScope
scope = Bool
False -- why not sending profile updates to scopes?
      | GroupInfo -> Bool
incognitoMembership GroupInfo
gInfo = Bool
False
      | Bool
otherwise =
          case (Maybe UTCTime
userMemberProfileSentAt, Maybe UTCTime
userMemberProfileUpdatedAt) of
            (Just UTCTime
lastSentTs, Just UTCTime
lastUpdateTs) -> UTCTime
lastSentTs UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
lastUpdateTs
            (Maybe UTCTime
Nothing, Just UTCTime
_) -> Bool
True
            (Maybe UTCTime, Maybe UTCTime)
_ -> Bool
False
    sendProfileUpdate :: ExceptT ChatError (ReaderT ChatController IO) ()
sendProfileUpdate = do
      let members' :: [GroupMember]
members' = (GroupMember -> Bool) -> [GroupMember] -> [GroupMember]
forall a. (a -> Bool) -> [a] -> [a]
filter (GroupMember -> Version ChatVersion -> Bool
`supportsVersion` Version ChatVersion
memberProfileUpdateVersion) [GroupMember]
members
          allowSimplexLinks :: Bool
allowSimplexLinks = SGroupFeature 'GFSimplexLinks -> GroupInfo -> Bool
forall (f :: GroupFeature).
GroupFeatureRoleI f =>
SGroupFeature f -> GroupInfo -> Bool
groupFeatureUserAllowed SGroupFeature 'GFSimplexLinks
SGFSimplexLinks GroupInfo
gInfo
          profileUpdateEvent :: ChatMsgEvent 'Json
profileUpdateEvent = Profile -> ChatMsgEvent 'Json
XInfo (Profile -> ChatMsgEvent 'Json) -> Profile -> ChatMsgEvent 'Json
forall a b. (a -> b) -> a -> b
$ Bool -> Profile -> Profile
redactedMemberProfile Bool
allowSimplexLinks (Profile -> Profile) -> Profile -> Profile
forall a b. (a -> b) -> a -> b
$ LocalProfile -> Profile
fromLocalProfile LocalProfile
p
      ExceptT ChatError (ReaderT ChatController IO) SndMessage
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) SndMessage
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 [GroupMember]
members' ChatMsgEvent 'Json
profileUpdateEvent
      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
      (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> GroupInfo -> UTCTime -> IO ()
updateUserMemberProfileSentAt Connection
db User
user GroupInfo
gInfo UTCTime
currentTs

data GroupSndResult = GroupSndResult
  { GroupSndResult
-> [(UserId, Either ChatError [UserId],
     Either ChatError ([UserId], PQEncryption))]
sentTo :: [(GroupMemberId, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption))],
    GroupSndResult
-> [(UserId, Either ChatError UserId, Either ChatError ())]
pending :: [(GroupMemberId, Either ChatError MessageId, Either ChatError ())],
    GroupSndResult -> [GroupMember]
forwarded :: [GroupMember]
  }

sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages_ :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupInfo
-> [GroupMember]
-> NonEmpty (ChatMsgEvent e)
-> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages_ User
_user gInfo :: GroupInfo
gInfo@GroupInfo {UserId
groupId :: GroupInfo -> UserId
groupId :: UserId
groupId} [GroupMember]
recipientMembers NonEmpty (ChatMsgEvent e)
events = do
  let idsEvts :: NonEmpty (ConnOrGroupId, ChatMsgEvent e)
idsEvts = (ChatMsgEvent e -> (ConnOrGroupId, ChatMsgEvent e))
-> NonEmpty (ChatMsgEvent e)
-> NonEmpty (ConnOrGroupId, ChatMsgEvent e)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (UserId -> ConnOrGroupId
GroupId UserId
groupId,) NonEmpty (ChatMsgEvent e)
events
  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 e)
-> 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 e)
idsEvts
  [GroupMember]
recipientMembers' <- IO [GroupMember] -> CM [GroupMember]
forall a. IO a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [GroupMember] -> CM [GroupMember])
-> IO [GroupMember] -> CM [GroupMember]
forall a b. (a -> b) -> a -> b
$ [GroupMember] -> IO [GroupMember]
shuffleMembers [GroupMember]
recipientMembers
  let msgFlags :: MsgFlags
msgFlags = MsgFlags {notification :: Bool
notification = (ChatMsgEvent e -> Bool) -> NonEmpty (ChatMsgEvent e) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CMEventTag e -> Bool
forall (e :: MsgEncoding). CMEventTag e -> Bool
hasNotification (CMEventTag e -> Bool)
-> (ChatMsgEvent e -> CMEventTag e) -> ChatMsgEvent e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatMsgEvent e -> CMEventTag e
forall (e :: MsgEncoding). ChatMsgEvent e -> CMEventTag e
toCMEventTag) NonEmpty (ChatMsgEvent e)
events}
      ([(GroupMember, Connection)]
toSendSeparate, [(GroupMember, Connection)]
toSendBatched, [GroupMember]
toPending, [GroupMember]
forwarded, Set UserId
_, Int
dups) =
        (GroupMember
 -> ([(GroupMember, Connection)], [(GroupMember, Connection)],
     [GroupMember], [GroupMember], Set UserId, Int)
 -> ([(GroupMember, Connection)], [(GroupMember, Connection)],
     [GroupMember], [GroupMember], Set UserId, Int))
-> ([(GroupMember, Connection)], [(GroupMember, Connection)],
    [GroupMember], [GroupMember], Set UserId, Int)
-> [GroupMember]
-> ([(GroupMember, Connection)], [(GroupMember, Connection)],
    [GroupMember], [GroupMember], Set UserId, Int)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' ([GroupMember]
-> GroupMember
-> ([(GroupMember, Connection)], [(GroupMember, Connection)],
    [GroupMember], [GroupMember], Set UserId, Int)
-> ([(GroupMember, Connection)], [(GroupMember, Connection)],
    [GroupMember], [GroupMember], Set UserId, Int)
addMember [GroupMember]
recipientMembers') ([], [], [], [], Set UserId
forall a. Set a
S.empty, Int
0 :: Int) [GroupMember]
recipientMembers'
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
dups Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ContactName -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ContactName -> m ()
logError (ContactName -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ContactName -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ContactName
"sendGroupMessages_: " ContactName -> ContactName -> ContactName
forall a. Semigroup a => a -> a -> a
<> Int -> ContactName
forall a. Show a => a -> ContactName
tshow Int
dups ContactName -> ContactName -> ContactName
forall a. Semigroup a => a -> a -> a
<> ContactName
" duplicate members"
  -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here
  -- Deliver to toSend members
  let ([UserId]
sendToMemIds, [Either ChatError ChatMsgReq]
msgReqs) = MsgFlags
-> NonEmpty (Either ChatError SndMessage)
-> [(GroupMember, Connection)]
-> [(GroupMember, Connection)]
-> ([UserId], [Either ChatError ChatMsgReq])
prepareMsgReqs MsgFlags
msgFlags NonEmpty (Either ChatError SndMessage)
sndMsgs_ [(GroupMember, Connection)]
toSendSeparate [(GroupMember, Connection)]
toSendBatched
  [Either ChatError ([UserId], PQEncryption)]
delivered <- ExceptT
  ChatError
  (ReaderT ChatController IO)
  [Either ChatError ([UserId], PQEncryption)]
-> (NonEmpty (Either ChatError ChatMsgReq)
    -> ExceptT
         ChatError
         (ReaderT ChatController IO)
         [Either ChatError ([UserId], PQEncryption)])
-> Maybe (NonEmpty (Either ChatError ChatMsgReq))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Either ChatError ([UserId], PQEncryption)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Either ChatError ([UserId], PQEncryption)]
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Either ChatError ([UserId], PQEncryption)]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) ((NonEmpty (Either ChatError ([UserId], PQEncryption))
 -> [Either ChatError ([UserId], PQEncryption)])
-> CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Either ChatError ([UserId], PQEncryption)]
forall a b.
(a -> b)
-> ExceptT ChatError (ReaderT ChatController IO) a
-> ExceptT ChatError (ReaderT ChatController IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Either ChatError ([UserId], PQEncryption))
-> [Either ChatError ([UserId], PQEncryption)]
forall a. NonEmpty a -> [a]
L.toList (CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      [Either ChatError ([UserId], PQEncryption)])
-> (NonEmpty (Either ChatError ChatMsgReq)
    -> CM (NonEmpty (Either ChatError ([UserId], PQEncryption))))
-> NonEmpty (Either ChatError ChatMsgReq)
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Either ChatError ([UserId], PQEncryption)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Either ChatError ChatMsgReq)
-> CM (NonEmpty (Either ChatError ([UserId], PQEncryption)))
deliverMessagesB) (Maybe (NonEmpty (Either ChatError ChatMsgReq))
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      [Either ChatError ([UserId], PQEncryption)])
-> Maybe (NonEmpty (Either ChatError ChatMsgReq))
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     [Either ChatError ([UserId], PQEncryption)]
forall a b. (a -> b) -> a -> b
$ [Either ChatError ChatMsgReq]
-> Maybe (NonEmpty (Either ChatError ChatMsgReq))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [Either ChatError ChatMsgReq]
msgReqs
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Either ChatError ([UserId], PQEncryption)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either ChatError ([UserId], PQEncryption)]
delivered Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [UserId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UserId]
sendToMemIds) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ContactName -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ContactName -> m ()
logError ContactName
"sendGroupMessages_: sendToMemIds and delivered length mismatch"
  -- Save as pending for toPending members
  let ([UserId]
pendingMemIds, [Either ChatError (UserId, UserId)]
pendingReqs) = NonEmpty (Either ChatError SndMessage)
-> [GroupMember] -> ([UserId], [Either ChatError (UserId, UserId)])
preparePending NonEmpty (Either ChatError SndMessage)
sndMsgs_ [GroupMember]
toPending
  [Either ChatError ()]
stored <- ReaderT ChatController IO [Either ChatError ()]
-> ExceptT
     ChatError (ReaderT ChatController IO) [Either ChatError ()]
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 [Either ChatError ()]
 -> ExceptT
      ChatError (ReaderT ChatController IO) [Either ChatError ()])
-> ReaderT ChatController IO [Either ChatError ()]
-> ExceptT
     ChatError (ReaderT ChatController IO) [Either ChatError ()]
forall a b. (a -> b) -> a -> b
$ (Connection -> [IO (Either ChatError ())])
-> ReaderT ChatController IO [Either ChatError ()]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO (Either ChatError a)))
-> CM' (t (Either ChatError a))
withStoreBatch (\Connection
db -> (Either ChatError (UserId, UserId) -> IO (Either ChatError ()))
-> [Either ChatError (UserId, UserId)]
-> [IO (Either ChatError ())]
forall a b. (a -> b) -> [a] -> [b]
map (((UserId, UserId) -> IO (Either ChatError ()))
-> Either ChatError (UserId, UserId) -> IO (Either ChatError ())
forall (m :: * -> *) a e b.
Monad m =>
(a -> m (Either e b)) -> Either e a -> m (Either e b)
bindRight (((UserId, UserId) -> IO (Either ChatError ()))
 -> Either ChatError (UserId, UserId) -> IO (Either ChatError ()))
-> ((UserId, UserId) -> IO (Either ChatError ()))
-> Either ChatError (UserId, UserId)
-> IO (Either ChatError ())
forall a b. (a -> b) -> a -> b
$ Connection -> (UserId, UserId) -> IO (Either ChatError ())
createPendingMsg Connection
db) [Either ChatError (UserId, UserId)]
pendingReqs)
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Either ChatError ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either ChatError ()]
stored Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [UserId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UserId]
pendingMemIds) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ContactName -> ExceptT ChatError (ReaderT ChatController IO) ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ContactName -> m ()
logError ContactName
"sendGroupMessages_: pendingMemIds and stored length mismatch"
  -- Zip for easier access to results
  let sentTo :: [(UserId, Either ChatError [UserId],
  Either ChatError ([UserId], PQEncryption))]
sentTo = (UserId
 -> Either ChatError ChatMsgReq
 -> Either ChatError ([UserId], PQEncryption)
 -> (UserId, Either ChatError [UserId],
     Either ChatError ([UserId], PQEncryption)))
-> [UserId]
-> [Either ChatError ChatMsgReq]
-> [Either ChatError ([UserId], PQEncryption)]
-> [(UserId, Either ChatError [UserId],
     Either ChatError ([UserId], PQEncryption))]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (\UserId
mId Either ChatError ChatMsgReq
mReq Either ChatError ([UserId], PQEncryption)
r -> (UserId
mId, (ChatMsgReq -> [UserId])
-> Either ChatError ChatMsgReq -> Either ChatError [UserId]
forall a b. (a -> b) -> Either ChatError a -> Either ChatError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Connection
_, MsgFlags
_, (ValueOrRef ByteString
_, [UserId]
msgIds)) -> [UserId]
msgIds) Either ChatError ChatMsgReq
mReq, Either ChatError ([UserId], PQEncryption)
r)) [UserId]
sendToMemIds [Either ChatError ChatMsgReq]
msgReqs [Either ChatError ([UserId], PQEncryption)]
delivered
      pending :: [(UserId, Either ChatError UserId, Either ChatError ())]
pending = (UserId
 -> Either ChatError (UserId, UserId)
 -> Either ChatError ()
 -> (UserId, Either ChatError UserId, Either ChatError ()))
-> [UserId]
-> [Either ChatError (UserId, UserId)]
-> [Either ChatError ()]
-> [(UserId, Either ChatError UserId, Either ChatError ())]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (\UserId
mId Either ChatError (UserId, UserId)
pReq Either ChatError ()
r -> (UserId
mId, ((UserId, UserId) -> UserId)
-> Either ChatError (UserId, UserId) -> Either ChatError UserId
forall a b. (a -> b) -> Either ChatError a -> Either ChatError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UserId, UserId) -> UserId
forall a b. (a, b) -> b
snd Either ChatError (UserId, UserId)
pReq, Either ChatError ()
r)) [UserId]
pendingMemIds [Either ChatError (UserId, UserId)]
pendingReqs [Either ChatError ()]
stored
  (NonEmpty (Either ChatError SndMessage), GroupSndResult)
-> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (Either ChatError SndMessage)
sndMsgs_, GroupSndResult {[(UserId, Either ChatError [UserId],
  Either ChatError ([UserId], PQEncryption))]
sentTo :: [(UserId, Either ChatError [UserId],
  Either ChatError ([UserId], PQEncryption))]
sentTo :: [(UserId, Either ChatError [UserId],
  Either ChatError ([UserId], PQEncryption))]
sentTo, [(UserId, Either ChatError UserId, Either ChatError ())]
pending :: [(UserId, Either ChatError UserId, Either ChatError ())]
pending :: [(UserId, Either ChatError UserId, Either ChatError ())]
pending, [GroupMember]
forwarded :: [GroupMember]
forwarded :: [GroupMember]
forwarded})
  where
    shuffleMembers :: [GroupMember] -> IO [GroupMember]
    shuffleMembers :: [GroupMember] -> IO [GroupMember]
shuffleMembers [GroupMember]
ms = do
      let ([GroupMember]
adminMs, [GroupMember]
otherMs) = (GroupMember -> Bool)
-> [GroupMember] -> ([GroupMember], [GroupMember])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition GroupMember -> Bool
isAdmin [GroupMember]
ms
      ([GroupMember] -> [GroupMember] -> [GroupMember])
-> IO [GroupMember] -> IO [GroupMember] -> IO [GroupMember]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [GroupMember] -> [GroupMember] -> [GroupMember]
forall a. Semigroup a => a -> a -> a
(<>) ([GroupMember] -> IO [GroupMember]
forall a. [a] -> IO [a]
shuffle [GroupMember]
adminMs) ([GroupMember] -> IO [GroupMember]
forall a. [a] -> IO [a]
shuffle [GroupMember]
otherMs)
      where
        isAdmin :: GroupMember -> Bool
isAdmin GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole} = GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
>= GroupMemberRole
GRAdmin
    addMember :: [GroupMember]
-> GroupMember
-> ([(GroupMember, Connection)], [(GroupMember, Connection)],
    [GroupMember], [GroupMember], Set UserId, Int)
-> ([(GroupMember, Connection)], [(GroupMember, Connection)],
    [GroupMember], [GroupMember], Set UserId, Int)
addMember [GroupMember]
members GroupMember
m acc :: ([(GroupMember, Connection)], [(GroupMember, Connection)],
 [GroupMember], [GroupMember], Set UserId, Int)
acc@([(GroupMember, Connection)]
toSendSeparate, [(GroupMember, Connection)]
toSendBatched, [GroupMember]
pending, [GroupMember]
forwarded, !Set UserId
mIds, !Int
dups) =
      case GroupInfo
-> NonEmpty (ChatMsgEvent e)
-> [GroupMember]
-> GroupMember
-> Maybe MemberSendAction
forall (e :: MsgEncoding).
GroupInfo
-> NonEmpty (ChatMsgEvent e)
-> [GroupMember]
-> GroupMember
-> Maybe MemberSendAction
memberSendAction GroupInfo
gInfo NonEmpty (ChatMsgEvent e)
events [GroupMember]
members GroupMember
m of
        Just MemberSendAction
a
          | UserId
mId UserId -> Set UserId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set UserId
mIds -> ([(GroupMember, Connection)]
toSendSeparate, [(GroupMember, Connection)]
toSendBatched, [GroupMember]
pending, [GroupMember]
forwarded, Set UserId
mIds, Int
dups Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          | Bool
otherwise -> case MemberSendAction
a of
              MSASend Connection
conn -> ((GroupMember
m, Connection
conn) (GroupMember, Connection)
-> [(GroupMember, Connection)] -> [(GroupMember, Connection)]
forall a. a -> [a] -> [a]
: [(GroupMember, Connection)]
toSendSeparate, [(GroupMember, Connection)]
toSendBatched, [GroupMember]
pending, [GroupMember]
forwarded, Set UserId
mIds', Int
dups)
              MSASendBatched Connection
conn -> ([(GroupMember, Connection)]
toSendSeparate, (GroupMember
m, Connection
conn) (GroupMember, Connection)
-> [(GroupMember, Connection)] -> [(GroupMember, Connection)]
forall a. a -> [a] -> [a]
: [(GroupMember, Connection)]
toSendBatched, [GroupMember]
pending, [GroupMember]
forwarded, Set UserId
mIds', Int
dups)
              MemberSendAction
MSAPending -> ([(GroupMember, Connection)]
toSendSeparate, [(GroupMember, Connection)]
toSendBatched, GroupMember
m GroupMember -> [GroupMember] -> [GroupMember]
forall a. a -> [a] -> [a]
: [GroupMember]
pending, [GroupMember]
forwarded, Set UserId
mIds', Int
dups)
              MemberSendAction
MSAForwarded -> ([(GroupMember, Connection)]
toSendSeparate, [(GroupMember, Connection)]
toSendBatched, [GroupMember]
pending, GroupMember
m GroupMember -> [GroupMember] -> [GroupMember]
forall a. a -> [a] -> [a]
: [GroupMember]
forwarded, Set UserId
mIds', Int
dups)
        Maybe MemberSendAction
Nothing -> ([(GroupMember, Connection)], [(GroupMember, Connection)],
 [GroupMember], [GroupMember], Set UserId, Int)
acc
      where
        mId :: UserId
mId = GroupMember -> UserId
groupMemberId' GroupMember
m
        mIds' :: Set UserId
mIds' = UserId -> Set UserId -> Set UserId
forall a. Ord a => a -> Set a -> Set a
S.insert UserId
mId Set UserId
mIds
    prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> [(GroupMember, Connection)] -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq])
    prepareMsgReqs :: MsgFlags
-> NonEmpty (Either ChatError SndMessage)
-> [(GroupMember, Connection)]
-> [(GroupMember, Connection)]
-> ([UserId], [Either ChatError ChatMsgReq])
prepareMsgReqs MsgFlags
msgFlags NonEmpty (Either ChatError SndMessage)
msgs [(GroupMember, Connection)]
toSendSeparate [(GroupMember, Connection)]
toSendBatched = do
      let batched_ :: [Either ChatError MsgBatch]
batched_ = NonEmpty (Either ChatError SndMessage)
-> [Either ChatError MsgBatch]
batchSndMessagesJSON NonEmpty (Either ChatError SndMessage)
msgs
      case [Either ChatError MsgBatch]
-> Maybe (NonEmpty (Either ChatError MsgBatch))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [Either ChatError MsgBatch]
batched_ of
        Just NonEmpty (Either ChatError MsgBatch)
batched' -> do
          let lenMsgs :: Int
lenMsgs = NonEmpty (Either ChatError SndMessage) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (Either ChatError SndMessage)
msgs
              ([UserId]
memsSep, [Either ChatError ChatMsgReq]
mreqsSep) = Int
-> (Maybe Int
    -> Int -> SndMessage -> (ValueOrRef ByteString, [UserId]))
-> NonEmpty (Either ChatError SndMessage)
-> [(GroupMember, Connection)]
-> ([UserId], [Either ChatError ChatMsgReq])
forall a.
Int
-> (Maybe Int -> Int -> a -> (ValueOrRef ByteString, [UserId]))
-> NonEmpty (Either ChatError a)
-> [(GroupMember, Connection)]
-> ([UserId], [Either ChatError ChatMsgReq])
foldMembers Int
lenMsgs Maybe Int -> Int -> SndMessage -> (ValueOrRef ByteString, [UserId])
sndMessageMBR NonEmpty (Either ChatError SndMessage)
msgs [(GroupMember, Connection)]
toSendSeparate
              ([UserId]
memsBtch, [Either ChatError ChatMsgReq]
mreqsBtch) = Int
-> (Maybe Int
    -> Int -> MsgBatch -> (ValueOrRef ByteString, [UserId]))
-> NonEmpty (Either ChatError MsgBatch)
-> [(GroupMember, Connection)]
-> ([UserId], [Either ChatError ChatMsgReq])
forall a.
Int
-> (Maybe Int -> Int -> a -> (ValueOrRef ByteString, [UserId]))
-> NonEmpty (Either ChatError a)
-> [(GroupMember, Connection)]
-> ([UserId], [Either ChatError ChatMsgReq])
foldMembers (NonEmpty (Either ChatError MsgBatch) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (Either ChatError MsgBatch)
batched' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lenMsgs) Maybe Int -> Int -> MsgBatch -> (ValueOrRef ByteString, [UserId])
msgBatchMBR NonEmpty (Either ChatError MsgBatch)
batched' [(GroupMember, Connection)]
toSendBatched
          ([UserId]
memsSep [UserId] -> [UserId] -> [UserId]
forall a. Semigroup a => a -> a -> a
<> [UserId]
memsBtch, [Either ChatError ChatMsgReq]
mreqsSep [Either ChatError ChatMsgReq]
-> [Either ChatError ChatMsgReq] -> [Either ChatError ChatMsgReq]
forall a. Semigroup a => a -> a -> a
<> [Either ChatError ChatMsgReq]
mreqsBtch)
        Maybe (NonEmpty (Either ChatError MsgBatch))
Nothing -> ([], [])
      where
        foldMembers :: forall a. Int -> (Maybe Int -> Int -> a -> (ValueOrRef MsgBody, [MessageId])) -> NonEmpty (Either ChatError a) -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq])
        foldMembers :: forall a.
Int
-> (Maybe Int -> Int -> a -> (ValueOrRef ByteString, [UserId]))
-> NonEmpty (Either ChatError a)
-> [(GroupMember, Connection)]
-> ([UserId], [Either ChatError ChatMsgReq])
foldMembers Int
lastRef Maybe Int -> Int -> a -> (ValueOrRef ByteString, [UserId])
mkMb NonEmpty (Either ChatError a)
mbs [(GroupMember, Connection)]
mems = (Maybe Int, ([UserId], [Either ChatError ChatMsgReq]))
-> ([UserId], [Either ChatError ChatMsgReq])
forall a b. (a, b) -> b
snd ((Maybe Int, ([UserId], [Either ChatError ChatMsgReq]))
 -> ([UserId], [Either ChatError ChatMsgReq]))
-> (Maybe Int, ([UserId], [Either ChatError ChatMsgReq]))
-> ([UserId], [Either ChatError ChatMsgReq])
forall a b. (a -> b) -> a -> b
$ ((GroupMember, Connection)
 -> (Maybe Int, ([UserId], [Either ChatError ChatMsgReq]))
 -> (Maybe Int, ([UserId], [Either ChatError ChatMsgReq])))
-> (Maybe Int, ([UserId], [Either ChatError ChatMsgReq]))
-> [(GroupMember, Connection)]
-> (Maybe Int, ([UserId], [Either ChatError ChatMsgReq]))
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (GroupMember, Connection)
-> (Maybe Int, ([UserId], [Either ChatError ChatMsgReq]))
-> (Maybe Int, ([UserId], [Either ChatError ChatMsgReq]))
foldMsgBodies (Maybe Int
lastMemIdx_, ([], [])) [(GroupMember, Connection)]
mems
          where
            lastMemIdx_ :: Maybe Int
lastMemIdx_ = let len :: Int
len = [(GroupMember, Connection)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(GroupMember, Connection)]
mems 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
            foldMsgBodies :: (GroupMember, Connection) -> (Maybe Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) -> (Maybe Int, ([GroupMemberId], [Either ChatError ChatMsgReq]))
            foldMsgBodies :: (GroupMember, Connection)
-> (Maybe Int, ([UserId], [Either ChatError ChatMsgReq]))
-> (Maybe Int, ([UserId], [Either ChatError ChatMsgReq]))
foldMsgBodies (GroupMember {UserId
groupMemberId :: GroupMember -> UserId
groupMemberId :: UserId
groupMemberId}, Connection
conn) (Maybe Int
memIdx_, ([UserId], [Either ChatError ChatMsgReq])
memIdsReqs) =
              (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_,) (([UserId], [Either ChatError ChatMsgReq])
 -> (Maybe Int, ([UserId], [Either ChatError ChatMsgReq])))
-> ([UserId], [Either ChatError ChatMsgReq])
-> (Maybe Int, ([UserId], [Either ChatError ChatMsgReq]))
forall a b. (a -> b) -> a -> b
$ (Int, ([UserId], [Either ChatError ChatMsgReq]))
-> ([UserId], [Either ChatError ChatMsgReq])
forall a b. (a, b) -> b
snd ((Int, ([UserId], [Either ChatError ChatMsgReq]))
 -> ([UserId], [Either ChatError ChatMsgReq]))
-> (Int, ([UserId], [Either ChatError ChatMsgReq]))
-> ([UserId], [Either ChatError ChatMsgReq])
forall a b. (a -> b) -> a -> b
$ (Either ChatError a
 -> (Int, ([UserId], [Either ChatError ChatMsgReq]))
 -> (Int, ([UserId], [Either ChatError ChatMsgReq])))
-> (Int, ([UserId], [Either ChatError ChatMsgReq]))
-> NonEmpty (Either ChatError a)
-> (Int, ([UserId], [Either ChatError ChatMsgReq]))
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' Either ChatError a
-> (Int, ([UserId], [Either ChatError ChatMsgReq]))
-> (Int, ([UserId], [Either ChatError ChatMsgReq]))
addBody (Int
lastRef, ([UserId], [Either ChatError ChatMsgReq])
memIdsReqs) NonEmpty (Either ChatError a)
mbs
              where
                addBody :: Either ChatError a -> (Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) -> (Int, ([GroupMemberId], [Either ChatError ChatMsgReq]))
                addBody :: Either ChatError a
-> (Int, ([UserId], [Either ChatError ChatMsgReq]))
-> (Int, ([UserId], [Either ChatError ChatMsgReq]))
addBody Either ChatError a
mb (Int
i, ([UserId]
memIds, [Either ChatError ChatMsgReq]
reqs)) =
                  let req :: Either ChatError ChatMsgReq
req = (Connection
conn,MsgFlags
msgFlags,) ((ValueOrRef ByteString, [UserId]) -> ChatMsgReq)
-> (a -> (ValueOrRef ByteString, [UserId])) -> a -> ChatMsgReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Int -> a -> (ValueOrRef ByteString, [UserId])
mkMb Maybe Int
memIdx_ Int
i (a -> ChatMsgReq)
-> Either ChatError a -> Either ChatError ChatMsgReq
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ChatError a
mb
                   in (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, (UserId
groupMemberId UserId -> [UserId] -> [UserId]
forall a. a -> [a] -> [a]
: [UserId]
memIds, Either ChatError ChatMsgReq
req Either ChatError ChatMsgReq
-> [Either ChatError ChatMsgReq] -> [Either ChatError ChatMsgReq]
forall a. a -> [a] -> [a]
: [Either ChatError ChatMsgReq]
reqs))
        sndMessageMBR :: Maybe Int -> Int -> SndMessage -> (ValueOrRef MsgBody, [MessageId])
        sndMessageMBR :: Maybe Int -> Int -> SndMessage -> (ValueOrRef ByteString, [UserId])
sndMessageMBR Maybe Int
memIdx_ Int
i SndMessage {UserId
msgId :: SndMessage -> UserId
msgId :: UserId
msgId, ByteString
msgBody :: SndMessage -> ByteString
msgBody :: ByteString
msgBody} = (Maybe Int -> Int -> ByteString -> ValueOrRef ByteString
forall {a} {a}.
(Eq a, Num a) =>
Maybe a -> Int -> a -> ValueOrRef a
vrValue_ Maybe Int
memIdx_ Int
i ByteString
msgBody, [UserId
Item [UserId]
msgId])
        msgBatchMBR :: Maybe Int -> Int -> MsgBatch -> (ValueOrRef MsgBody, [MessageId])
        msgBatchMBR :: Maybe Int -> Int -> MsgBatch -> (ValueOrRef ByteString, [UserId])
msgBatchMBR Maybe Int
memIdx_ Int
i (MsgBatch ByteString
batchBody [SndMessage]
sndMsgs) = (Maybe Int -> Int -> ByteString -> ValueOrRef ByteString
forall {a} {a}.
(Eq a, Num a) =>
Maybe a -> Int -> a -> ValueOrRef a
vrValue_ Maybe Int
memIdx_ Int
i ByteString
batchBody, (SndMessage -> UserId) -> [SndMessage] -> [UserId]
forall a b. (a -> b) -> [a] -> [b]
map (\SndMessage {UserId
msgId :: SndMessage -> UserId
msgId :: UserId
msgId} -> UserId
msgId) [SndMessage]
sndMsgs)
        vrValue_ :: Maybe a -> Int -> a -> ValueOrRef a
vrValue_ Maybe a
memIdx_ Int
i a
v = case Maybe a
memIdx_ of
          Maybe a
Nothing -> Maybe Int -> a -> ValueOrRef a
forall a. Maybe Int -> a -> ValueOrRef a
VRValue Maybe Int
forall a. Maybe a
Nothing a
v -- sending to one member, do not reference bodies
          Just a
1 -> Maybe Int -> a -> ValueOrRef a
forall a. Maybe Int -> a -> ValueOrRef a
VRValue (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i) a
v
          Just a
_ -> Int -> ValueOrRef a
forall a. Int -> ValueOrRef a
VRRef Int
i
    preparePending :: NonEmpty (Either ChatError SndMessage) -> [GroupMember] -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)])
    preparePending :: NonEmpty (Either ChatError SndMessage)
-> [GroupMember] -> ([UserId], [Either ChatError (UserId, UserId)])
preparePending NonEmpty (Either ChatError SndMessage)
msgs_ =
      (GroupMember
 -> ([UserId], [Either ChatError (UserId, UserId)])
 -> ([UserId], [Either ChatError (UserId, UserId)]))
-> ([UserId], [Either ChatError (UserId, UserId)])
-> [GroupMember]
-> ([UserId], [Either ChatError (UserId, UserId)])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' GroupMember
-> ([UserId], [Either ChatError (UserId, UserId)])
-> ([UserId], [Either ChatError (UserId, UserId)])
foldMsgs ([], [])
      where
        foldMsgs :: GroupMember -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)])
        foldMsgs :: GroupMember
-> ([UserId], [Either ChatError (UserId, UserId)])
-> ([UserId], [Either ChatError (UserId, UserId)])
foldMsgs GroupMember {UserId
groupMemberId :: GroupMember -> UserId
groupMemberId :: UserId
groupMemberId} ([UserId], [Either ChatError (UserId, UserId)])
memIdsReqs =
          (Either ChatError SndMessage
 -> ([UserId], [Either ChatError (UserId, UserId)])
 -> ([UserId], [Either ChatError (UserId, UserId)]))
-> ([UserId], [Either ChatError (UserId, UserId)])
-> NonEmpty (Either ChatError SndMessage)
-> ([UserId], [Either ChatError (UserId, UserId)])
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (\Either ChatError SndMessage
msg_ ([UserId]
memIds, [Either ChatError (UserId, UserId)]
reqs) -> (UserId
groupMemberId UserId -> [UserId] -> [UserId]
forall a. a -> [a] -> [a]
: [UserId]
memIds, (SndMessage -> (UserId, UserId))
-> Either ChatError SndMessage -> Either ChatError (UserId, UserId)
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 -> (UserId, UserId)
pendingReq Either ChatError SndMessage
msg_ Either ChatError (UserId, UserId)
-> [Either ChatError (UserId, UserId)]
-> [Either ChatError (UserId, UserId)]
forall a. a -> [a] -> [a]
: [Either ChatError (UserId, UserId)]
reqs)) ([UserId], [Either ChatError (UserId, UserId)])
memIdsReqs NonEmpty (Either ChatError SndMessage)
msgs_
          where
            pendingReq :: SndMessage -> (GroupMemberId, MessageId)
            pendingReq :: SndMessage -> (UserId, UserId)
pendingReq SndMessage {UserId
msgId :: SndMessage -> UserId
msgId :: UserId
msgId} = (UserId
groupMemberId, UserId
msgId)
    createPendingMsg :: DB.Connection -> (GroupMemberId, MessageId) -> IO (Either ChatError ())
    createPendingMsg :: Connection -> (UserId, UserId) -> IO (Either ChatError ())
createPendingMsg Connection
db (UserId
groupMemberId, UserId
msgId) =
      Connection -> UserId -> UserId -> IO ()
createPendingGroupMessage Connection
db UserId
groupMemberId UserId
msgId IO () -> Either ChatError () -> IO (Either ChatError ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> () -> Either ChatError ()
forall a b. b -> Either a b
Right ()

data MemberSendAction = MSASend Connection | MSASendBatched Connection | MSAPending | MSAForwarded

memberSendAction :: GroupInfo -> NonEmpty (ChatMsgEvent e) -> [GroupMember] -> GroupMember -> Maybe MemberSendAction
memberSendAction :: forall (e :: MsgEncoding).
GroupInfo
-> NonEmpty (ChatMsgEvent e)
-> [GroupMember]
-> GroupMember
-> Maybe MemberSendAction
memberSendAction GroupInfo {BoolDef
useRelays :: GroupInfo -> BoolDef
useRelays :: BoolDef
useRelays, GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} NonEmpty (ChatMsgEvent e)
events [GroupMember]
members m :: GroupMember
m@GroupMember {GroupMemberRole
memberRole :: GroupMember -> GroupMemberRole
memberRole :: GroupMemberRole
memberRole, GroupMemberStatus
memberStatus :: GroupMember -> GroupMemberStatus
memberStatus :: GroupMemberStatus
memberStatus}
  -- groups with relays require newer version - we don't need to check member version for batching and forwarding support
  | BoolDef -> Bool
isTrue BoolDef
useRelays =
      if
        -- if user is chat relay, send to all non chat relay members
        | GroupMember -> Bool
isMemberRelay GroupMember
membership Bool -> Bool -> Bool
&& Bool -> Bool
not (GroupMember -> Bool
isMemberRelay GroupMember
m) -> Connection -> MemberSendAction
MSASendBatched (Connection -> MemberSendAction)
-> ((UserId, Connection) -> Connection)
-> (UserId, Connection)
-> MemberSendAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserId, Connection) -> Connection
forall a b. (a, b) -> b
snd ((UserId, Connection) -> MemberSendAction)
-> Maybe (UserId, Connection) -> Maybe MemberSendAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GroupMember -> Maybe (UserId, Connection)
readyMemberConn GroupMember
m
        -- if user is not chat relay, send only to chat relays
        | Bool -> Bool
not (GroupMember -> Bool
isMemberRelay GroupMember
membership) Bool -> Bool -> Bool
&& GroupMember -> Bool
isMemberRelay GroupMember
m -> Connection -> MemberSendAction
MSASendBatched (Connection -> MemberSendAction)
-> ((UserId, Connection) -> Connection)
-> (UserId, Connection)
-> MemberSendAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserId, Connection) -> Connection
forall a b. (a, b) -> b
snd ((UserId, Connection) -> MemberSendAction)
-> Maybe (UserId, Connection) -> Maybe MemberSendAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GroupMember -> Maybe (UserId, Connection)
readyMemberConn GroupMember
m
        | Bool
otherwise -> Maybe MemberSendAction
forall a. Maybe a
Nothing -- TODO [channels fwd] MSAForwarded to create GSSForwarded snd statuses?
  | Bool
otherwise = case GroupMember -> Maybe Connection
memberConn GroupMember
m of
      Maybe Connection
Nothing -> Maybe MemberSendAction
pendingOrForwarded
      Just conn :: Connection
conn@Connection {ConnStatus
connStatus :: ConnStatus
connStatus :: Connection -> ConnStatus
connStatus}
        | Connection -> Bool
connDisabled Connection
conn Bool -> Bool -> Bool
|| ConnStatus
connStatus ConnStatus -> ConnStatus -> Bool
forall a. Eq a => a -> a -> Bool
== ConnStatus
ConnDeleted Bool -> Bool -> Bool
|| GroupMemberStatus
memberStatus GroupMemberStatus -> GroupMemberStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberStatus
GSMemRejected -> Maybe MemberSendAction
forall a. Maybe a
Nothing
        | Connection -> Bool
connInactive Connection
conn -> MemberSendAction -> Maybe MemberSendAction
forall a. a -> Maybe a
Just MemberSendAction
MSAPending
        | ConnStatus
connStatus ConnStatus -> ConnStatus -> Bool
forall a. Eq a => a -> a -> Bool
== ConnStatus
ConnSndReady Bool -> Bool -> Bool
|| ConnStatus
connStatus ConnStatus -> ConnStatus -> Bool
forall a. Eq a => a -> a -> Bool
== ConnStatus
ConnReady -> Connection -> Maybe MemberSendAction
sendBatchedOrSeparate Connection
conn
        | Bool
otherwise -> Maybe MemberSendAction
pendingOrForwarded
  where
    sendBatchedOrSeparate :: Connection -> Maybe MemberSendAction
sendBatchedOrSeparate Connection
conn
      -- admin doesn't support batch forwarding - send messages separately so that admin can forward one by one
      | GroupMemberRole
memberRole GroupMemberRole -> GroupMemberRole -> Bool
forall a. Ord a => a -> a -> Bool
>= GroupMemberRole
GRAdmin Bool -> Bool -> Bool
&& Bool -> Bool
not (GroupMember
m GroupMember -> Version ChatVersion -> Bool
`supportsVersion` Version ChatVersion
batchSend2Version) = MemberSendAction -> Maybe MemberSendAction
forall a. a -> Maybe a
Just (Connection -> MemberSendAction
MSASend Connection
conn)
      -- either member is not admin, or admin supports batched forwarding
      | Bool
otherwise = MemberSendAction -> Maybe MemberSendAction
forall a. a -> Maybe a
Just (Connection -> MemberSendAction
MSASendBatched Connection
conn)
    pendingOrForwarded :: Maybe MemberSendAction
pendingOrForwarded = case GroupMember -> GroupMemberCategory
memberCategory GroupMember
m of
      GroupMemberCategory
GCUserMember -> Maybe MemberSendAction
forall a. Maybe a
Nothing -- shouldn't happen
      GroupMemberCategory
GCInviteeMember -> MemberSendAction -> Maybe MemberSendAction
forall a. a -> Maybe a
Just MemberSendAction
MSAPending
      GroupMemberCategory
GCHostMember -> MemberSendAction -> Maybe MemberSendAction
forall a. a -> Maybe a
Just MemberSendAction
MSAPending
      GroupMemberCategory
GCPreMember -> Maybe UserId -> Maybe MemberSendAction
forwardSupportedOrPending (GroupMember -> Maybe UserId
invitedByGroupMemberId GroupMember
membership)
      GroupMemberCategory
GCPostMember -> Maybe UserId -> Maybe MemberSendAction
forwardSupportedOrPending (GroupMember -> Maybe UserId
invitedByGroupMemberId GroupMember
m)
      where
        forwardSupportedOrPending :: Maybe UserId -> Maybe MemberSendAction
forwardSupportedOrPending Maybe UserId
invitingMemberId_
          | Bool
membersSupport Bool -> Bool -> Bool
&& (ChatMsgEvent e -> Bool) -> NonEmpty (ChatMsgEvent e) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ChatMsgEvent e -> Bool
forall (e :: MsgEncoding). ChatMsgEvent e -> Bool
isForwardedGroupMsg NonEmpty (ChatMsgEvent e)
events = MemberSendAction -> Maybe MemberSendAction
forall a. a -> Maybe a
Just MemberSendAction
MSAForwarded
          | (ChatMsgEvent e -> Bool) -> NonEmpty (ChatMsgEvent e) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ChatMsgEvent e -> Bool
forall (e :: MsgEncoding). ChatMsgEvent e -> Bool
isXGrpMsgForward NonEmpty (ChatMsgEvent e)
events = Maybe MemberSendAction
forall a. Maybe a
Nothing
          | Bool
otherwise = MemberSendAction -> Maybe MemberSendAction
forall a. a -> Maybe a
Just MemberSendAction
MSAPending
          where
            membersSupport :: Bool
membersSupport =
              GroupMember
m GroupMember -> Version ChatVersion -> Bool
`supportsVersion` Version ChatVersion
groupForwardVersion Bool -> Bool -> Bool
&& Bool
invitingMemberSupportsForward
            invitingMemberSupportsForward :: Bool
invitingMemberSupportsForward = case Maybe UserId
invitingMemberId_ of
              Just UserId
invMemberId ->
                -- can be optimized for large groups by replacing [GroupMember] with Map GroupMemberId GroupMember
                case (GroupMember -> Bool) -> [GroupMember] -> Maybe GroupMember
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\GroupMember
m' -> GroupMember -> UserId
groupMemberId' GroupMember
m' UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== UserId
invMemberId) [GroupMember]
members of
                  Just GroupMember
invitingMember -> GroupMember
invitingMember GroupMember -> Version ChatVersion -> Bool
`supportsVersion` Version ChatVersion
groupForwardVersion
                  Maybe GroupMember
Nothing -> Bool
False
              Maybe UserId
Nothing -> Bool
False
            isXGrpMsgForward :: ChatMsgEvent e -> Bool
isXGrpMsgForward ChatMsgEvent e
event = case ChatMsgEvent e
event of
              XGrpMsgForward {} -> Bool
True
              ChatMsgEvent e
_ -> Bool
False

-- Should match memberSendAction logic
readyMemberConn :: GroupMember -> Maybe (GroupMemberId, Connection)
readyMemberConn :: GroupMember -> Maybe (UserId, Connection)
readyMemberConn GroupMember {UserId
groupMemberId :: GroupMember -> UserId
groupMemberId :: UserId
groupMemberId, activeConn :: GroupMember -> Maybe Connection
activeConn = Just conn :: Connection
conn@Connection {ConnStatus
connStatus :: Connection -> ConnStatus
connStatus :: ConnStatus
connStatus}, GroupMemberStatus
memberStatus :: GroupMember -> GroupMemberStatus
memberStatus :: GroupMemberStatus
memberStatus}
  | (ConnStatus
connStatus ConnStatus -> ConnStatus -> Bool
forall a. Eq a => a -> a -> Bool
== ConnStatus
ConnReady Bool -> Bool -> Bool
|| ConnStatus
connStatus ConnStatus -> ConnStatus -> Bool
forall a. Eq a => a -> a -> Bool
== ConnStatus
ConnSndReady)
    Bool -> Bool -> Bool
&& Bool -> Bool
not (Connection -> Bool
connDisabled Connection
conn)
    Bool -> Bool -> Bool
&& Bool -> Bool
not (Connection -> Bool
connInactive Connection
conn)
    Bool -> Bool -> Bool
&& GroupMemberStatus
memberStatus GroupMemberStatus -> GroupMemberStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= GroupMemberStatus
GSMemRejected =
      (UserId, Connection) -> Maybe (UserId, Connection)
forall a. a -> Maybe a
Just (UserId
groupMemberId, Connection
conn)
  | Bool
otherwise = Maybe (UserId, Connection)
forall a. Maybe a
Nothing
readyMemberConn GroupMember {activeConn :: GroupMember -> Maybe Connection
activeConn = Maybe Connection
Nothing} = Maybe (UserId, Connection)
forall a. Maybe a
Nothing

sendGroupMemberMessage :: MsgEncodingI e => GroupInfo -> GroupMember -> ChatMsgEvent e -> CM ()
sendGroupMemberMessage :: forall (e :: MsgEncoding).
MsgEncodingI e =>
GroupInfo
-> GroupMember
-> ChatMsgEvent e
-> ExceptT ChatError (ReaderT ChatController IO) ()
sendGroupMemberMessage gInfo :: GroupInfo
gInfo@GroupInfo {UserId
groupId :: GroupInfo -> UserId
groupId :: UserId
groupId} m :: GroupMember
m@GroupMember {UserId
groupMemberId :: GroupMember -> UserId
groupMemberId :: UserId
groupMemberId} ChatMsgEvent e
chatMsgEvent = do
  SndMessage
msg <- ChatMsgEvent e
-> ConnOrGroupId
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
forall (e :: MsgEncoding).
MsgEncodingI e =>
ChatMsgEvent e
-> ConnOrGroupId
-> ExceptT ChatError (ReaderT ChatController IO) SndMessage
createSndMessage ChatMsgEvent e
chatMsgEvent (UserId -> ConnOrGroupId
GroupId UserId
groupId)
  SndMessage -> ExceptT ChatError (ReaderT ChatController IO) ()
messageMember SndMessage
msg ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> ExceptT ChatError (ReaderT ChatController IO) ()
eToView
  where
    messageMember :: SndMessage -> CM ()
    messageMember :: SndMessage -> ExceptT ChatError (ReaderT ChatController IO) ()
messageMember SndMessage {UserId
msgId :: SndMessage -> UserId
msgId :: UserId
msgId, ByteString
msgBody :: SndMessage -> ByteString
msgBody :: ByteString
msgBody} = Maybe MemberSendAction
-> (MemberSendAction
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GroupInfo
-> NonEmpty (ChatMsgEvent e)
-> [GroupMember]
-> GroupMember
-> Maybe MemberSendAction
forall (e :: MsgEncoding).
GroupInfo
-> NonEmpty (ChatMsgEvent e)
-> [GroupMember]
-> GroupMember
-> Maybe MemberSendAction
memberSendAction GroupInfo
gInfo (ChatMsgEvent e
chatMsgEvent ChatMsgEvent e -> [ChatMsgEvent e] -> NonEmpty (ChatMsgEvent e)
forall a. a -> [a] -> NonEmpty a
:| []) [Item [GroupMember]
GroupMember
m] GroupMember
m) ((MemberSendAction
  -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (MemberSendAction
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \case
      MSASend Connection
conn -> CM (UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM (UserId, PQEncryption)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> CM (UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ Connection
-> CMEventTag e
-> ByteString
-> UserId
-> CM (UserId, PQEncryption)
forall (e :: MsgEncoding).
Connection
-> CMEventTag e
-> ByteString
-> UserId
-> CM (UserId, PQEncryption)
deliverMessage Connection
conn (ChatMsgEvent e -> CMEventTag e
forall (e :: MsgEncoding). ChatMsgEvent e -> CMEventTag e
toCMEventTag ChatMsgEvent e
chatMsgEvent) ByteString
msgBody UserId
msgId
      MSASendBatched Connection
conn -> CM (UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM (UserId, PQEncryption)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> CM (UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ Connection
-> CMEventTag e
-> ByteString
-> UserId
-> CM (UserId, PQEncryption)
forall (e :: MsgEncoding).
Connection
-> CMEventTag e
-> ByteString
-> UserId
-> CM (UserId, PQEncryption)
deliverMessage Connection
conn (ChatMsgEvent e -> CMEventTag e
forall (e :: MsgEncoding). ChatMsgEvent e -> CMEventTag e
toCMEventTag ChatMsgEvent e
chatMsgEvent) ByteString
msgBody UserId
msgId
      MemberSendAction
MSAPending -> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> UserId -> IO ()
createPendingGroupMessage Connection
db UserId
groupMemberId UserId
msgId
      MemberSendAction
MSAForwarded -> () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- TODO ensure order - pending messages interleave with user input messages
sendPendingGroupMessages :: User -> GroupMember -> Connection -> CM ()
sendPendingGroupMessages :: User
-> GroupMember
-> Connection
-> ExceptT ChatError (ReaderT ChatController IO) ()
sendPendingGroupMessages User
user GroupMember {UserId
groupMemberId :: GroupMember -> UserId
groupMemberId :: UserId
groupMemberId} Connection
conn = do
  [SndMessage]
msgs <- (Connection -> IO [SndMessage]) -> CM [SndMessage]
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO [SndMessage]) -> CM [SndMessage])
-> (Connection -> IO [SndMessage]) -> CM [SndMessage]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> IO [SndMessage]
getPendingGroupMessages Connection
db UserId
groupMemberId
  Maybe (NonEmpty SndMessage)
-> (NonEmpty SndMessage
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([SndMessage] -> Maybe (NonEmpty SndMessage)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [SndMessage]
msgs) ((NonEmpty SndMessage
  -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (NonEmpty SndMessage
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty SndMessage
msgs' -> do
    CM ([Either ChatError SndMessage], Maybe PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CM ([Either ChatError SndMessage], Maybe PQEncryption)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> CM ([Either ChatError SndMessage], Maybe PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User
-> Connection
-> MsgFlags
-> NonEmpty SndMessage
-> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessages User
user Connection
conn MsgFlags {notification :: Bool
notification = Bool
True} NonEmpty SndMessage
msgs'
    ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ((Connection -> NonEmpty (IO ()))
    -> ReaderT ChatController IO ())
-> (Connection -> NonEmpty (IO ()))
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()))
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> NonEmpty (IO ()))
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> (SndMessage -> IO ()) -> NonEmpty SndMessage -> NonEmpty (IO ())
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\SndMessage {UserId
msgId :: SndMessage -> UserId
msgId :: UserId
msgId} -> Connection -> UserId -> UserId -> IO ()
deletePendingGroupMessage Connection
db UserId
groupMemberId UserId
msgId) NonEmpty SndMessage
msgs'

saveDirectRcvMSG :: MsgEncodingI e => Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (Connection, RcvMessage)
saveDirectRcvMSG :: forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> MsgMeta
-> ByteString
-> ChatMessage e
-> CM (Connection, RcvMessage)
saveDirectRcvMSG conn :: Connection
conn@Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId} MsgMeta
agentMsgMeta ByteString
msgBody ChatMessage {VersionRangeChat
chatVRange :: forall (e :: MsgEncoding). ChatMessage e -> VersionRangeChat
chatVRange :: VersionRangeChat
chatVRange, msgId :: forall (e :: MsgEncoding). ChatMessage e -> Maybe SharedMsgId
msgId = Maybe SharedMsgId
sharedMsgId_, ChatMsgEvent e
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent} = do
  Connection
conn' <- Connection -> VersionRangeChat -> CM Connection
updatePeerChatVRange Connection
conn VersionRangeChat
chatVRange
  let agentMsgId :: UserId
agentMsgId = (UserId, UTCTime) -> UserId
forall a b. (a, b) -> a
fst ((UserId, UTCTime) -> UserId) -> (UserId, UTCTime) -> UserId
forall a b. (a -> b) -> a -> b
$ MsgMeta -> (UserId, UTCTime)
recipient MsgMeta
agentMsgMeta
      brokerTs :: UTCTime
brokerTs = MsgMeta -> UTCTime
metaBrokerTs MsgMeta
agentMsgMeta
      newMsg :: NewRcvMessage e
newMsg = NewRcvMessage {ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent, ByteString
msgBody :: ByteString
msgBody :: ByteString
msgBody, UTCTime
brokerTs :: UTCTime
brokerTs :: UTCTime
brokerTs}
      rcvMsgDelivery :: RcvMsgDelivery
rcvMsgDelivery = RcvMsgDelivery {UserId
connId :: UserId
connId :: UserId
connId, UserId
agentMsgId :: UserId
agentMsgId :: UserId
agentMsgId, MsgMeta
agentMsgMeta :: MsgMeta
agentMsgMeta :: MsgMeta
agentMsgMeta}
  RcvMessage
msg <- (Connection -> ExceptT StoreError IO RcvMessage) -> CM RcvMessage
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore ((Connection -> ExceptT StoreError IO RcvMessage) -> CM RcvMessage)
-> (Connection -> ExceptT StoreError IO RcvMessage)
-> CM RcvMessage
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ConnOrGroupId
-> NewRcvMessage e
-> Maybe SharedMsgId
-> RcvMsgDelivery
-> Maybe UserId
-> ExceptT StoreError IO RcvMessage
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ConnOrGroupId
-> NewRcvMessage e
-> Maybe SharedMsgId
-> RcvMsgDelivery
-> Maybe UserId
-> ExceptT StoreError IO RcvMessage
createNewMessageAndRcvMsgDelivery Connection
db (UserId -> ConnOrGroupId
ConnectionId UserId
connId) NewRcvMessage e
newMsg Maybe SharedMsgId
sharedMsgId_ RcvMsgDelivery
rcvMsgDelivery Maybe UserId
forall a. Maybe a
Nothing
  (Connection, RcvMessage) -> CM (Connection, RcvMessage)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Connection
conn', RcvMessage
msg)

saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (GroupMember, Connection, RcvMessage)
saveGroupRcvMsg :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> UserId
-> GroupMember
-> Connection
-> MsgMeta
-> ByteString
-> ChatMessage e
-> CM (GroupMember, Connection, RcvMessage)
saveGroupRcvMsg User
user UserId
groupId GroupMember
authorMember conn :: Connection
conn@Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId} MsgMeta
agentMsgMeta ByteString
msgBody ChatMessage {VersionRangeChat
chatVRange :: forall (e :: MsgEncoding). ChatMessage e -> VersionRangeChat
chatVRange :: VersionRangeChat
chatVRange, msgId :: forall (e :: MsgEncoding). ChatMessage e -> Maybe SharedMsgId
msgId = Maybe SharedMsgId
sharedMsgId_, ChatMsgEvent e
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent} = do
  (am' :: GroupMember
am'@GroupMember {memberId :: GroupMember -> MemberId
memberId = MemberId
amMemId, groupMemberId :: GroupMember -> UserId
groupMemberId = UserId
amGroupMemId}, Connection
conn') <- GroupMember
-> Connection -> VersionRangeChat -> CM (GroupMember, Connection)
updateMemberChatVRange GroupMember
authorMember Connection
conn VersionRangeChat
chatVRange
  let agentMsgId :: UserId
agentMsgId = (UserId, UTCTime) -> UserId
forall a b. (a, b) -> a
fst ((UserId, UTCTime) -> UserId) -> (UserId, UTCTime) -> UserId
forall a b. (a -> b) -> a -> b
$ MsgMeta -> (UserId, UTCTime)
recipient MsgMeta
agentMsgMeta
      brokerTs :: UTCTime
brokerTs = MsgMeta -> UTCTime
metaBrokerTs MsgMeta
agentMsgMeta
      newMsg :: NewRcvMessage e
newMsg = NewRcvMessage {ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent, ByteString
msgBody :: ByteString
msgBody :: ByteString
msgBody, UTCTime
brokerTs :: UTCTime
brokerTs :: UTCTime
brokerTs}
      rcvMsgDelivery :: RcvMsgDelivery
rcvMsgDelivery = RcvMsgDelivery {UserId
connId :: UserId
connId :: UserId
connId, UserId
agentMsgId :: UserId
agentMsgId :: UserId
agentMsgId, MsgMeta
agentMsgMeta :: MsgMeta
agentMsgMeta :: MsgMeta
agentMsgMeta}
  RcvMessage
msg <-
    (Connection -> ExceptT StoreError IO RcvMessage) -> CM RcvMessage
forall a. (Connection -> ExceptT StoreError IO a) -> CM a
withStore (\Connection
db -> Connection
-> ConnOrGroupId
-> NewRcvMessage e
-> Maybe SharedMsgId
-> RcvMsgDelivery
-> Maybe UserId
-> ExceptT StoreError IO RcvMessage
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ConnOrGroupId
-> NewRcvMessage e
-> Maybe SharedMsgId
-> RcvMsgDelivery
-> Maybe UserId
-> ExceptT StoreError IO RcvMessage
createNewMessageAndRcvMsgDelivery Connection
db (UserId -> ConnOrGroupId
GroupId UserId
groupId) NewRcvMessage e
newMsg Maybe SharedMsgId
sharedMsgId_ RcvMsgDelivery
rcvMsgDelivery (Maybe UserId -> ExceptT StoreError IO RcvMessage)
-> Maybe UserId -> ExceptT StoreError IO RcvMessage
forall a b. (a -> b) -> a -> b
$ UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
amGroupMemId)
      CM RcvMessage -> (ChatError -> CM RcvMessage) -> CM RcvMessage
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` \ChatError
e -> case ChatError
e of
        ChatErrorStore (SEDuplicateGroupMessage UserId
_ SharedMsgId
_ Maybe UserId
_ (Just UserId
forwardedByGroupMemberId)) -> do
          VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
          GroupMember
fm <- (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
-> UserId
-> UserId
-> ExceptT StoreError IO GroupMember
getGroupMember Connection
db VersionRangeChat
vr User
user UserId
groupId UserId
forwardedByGroupMemberId
          Maybe Connection
-> (Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GroupMember -> Maybe Connection
memberConn GroupMember
fm) ((Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
fmConn ->
            ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, UserId, PQEncryption)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
sendDirectMemberMessage Connection
fmConn (MemberId -> ChatMsgEvent 'Json
XGrpMemCon MemberId
amMemId) UserId
groupId
          ChatError -> CM RcvMessage
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
e
        ChatError
_ -> ChatError -> CM RcvMessage
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
e
  (GroupMember, Connection, RcvMessage)
-> CM (GroupMember, Connection, RcvMessage)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupMember
am', Connection
conn', RcvMessage
msg)

saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> UTCTime -> CM (Maybe RcvMessage)
saveGroupFwdRcvMsg :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> GroupInfo
-> GroupMember
-> GroupMember
-> ByteString
-> ChatMessage e
-> UTCTime
-> CM (Maybe RcvMessage)
saveGroupFwdRcvMsg User
user GroupInfo {UserId
groupId :: GroupInfo -> UserId
groupId :: UserId
groupId, BoolDef
useRelays :: GroupInfo -> BoolDef
useRelays :: BoolDef
useRelays} GroupMember
forwardingMember refAuthorMember :: GroupMember
refAuthorMember@GroupMember {memberId :: GroupMember -> MemberId
memberId = MemberId
refMemberId} ByteString
msgBody ChatMessage {msgId :: forall (e :: MsgEncoding). ChatMessage e -> Maybe SharedMsgId
msgId = Maybe SharedMsgId
sharedMsgId_, ChatMsgEvent e
chatMsgEvent :: forall (e :: MsgEncoding). ChatMessage e -> ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent} UTCTime
brokerTs = do
  let newMsg :: NewRcvMessage e
newMsg = NewRcvMessage {ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent :: ChatMsgEvent e
chatMsgEvent, ByteString
msgBody :: ByteString
msgBody :: ByteString
msgBody, UTCTime
brokerTs :: UTCTime
brokerTs :: UTCTime
brokerTs}
      fwdMemberId :: Maybe UserId
fwdMemberId = UserId -> Maybe UserId
forall a. a -> Maybe a
Just (UserId -> Maybe UserId) -> UserId -> Maybe UserId
forall a b. (a -> b) -> a -> b
$ GroupMember -> UserId
groupMemberId' GroupMember
forwardingMember
      refAuthorId :: Maybe UserId
refAuthorId = UserId -> Maybe UserId
forall a. a -> Maybe a
Just (UserId -> Maybe UserId) -> UserId -> Maybe UserId
forall a b. (a -> b) -> a -> b
$ GroupMember -> UserId
groupMemberId' GroupMember
refAuthorMember
  -- TODO [channels fwd] TBC highlighting difference between deduplicated messages (useRelays branch)
  (Connection -> IO (Either StoreError RcvMessage))
-> CM (Either StoreError RcvMessage)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> ExceptT StoreError IO RcvMessage
-> IO (Either StoreError RcvMessage)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError IO RcvMessage
 -> IO (Either StoreError RcvMessage))
-> ExceptT StoreError IO RcvMessage
-> IO (Either StoreError RcvMessage)
forall a b. (a -> b) -> a -> b
$ Connection
-> ConnOrGroupId
-> NewRcvMessage e
-> Maybe SharedMsgId
-> Maybe UserId
-> Maybe UserId
-> ExceptT StoreError IO RcvMessage
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ConnOrGroupId
-> NewRcvMessage e
-> Maybe SharedMsgId
-> Maybe UserId
-> Maybe UserId
-> ExceptT StoreError IO RcvMessage
createNewRcvMessage Connection
db (UserId -> ConnOrGroupId
GroupId UserId
groupId) NewRcvMessage e
newMsg Maybe SharedMsgId
sharedMsgId_ Maybe UserId
refAuthorId Maybe UserId
fwdMemberId) CM (Either StoreError RcvMessage)
-> (Either StoreError RcvMessage -> CM (Maybe RcvMessage))
-> CM (Maybe RcvMessage)
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 RcvMessage
msg -> Maybe RcvMessage -> CM (Maybe RcvMessage)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RcvMessage -> CM (Maybe RcvMessage))
-> Maybe RcvMessage -> CM (Maybe RcvMessage)
forall a b. (a -> b) -> a -> b
$ RcvMessage -> Maybe RcvMessage
forall a. a -> Maybe a
Just RcvMessage
msg
    Left e :: StoreError
e@SEDuplicateGroupMessage {Maybe UserId
authorGroupMemberId :: Maybe UserId
authorGroupMemberId :: StoreError -> Maybe UserId
authorGroupMemberId, Maybe UserId
forwardedByGroupMemberId :: Maybe UserId
forwardedByGroupMemberId :: StoreError -> Maybe UserId
forwardedByGroupMemberId}
      | BoolDef -> Bool
isTrue BoolDef
useRelays -> Maybe RcvMessage -> CM (Maybe RcvMessage)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RcvMessage
forall a. Maybe a
Nothing -- with chat relays, duplicates are expected
      | Bool
otherwise -> case (Maybe UserId
authorGroupMemberId, Maybe UserId
forwardedByGroupMemberId) of
          (Just UserId
authorGMId, Maybe UserId
Nothing) -> do
            VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
            am :: GroupMember
am@GroupMember {memberId :: GroupMember -> MemberId
memberId = MemberId
amMemberId} <- (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
-> UserId
-> UserId
-> ExceptT StoreError IO GroupMember
getGroupMember Connection
db VersionRangeChat
vr User
user UserId
groupId UserId
authorGMId
            if MemberId -> GroupMember -> Bool
sameMemberId MemberId
refMemberId GroupMember
am
              then Maybe Connection
-> (Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GroupMember -> Maybe Connection
memberConn GroupMember
forwardingMember) ((Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
fmConn ->
                ExceptT
  ChatError
  (ReaderT ChatController IO)
  (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
   ChatError
   (ReaderT ChatController IO)
   (SndMessage, UserId, PQEncryption)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ Connection
-> ChatMsgEvent 'Json
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
forall (e :: MsgEncoding).
MsgEncodingI e =>
Connection
-> ChatMsgEvent e
-> UserId
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (SndMessage, UserId, PQEncryption)
sendDirectMemberMessage Connection
fmConn (MemberId -> ChatMsgEvent 'Json
XGrpMemCon MemberId
amMemberId) UserId
groupId
              else ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User -> ContactName -> ContactName -> ChatEvent
CEvtMessageError User
user ContactName
"error" ContactName
"saveGroupFwdRcvMsg: referenced author member id doesn't match message member id"
            ChatError -> CM (Maybe RcvMessage)
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> CM (Maybe RcvMessage))
-> ChatError -> CM (Maybe RcvMessage)
forall a b. (a -> b) -> a -> b
$ StoreError -> ChatError
ChatErrorStore StoreError
e
          (Maybe UserId, Maybe UserId)
_ -> ChatError -> CM (Maybe RcvMessage)
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> CM (Maybe RcvMessage))
-> ChatError -> CM (Maybe RcvMessage)
forall a b. (a -> b) -> a -> b
$ StoreError -> ChatError
ChatErrorStore StoreError
e
    Left StoreError
e -> ChatError -> CM (Maybe RcvMessage)
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChatError -> CM (Maybe RcvMessage))
-> ChatError -> CM (Maybe RcvMessage)
forall a b. (a -> b) -> a -> b
$ StoreError -> ChatError
ChatErrorStore StoreError
e

saveSndChatItem :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> CM (ChatItem c 'MDSnd)
saveSndChatItem :: forall (c :: ChatType).
ChatTypeI c =>
User
-> ChatDirection c 'MDSnd
-> SndMessage
-> CIContent 'MDSnd
-> CM (ChatItem c 'MDSnd)
saveSndChatItem User
user ChatDirection c 'MDSnd
cd SndMessage
msg CIContent 'MDSnd
content = User
-> ChatDirection c 'MDSnd
-> SndMessage
-> CIContent 'MDSnd
-> Maybe (CIFile 'MDSnd)
-> Maybe (CIQuote c)
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> CM (ChatItem c 'MDSnd)
forall (c :: ChatType).
ChatTypeI c =>
User
-> ChatDirection c 'MDSnd
-> SndMessage
-> CIContent 'MDSnd
-> Maybe (CIFile 'MDSnd)
-> Maybe (CIQuote c)
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> CM (ChatItem c 'MDSnd)
saveSndChatItem' User
user ChatDirection c 'MDSnd
cd SndMessage
msg CIContent 'MDSnd
content Maybe (CIFile 'MDSnd)
forall a. Maybe a
Nothing Maybe (CIQuote c)
forall a. Maybe a
Nothing Maybe CIForwardedFrom
forall a. Maybe a
Nothing Maybe CITimed
forall a. Maybe a
Nothing Bool
False

-- TODO [mentions] optimize by avoiding unnecesary parsing of control messages
saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd)
saveSndChatItem' :: forall (c :: ChatType).
ChatTypeI c =>
User
-> ChatDirection c 'MDSnd
-> SndMessage
-> CIContent 'MDSnd
-> Maybe (CIFile 'MDSnd)
-> Maybe (CIQuote c)
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> CM (ChatItem c 'MDSnd)
saveSndChatItem' User
user ChatDirection c 'MDSnd
cd SndMessage
msg CIContent 'MDSnd
content Maybe (CIFile 'MDSnd)
ciFile Maybe (CIQuote c)
quotedItem Maybe CIForwardedFrom
itemForwarded Maybe CITimed
itemTimed Bool
live = do
  let itemTexts :: (ContactName, Maybe MarkdownList)
itemTexts = CIContent 'MDSnd -> (ContactName, Maybe MarkdownList)
forall (d :: MsgDirection).
CIContent d -> (ContactName, Maybe MarkdownList)
ciContentTexts CIContent 'MDSnd
content
  User
-> ChatDirection c 'MDSnd
-> [Either ChatError (NewSndChatItemData c)]
-> Maybe CITimed
-> Bool
-> CM [Either ChatError (ChatItem c 'MDSnd)]
forall (c :: ChatType).
ChatTypeI c =>
User
-> ChatDirection c 'MDSnd
-> [Either ChatError (NewSndChatItemData c)]
-> Maybe CITimed
-> Bool
-> CM [Either ChatError (ChatItem c 'MDSnd)]
saveSndChatItems User
user ChatDirection c 'MDSnd
cd [NewSndChatItemData c -> Either ChatError (NewSndChatItemData c)
forall a b. b -> Either a b
Right NewSndChatItemData {SndMessage
msg :: SndMessage
msg :: SndMessage
msg, CIContent 'MDSnd
content :: CIContent 'MDSnd
content :: CIContent 'MDSnd
content, (ContactName, Maybe MarkdownList)
itemTexts :: (ContactName, Maybe MarkdownList)
itemTexts :: (ContactName, Maybe MarkdownList)
itemTexts, itemMentions :: Map ContactName CIMention
itemMentions = Map ContactName CIMention
forall k a. Map k a
M.empty, Maybe (CIFile 'MDSnd)
ciFile :: Maybe (CIFile 'MDSnd)
ciFile :: Maybe (CIFile 'MDSnd)
ciFile, Maybe (CIQuote c)
quotedItem :: Maybe (CIQuote c)
quotedItem :: Maybe (CIQuote c)
quotedItem, Maybe CIForwardedFrom
itemForwarded :: Maybe CIForwardedFrom
itemForwarded :: Maybe CIForwardedFrom
itemForwarded}] Maybe CITimed
itemTimed Bool
live CM [Either ChatError (ChatItem c 'MDSnd)]
-> ([Either ChatError (ChatItem c 'MDSnd)]
    -> CM (ChatItem c 'MDSnd))
-> CM (ChatItem c 'MDSnd)
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 ChatItem c 'MDSnd
ci] -> ChatItem c 'MDSnd -> CM (ChatItem c 'MDSnd)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChatItem c 'MDSnd
ci
    [Either ChatError (ChatItem c 'MDSnd)]
_ -> ChatErrorType -> CM (ChatItem c 'MDSnd)
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType -> CM (ChatItem c 'MDSnd))
-> ChatErrorType -> CM (ChatItem c 'MDSnd)
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError String
"saveSndChatItem': expected 1 item"

data NewSndChatItemData c = NewSndChatItemData
  { forall (c :: ChatType). NewSndChatItemData c -> SndMessage
msg :: SndMessage,
    forall (c :: ChatType). NewSndChatItemData c -> CIContent 'MDSnd
content :: CIContent 'MDSnd,
    forall (c :: ChatType).
NewSndChatItemData c -> (ContactName, Maybe MarkdownList)
itemTexts :: (Text, Maybe MarkdownList),
    forall (c :: ChatType).
NewSndChatItemData c -> Map ContactName CIMention
itemMentions :: Map MemberName CIMention,
    forall (c :: ChatType).
NewSndChatItemData c -> Maybe (CIFile 'MDSnd)
ciFile :: Maybe (CIFile 'MDSnd),
    forall (c :: ChatType). NewSndChatItemData c -> Maybe (CIQuote c)
quotedItem :: Maybe (CIQuote c),
    forall (c :: ChatType).
NewSndChatItemData c -> Maybe CIForwardedFrom
itemForwarded :: Maybe CIForwardedFrom
  }

saveSndChatItems ::
  forall c.
  ChatTypeI c =>
  User ->
  ChatDirection c 'MDSnd ->
  [Either ChatError (NewSndChatItemData c)] ->
  Maybe CITimed ->
  Bool ->
  CM [Either ChatError (ChatItem c 'MDSnd)]
saveSndChatItems :: forall (c :: ChatType).
ChatTypeI c =>
User
-> ChatDirection c 'MDSnd
-> [Either ChatError (NewSndChatItemData c)]
-> Maybe CITimed
-> Bool
-> CM [Either ChatError (ChatItem c 'MDSnd)]
saveSndChatItems User
user ChatDirection c 'MDSnd
cd [Either ChatError (NewSndChatItemData c)]
itemsData Maybe CITimed
itemTimed Bool
live = do
  UTCTime
createdAt <- 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
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ChatDirection c 'MDSnd -> Bool
forall (c :: ChatType) (d :: MsgDirection).
ChatDirection c d -> Bool
contactChatDeleted ChatDirection c 'MDSnd
cd Bool -> Bool -> Bool
|| (NewSndChatItemData c -> Bool) -> [NewSndChatItemData c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\NewSndChatItemData {CIContent 'MDSnd
content :: forall (c :: ChatType). NewSndChatItemData c -> CIContent 'MDSnd
content :: CIContent 'MDSnd
content} -> CIContent 'MDSnd -> Bool
forall (d :: MsgDirection). MsgDirectionI d => CIContent d -> Bool
ciRequiresAttention CIContent 'MDSnd
content) ([Either ChatError (NewSndChatItemData c)] -> [NewSndChatItemData c]
forall a b. [Either a b] -> [b]
rights [Either ChatError (NewSndChatItemData c)]
itemsData)) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$
    ExceptT ChatError (ReaderT ChatController IO) (ChatInfo c)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) (ChatInfo c)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) (ChatInfo c)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ (Connection -> IO (ChatInfo c))
-> ExceptT ChatError (ReaderT ChatController IO) (ChatInfo c)
forall a. (Connection -> IO a) -> CM a
withStore' (\Connection
db -> Connection
-> VersionRangeChat
-> User
-> ChatDirection c 'MDSnd
-> UTCTime
-> Maybe (Int, MemberAttention, Int)
-> IO (ChatInfo c)
forall (c :: ChatType) (d :: MsgDirection).
Connection
-> VersionRangeChat
-> User
-> ChatDirection c d
-> UTCTime
-> Maybe (Int, MemberAttention, Int)
-> IO (ChatInfo c)
updateChatTsStats Connection
db VersionRangeChat
vr User
user ChatDirection c 'MDSnd
cd UTCTime
createdAt Maybe (Int, MemberAttention, Int)
forall a. Maybe a
Nothing)
  ReaderT ChatController IO [Either ChatError (ChatItem c 'MDSnd)]
-> CM [Either ChatError (ChatItem c 'MDSnd)]
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 [Either ChatError (ChatItem c 'MDSnd)]
 -> CM [Either ChatError (ChatItem c 'MDSnd)])
-> ReaderT ChatController IO [Either ChatError (ChatItem c 'MDSnd)]
-> CM [Either ChatError (ChatItem c 'MDSnd)]
forall a b. (a -> b) -> a -> b
$ (Connection -> [IO (Either ChatError (ChatItem c 'MDSnd))])
-> ReaderT ChatController IO [Either ChatError (ChatItem c 'MDSnd)]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO (Either ChatError a)))
-> CM' (t (Either ChatError a))
withStoreBatch (\Connection
db -> (Either ChatError (NewSndChatItemData c)
 -> IO (Either ChatError (ChatItem c 'MDSnd)))
-> [Either ChatError (NewSndChatItemData c)]
-> [IO (Either ChatError (ChatItem c 'MDSnd))]
forall a b. (a -> b) -> [a] -> [b]
map ((NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd)))
-> Either ChatError (NewSndChatItemData c)
-> IO (Either ChatError (ChatItem c 'MDSnd))
forall (m :: * -> *) a e b.
Monad m =>
(a -> m (Either e b)) -> Either e a -> m (Either e b)
bindRight ((NewSndChatItemData c
  -> IO (Either ChatError (ChatItem c 'MDSnd)))
 -> Either ChatError (NewSndChatItemData c)
 -> IO (Either ChatError (ChatItem c 'MDSnd)))
-> (NewSndChatItemData c
    -> IO (Either ChatError (ChatItem c 'MDSnd)))
-> Either ChatError (NewSndChatItemData c)
-> IO (Either ChatError (ChatItem c 'MDSnd))
forall a b. (a -> b) -> a -> b
$ Connection
-> UTCTime
-> NewSndChatItemData c
-> IO (Either ChatError (ChatItem c 'MDSnd))
createItem Connection
db UTCTime
createdAt) [Either ChatError (NewSndChatItemData c)]
itemsData)
  where
    createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd))
    createItem :: Connection
-> UTCTime
-> NewSndChatItemData c
-> IO (Either ChatError (ChatItem c 'MDSnd))
createItem Connection
db UTCTime
createdAt NewSndChatItemData {msg :: forall (c :: ChatType). NewSndChatItemData c -> SndMessage
msg = msg :: SndMessage
msg@SndMessage {SharedMsgId
sharedMsgId :: SharedMsgId
sharedMsgId :: SndMessage -> SharedMsgId
sharedMsgId}, CIContent 'MDSnd
content :: forall (c :: ChatType). NewSndChatItemData c -> CIContent 'MDSnd
content :: CIContent 'MDSnd
content, (ContactName, Maybe MarkdownList)
itemTexts :: forall (c :: ChatType).
NewSndChatItemData c -> (ContactName, Maybe MarkdownList)
itemTexts :: (ContactName, Maybe MarkdownList)
itemTexts, Map ContactName CIMention
itemMentions :: forall (c :: ChatType).
NewSndChatItemData c -> Map ContactName CIMention
itemMentions :: Map ContactName CIMention
itemMentions, Maybe (CIFile 'MDSnd)
ciFile :: forall (c :: ChatType).
NewSndChatItemData c -> Maybe (CIFile 'MDSnd)
ciFile :: Maybe (CIFile 'MDSnd)
ciFile, Maybe (CIQuote c)
quotedItem :: forall (c :: ChatType). NewSndChatItemData c -> Maybe (CIQuote c)
quotedItem :: Maybe (CIQuote c)
quotedItem, Maybe CIForwardedFrom
itemForwarded :: forall (c :: ChatType).
NewSndChatItemData c -> Maybe CIForwardedFrom
itemForwarded :: Maybe CIForwardedFrom
itemForwarded} = do
      UserId
ciId <- Connection
-> User
-> ChatDirection c 'MDSnd
-> SndMessage
-> CIContent 'MDSnd
-> Maybe (CIQuote c)
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> UTCTime
-> IO UserId
forall (c :: ChatType).
Connection
-> User
-> ChatDirection c 'MDSnd
-> SndMessage
-> CIContent 'MDSnd
-> Maybe (CIQuote c)
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> UTCTime
-> IO UserId
createNewSndChatItem Connection
db User
user ChatDirection c 'MDSnd
cd SndMessage
msg CIContent 'MDSnd
content Maybe (CIQuote c)
quotedItem Maybe CIForwardedFrom
itemForwarded Maybe CITimed
itemTimed Bool
live UTCTime
createdAt
      Maybe (CIFile 'MDSnd) -> (CIFile 'MDSnd -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (CIFile 'MDSnd)
ciFile ((CIFile 'MDSnd -> IO ()) -> IO ())
-> (CIFile 'MDSnd -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CIFile {UserId
fileId :: forall (d :: MsgDirection). CIFile d -> UserId
fileId :: UserId
fileId} -> Connection -> UserId -> UserId -> UTCTime -> IO ()
updateFileTransferChatItemId Connection
db UserId
fileId UserId
ciId UTCTime
createdAt
      let ci :: ChatItem c 'MDSnd
ci = ChatDirection c 'MDSnd
-> Bool
-> UserId
-> CIContent 'MDSnd
-> (ContactName, Maybe MarkdownList)
-> Maybe (CIFile 'MDSnd)
-> Maybe (CIQuote c)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem c 'MDSnd
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
ChatDirection c d
-> Bool
-> UserId
-> CIContent d
-> (ContactName, Maybe MarkdownList)
-> Maybe (CIFile d)
-> Maybe (CIQuote c)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem c d
mkChatItem_ ChatDirection c 'MDSnd
cd Bool
False UserId
ciId CIContent 'MDSnd
content (ContactName, Maybe MarkdownList)
itemTexts Maybe (CIFile 'MDSnd)
ciFile Maybe (CIQuote c)
quotedItem (SharedMsgId -> Maybe SharedMsgId
forall a. a -> Maybe a
Just SharedMsgId
sharedMsgId) Maybe CIForwardedFrom
itemForwarded Maybe CITimed
itemTimed Bool
live Bool
False UTCTime
createdAt Maybe UserId
forall a. Maybe a
Nothing UTCTime
createdAt
      ChatItem c 'MDSnd -> Either ChatError (ChatItem c 'MDSnd)
forall a b. b -> Either a b
Right (ChatItem c 'MDSnd -> Either ChatError (ChatItem c 'MDSnd))
-> IO (ChatItem c 'MDSnd)
-> IO (Either ChatError (ChatItem c 'MDSnd))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case ChatDirection c 'MDSnd
cd of
        CDGroupSnd GroupInfo
g Maybe GroupChatScopeInfo
_scope | Bool -> Bool
not (Map ContactName CIMention -> Bool
forall a. Map ContactName a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map ContactName CIMention
itemMentions) -> Connection
-> GroupInfo
-> ChatItem 'CTGroup 'MDSnd
-> Map ContactName CIMention
-> IO (ChatItem 'CTGroup 'MDSnd)
forall (d :: MsgDirection).
Connection
-> GroupInfo
-> ChatItem 'CTGroup d
-> Map ContactName CIMention
-> IO (ChatItem 'CTGroup d)
createGroupCIMentions Connection
db GroupInfo
g ChatItem c 'MDSnd
ChatItem 'CTGroup 'MDSnd
ci Map ContactName CIMention
itemMentions
        ChatDirection c 'MDSnd
_ -> ChatItem c 'MDSnd -> IO (ChatItem c 'MDSnd)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChatItem c 'MDSnd
ci

saveRcvChatItemNoParse :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItemNoParse :: 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 c 'MDRcv
cd RcvMessage
msg UTCTime
brokerTs = User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> (CIContent 'MDRcv, (ContactName, Maybe MarkdownList))
-> CM (ChatItem c 'MDRcv, ChatInfo c)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> (CIContent 'MDRcv, (ContactName, Maybe MarkdownList))
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem User
user ChatDirection c 'MDRcv
cd RcvMessage
msg UTCTime
brokerTs ((CIContent 'MDRcv, (ContactName, Maybe MarkdownList))
 -> CM (ChatItem c 'MDRcv, ChatInfo c))
-> (CIContent 'MDRcv
    -> (CIContent 'MDRcv, (ContactName, Maybe MarkdownList)))
-> CIContent 'MDRcv
-> CM (ChatItem c 'MDRcv, ChatInfo c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CIContent 'MDRcv
-> (CIContent 'MDRcv, (ContactName, Maybe MarkdownList))
ciContentNoParse

saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem :: forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> UTCTime
-> (CIContent 'MDRcv, (ContactName, Maybe MarkdownList))
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem User
user ChatDirection c 'MDRcv
cd msg :: RcvMessage
msg@RcvMessage {Maybe SharedMsgId
sharedMsgId_ :: Maybe SharedMsgId
sharedMsgId_ :: RcvMessage -> Maybe SharedMsgId
sharedMsgId_} UTCTime
brokerTs (CIContent 'MDRcv, (ContactName, Maybe MarkdownList))
content =
  User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (ContactName, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map ContactName MsgMention
-> CM (ChatItem c 'MDRcv, ChatInfo c)
forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (ContactName, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map ContactName MsgMention
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' User
user ChatDirection c 'MDRcv
cd RcvMessage
msg Maybe SharedMsgId
sharedMsgId_ UTCTime
brokerTs (CIContent 'MDRcv, (ContactName, Maybe MarkdownList))
content Maybe (CIFile 'MDRcv)
forall a. Maybe a
Nothing Maybe CITimed
forall a. Maybe a
Nothing Bool
False Map ContactName MsgMention
forall k a. Map k a
M.empty

ciContentNoParse :: CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
ciContentNoParse :: CIContent 'MDRcv
-> (CIContent 'MDRcv, (ContactName, Maybe MarkdownList))
ciContentNoParse CIContent 'MDRcv
content = (CIContent 'MDRcv
content, (CIContent 'MDRcv -> ContactName
forall (d :: MsgDirection). CIContent d -> ContactName
ciContentToText CIContent 'MDRcv
content, Maybe MarkdownList
forall a. Maybe a
Nothing))

saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' :: forall (c :: ChatType).
(ChatTypeI c, ChatTypeQuotable c) =>
User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> UTCTime
-> (CIContent 'MDRcv, (ContactName, Maybe MarkdownList))
-> Maybe (CIFile 'MDRcv)
-> Maybe CITimed
-> Bool
-> Map ContactName MsgMention
-> CM (ChatItem c 'MDRcv, ChatInfo c)
saveRcvChatItem' User
user ChatDirection c 'MDRcv
cd msg :: RcvMessage
msg@RcvMessage {AChatMsgEvent
chatMsgEvent :: AChatMsgEvent
chatMsgEvent :: RcvMessage -> AChatMsgEvent
chatMsgEvent, Maybe UserId
forwardedByMember :: Maybe UserId
forwardedByMember :: RcvMessage -> Maybe UserId
forwardedByMember} Maybe SharedMsgId
sharedMsgId_ UTCTime
brokerTs (CIContent 'MDRcv
content, (ContactName
t, Maybe MarkdownList
ft_)) Maybe (CIFile 'MDRcv)
ciFile Maybe CITimed
itemTimed Bool
live Map ContactName MsgMention
mentions = do
  UTCTime
createdAt <- 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
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  (Connection -> IO (ChatItem c 'MDRcv, ChatInfo c))
-> CM (ChatItem c 'MDRcv, ChatInfo c)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (ChatItem c 'MDRcv, ChatInfo c))
 -> CM (ChatItem c 'MDRcv, ChatInfo c))
-> (Connection -> IO (ChatItem c 'MDRcv, ChatInfo c))
-> CM (ChatItem c 'MDRcv, ChatInfo c)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> do
    (Map ContactName CIMention
mentions' :: Map MemberName CIMention, Bool
userMention) <- case ChatDirection c 'MDRcv
cd of
      CDGroupRcv g :: GroupInfo
g@GroupInfo {GroupMember
membership :: GroupInfo -> GroupMember
membership :: GroupMember
membership} Maybe GroupChatScopeInfo
_scope GroupMember
_m -> do
        Map ContactName CIMention
mentions' <- Connection
-> User
-> GroupInfo
-> Maybe MarkdownList
-> Map ContactName MsgMention
-> IO (Map ContactName CIMention)
getRcvCIMentions Connection
db User
user GroupInfo
g Maybe MarkdownList
ft_ Map ContactName MsgMention
mentions
        let userReply :: Bool
userReply = case AChatMsgEvent -> Maybe QuotedMsg
cmToQuotedMsg AChatMsgEvent
chatMsgEvent of
              Just QuotedMsg {msgRef :: QuotedMsg -> MsgRef
msgRef = MsgRef {memberId :: MsgRef -> Maybe MemberId
memberId = Just MemberId
mId}} -> MemberId -> GroupMember -> Bool
sameMemberId MemberId
mId GroupMember
membership
              Maybe QuotedMsg
_ -> Bool
False
            userMention' :: Bool
userMention' = Bool
userReply Bool -> Bool -> Bool
|| (CIMention -> Bool) -> Map ContactName CIMention -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\CIMention {MemberId
memberId :: CIMention -> MemberId
memberId :: MemberId
memberId} -> MemberId -> GroupMember -> Bool
sameMemberId MemberId
memberId GroupMember
membership) Map ContactName CIMention
mentions'
         in (Map ContactName CIMention, Bool)
-> IO (Map ContactName CIMention, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ContactName CIMention
mentions', Bool
userMention')
      CDDirectRcv Contact
_ -> (Map ContactName CIMention, Bool)
-> IO (Map ContactName CIMention, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ContactName CIMention
forall k a. Map k a
M.empty, Bool
False)
    ChatInfo c
cInfo' <- if (CIContent 'MDRcv -> Bool
forall (d :: MsgDirection). MsgDirectionI d => CIContent d -> Bool
ciRequiresAttention CIContent 'MDRcv
content Bool -> Bool -> Bool
|| ChatDirection c 'MDRcv -> Bool
forall (c :: ChatType) (d :: MsgDirection).
ChatDirection c d -> Bool
contactChatDeleted ChatDirection c 'MDRcv
cd)
      then Connection
-> VersionRangeChat
-> User
-> ChatDirection c 'MDRcv
-> UTCTime
-> Maybe (Int, MemberAttention, Int)
-> IO (ChatInfo c)
forall (c :: ChatType) (d :: MsgDirection).
Connection
-> VersionRangeChat
-> User
-> ChatDirection c d
-> UTCTime
-> Maybe (Int, MemberAttention, Int)
-> IO (ChatInfo c)
updateChatTsStats Connection
db VersionRangeChat
vr User
user ChatDirection c 'MDRcv
cd UTCTime
createdAt (Bool -> Maybe (Int, MemberAttention, Int)
memberChatStats Bool
userMention)
      else ChatInfo c -> IO (ChatInfo c)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatInfo c -> IO (ChatInfo c)) -> ChatInfo c -> IO (ChatInfo c)
forall a b. (a -> b) -> a -> b
$ ChatDirection c 'MDRcv -> ChatInfo c
forall (c :: ChatType) (d :: MsgDirection).
ChatDirection c d -> ChatInfo c
toChatInfo ChatDirection c 'MDRcv
cd
    (UserId
ciId, Maybe (CIQuote c)
quotedItem, Maybe CIForwardedFrom
itemForwarded) <- Connection
-> User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> CIContent 'MDRcv
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> UTCTime
-> IO (UserId, Maybe (CIQuote c), Maybe CIForwardedFrom)
forall (c :: ChatType).
ChatTypeQuotable c =>
Connection
-> User
-> ChatDirection c 'MDRcv
-> RcvMessage
-> Maybe SharedMsgId
-> CIContent 'MDRcv
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> UTCTime
-> IO (UserId, Maybe (CIQuote c), Maybe CIForwardedFrom)
createNewRcvChatItem Connection
db User
user ChatDirection c 'MDRcv
cd RcvMessage
msg Maybe SharedMsgId
sharedMsgId_ CIContent 'MDRcv
content Maybe CITimed
itemTimed Bool
live Bool
userMention UTCTime
brokerTs UTCTime
createdAt
    Maybe (CIFile 'MDRcv) -> (CIFile 'MDRcv -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (CIFile 'MDRcv)
ciFile ((CIFile 'MDRcv -> IO ()) -> IO ())
-> (CIFile 'MDRcv -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CIFile {UserId
fileId :: forall (d :: MsgDirection). CIFile d -> UserId
fileId :: UserId
fileId} -> Connection -> UserId -> UserId -> UTCTime -> IO ()
updateFileTransferChatItemId Connection
db UserId
fileId UserId
ciId UTCTime
createdAt
    let ci :: ChatItem c 'MDRcv
ci = ChatDirection c 'MDRcv
-> Bool
-> UserId
-> CIContent 'MDRcv
-> (ContactName, Maybe MarkdownList)
-> Maybe (CIFile 'MDRcv)
-> Maybe (CIQuote c)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem c 'MDRcv
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
ChatDirection c d
-> Bool
-> UserId
-> CIContent d
-> (ContactName, Maybe MarkdownList)
-> Maybe (CIFile d)
-> Maybe (CIQuote c)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem c d
mkChatItem_ ChatDirection c 'MDRcv
cd Bool
False UserId
ciId CIContent 'MDRcv
content (ContactName
t, Maybe MarkdownList
ft_) Maybe (CIFile 'MDRcv)
ciFile Maybe (CIQuote c)
quotedItem Maybe SharedMsgId
sharedMsgId_ Maybe CIForwardedFrom
itemForwarded Maybe CITimed
itemTimed Bool
live Bool
userMention UTCTime
brokerTs Maybe UserId
forwardedByMember UTCTime
createdAt
    ChatItem c 'MDRcv
ci' <- case ChatDirection c 'MDRcv
cd of
      CDGroupRcv GroupInfo
g Maybe GroupChatScopeInfo
_scope GroupMember
_m | Bool -> Bool
not (Map ContactName CIMention -> Bool
forall a. Map ContactName a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map ContactName CIMention
mentions') -> Connection
-> GroupInfo
-> ChatItem 'CTGroup 'MDRcv
-> Map ContactName CIMention
-> IO (ChatItem 'CTGroup 'MDRcv)
forall (d :: MsgDirection).
Connection
-> GroupInfo
-> ChatItem 'CTGroup d
-> Map ContactName CIMention
-> IO (ChatItem 'CTGroup d)
createGroupCIMentions Connection
db GroupInfo
g ChatItem c 'MDRcv
ChatItem 'CTGroup 'MDRcv
ci Map ContactName CIMention
mentions'
      ChatDirection c 'MDRcv
_ -> ChatItem c 'MDRcv -> IO (ChatItem c 'MDRcv)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChatItem c 'MDRcv
ci
    (ChatItem c 'MDRcv, ChatInfo c)
-> IO (ChatItem c 'MDRcv, ChatInfo c)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatItem c 'MDRcv
ci', ChatInfo c
cInfo')
  where
    memberChatStats :: Bool -> Maybe (Int, MemberAttention, Int)
    memberChatStats :: Bool -> Maybe (Int, MemberAttention, Int)
memberChatStats Bool
userMention = case ChatDirection c 'MDRcv
cd of
      CDGroupRcv GroupInfo
_g (Just GroupChatScopeInfo
scope) GroupMember
m -> do
        let unread :: Int
unread = Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ CIContent 'MDRcv -> CIStatus 'MDRcv
forall (d :: MsgDirection).
MsgDirectionI d =>
CIContent d -> CIStatus d
ciCreateStatus CIContent 'MDRcv
content CIStatus 'MDRcv -> CIStatus 'MDRcv -> Bool
forall a. Eq a => a -> a -> Bool
== CIStatus 'MDRcv
CISRcvNew
         in (Int, MemberAttention, Int) -> Maybe (Int, MemberAttention, Int)
forall a. a -> Maybe a
Just (Int
unread, Int
-> Maybe UTCTime
-> GroupMember
-> GroupChatScopeInfo
-> MemberAttention
memberAttentionChange Int
unread (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
brokerTs) GroupMember
m GroupChatScopeInfo
scope, Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
userMention)
      ChatDirection c 'MDRcv
_ -> Maybe (Int, MemberAttention, Int)
forall a. Maybe a
Nothing

-- TODO [mentions] optimize by avoiding unnecessary parsing
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
mkChatItem :: forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
ChatDirection c d
-> Bool
-> UserId
-> CIContent d
-> Maybe (CIFile d)
-> Maybe (CIQuote c)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem c d
mkChatItem ChatDirection c d
cd Bool
showGroupAsSender UserId
ciId CIContent d
content Maybe (CIFile d)
file Maybe (CIQuote c)
quotedItem Maybe SharedMsgId
sharedMsgId Maybe CIForwardedFrom
itemForwarded Maybe CITimed
itemTimed Bool
live Bool
userMention UTCTime
itemTs Maybe UserId
forwardedByMember UTCTime
currentTs =
  let ts :: (ContactName, Maybe MarkdownList)
ts = CIContent d -> (ContactName, Maybe MarkdownList)
forall (d :: MsgDirection).
CIContent d -> (ContactName, Maybe MarkdownList)
ciContentTexts CIContent d
content
   in ChatDirection c d
-> Bool
-> UserId
-> CIContent d
-> (ContactName, Maybe MarkdownList)
-> Maybe (CIFile d)
-> Maybe (CIQuote c)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem c d
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
ChatDirection c d
-> Bool
-> UserId
-> CIContent d
-> (ContactName, Maybe MarkdownList)
-> Maybe (CIFile d)
-> Maybe (CIQuote c)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem c d
mkChatItem_ ChatDirection c d
cd Bool
showGroupAsSender UserId
ciId CIContent d
content (ContactName, Maybe MarkdownList)
ts Maybe (CIFile d)
file Maybe (CIQuote c)
quotedItem Maybe SharedMsgId
sharedMsgId Maybe CIForwardedFrom
itemForwarded Maybe CITimed
itemTimed Bool
live Bool
userMention UTCTime
itemTs Maybe UserId
forwardedByMember UTCTime
currentTs

mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
mkChatItem_ :: forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
ChatDirection c d
-> Bool
-> UserId
-> CIContent d
-> (ContactName, Maybe MarkdownList)
-> Maybe (CIFile d)
-> Maybe (CIQuote c)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem c d
mkChatItem_ ChatDirection c d
cd Bool
showGroupAsSender UserId
ciId CIContent d
content (ContactName
itemText, Maybe MarkdownList
formattedText) Maybe (CIFile d)
file Maybe (CIQuote c)
quotedItem Maybe SharedMsgId
sharedMsgId Maybe CIForwardedFrom
itemForwarded Maybe CITimed
itemTimed Bool
live Bool
userMention UTCTime
itemTs Maybe UserId
forwardedByMember UTCTime
currentTs =
  let itemStatus :: CIStatus d
itemStatus = CIContent d -> CIStatus d
forall (d :: MsgDirection).
MsgDirectionI d =>
CIContent d -> CIStatus d
ciCreateStatus CIContent d
content
      meta :: CIMeta c d
meta = UserId
-> CIContent d
-> ContactName
-> CIStatus d
-> Maybe Bool
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe (CIDeleted c)
-> Bool
-> Maybe CITimed
-> Maybe Bool
-> Bool
-> UTCTime
-> UTCTime
-> Maybe UserId
-> Bool
-> UTCTime
-> UTCTime
-> CIMeta c d
forall (c :: ChatType) (d :: MsgDirection).
ChatTypeI c =>
UserId
-> CIContent d
-> ContactName
-> CIStatus d
-> Maybe Bool
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe (CIDeleted c)
-> Bool
-> Maybe CITimed
-> Maybe Bool
-> Bool
-> UTCTime
-> UTCTime
-> Maybe UserId
-> Bool
-> UTCTime
-> UTCTime
-> CIMeta c d
mkCIMeta UserId
ciId CIContent d
content ContactName
itemText CIStatus d
itemStatus Maybe Bool
forall a. Maybe a
Nothing Maybe SharedMsgId
sharedMsgId Maybe CIForwardedFrom
itemForwarded Maybe (CIDeleted c)
forall a. Maybe a
Nothing Bool
False Maybe CITimed
itemTimed (Bool -> Maybe Bool
justTrue Bool
live) Bool
userMention UTCTime
currentTs UTCTime
itemTs Maybe UserId
forwardedByMember Bool
showGroupAsSender UTCTime
currentTs UTCTime
currentTs
   in ChatItem {chatDir :: CIDirection c d
chatDir = ChatDirection c d -> CIDirection c d
forall (c :: ChatType) (d :: MsgDirection).
ChatDirection c d -> CIDirection c d
toCIDirection ChatDirection c d
cd, CIMeta c d
meta :: CIMeta c d
meta :: CIMeta c d
meta, CIContent d
content :: CIContent d
content :: CIContent d
content, mentions :: Map ContactName CIMention
mentions = Map ContactName CIMention
forall k a. Map k a
M.empty, Maybe MarkdownList
formattedText :: Maybe MarkdownList
formattedText :: Maybe MarkdownList
formattedText, Maybe (CIQuote c)
quotedItem :: Maybe (CIQuote c)
quotedItem :: Maybe (CIQuote c)
quotedItem, reactions :: [CIReactionCount]
reactions = [], Maybe (CIFile d)
file :: Maybe (CIFile d)
file :: Maybe (CIFile d)
file}

createAgentConnectionAsync :: ConnectionModeI c => User -> CommandFunction -> Bool -> SConnectionMode c -> SubscriptionMode -> CM (CommandId, ConnId)
createAgentConnectionAsync :: forall (c :: ConnectionMode).
ConnectionModeI c =>
User
-> CommandFunction
-> Bool
-> SConnectionMode c
-> SubscriptionMode
-> CM (UserId, ByteString)
createAgentConnectionAsync User
user CommandFunction
cmdFunction Bool
enableNtfs SConnectionMode c
cMode SubscriptionMode
subMode = do
  UserId
cmdId <- (Connection -> IO UserId) -> CM UserId
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO UserId) -> CM UserId)
-> (Connection -> IO UserId) -> CM UserId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Maybe UserId -> CommandFunction -> IO UserId
createCommand Connection
db User
user Maybe UserId
forall a. Maybe a
Nothing CommandFunction
cmdFunction
  ByteString
connId <- (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ByteString)
 -> CM ByteString)
-> (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> UserId
-> ByteString
-> Bool
-> SConnectionMode c
-> InitialKeys
-> SubscriptionMode
-> ExceptT AgentErrorType IO ByteString
forall (c :: ConnectionMode).
ConnectionModeI c =>
AgentClient
-> UserId
-> ByteString
-> Bool
-> SConnectionMode c
-> InitialKeys
-> SubscriptionMode
-> ExceptT AgentErrorType IO ByteString
createConnectionAsync AgentClient
a (User -> UserId
aUserId User
user) (UserId -> ByteString
aCorrId UserId
cmdId) Bool
enableNtfs SConnectionMode c
cMode InitialKeys
IKPQOff SubscriptionMode
subMode
  (UserId, ByteString) -> CM (UserId, ByteString)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserId
cmdId, ByteString
connId)

joinAgentConnectionAsync :: User -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> CM (CommandId, ConnId)
joinAgentConnectionAsync :: forall (c :: ConnectionMode).
User
-> Bool
-> ConnectionRequestUri c
-> ByteString
-> SubscriptionMode
-> CM (UserId, ByteString)
joinAgentConnectionAsync User
user Bool
enableNtfs ConnectionRequestUri c
cReqUri ByteString
cInfo SubscriptionMode
subMode = do
  UserId
cmdId <- (Connection -> IO UserId) -> CM UserId
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO UserId) -> CM UserId)
-> (Connection -> IO UserId) -> CM UserId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Maybe UserId -> CommandFunction -> IO UserId
createCommand Connection
db User
user Maybe UserId
forall a. Maybe a
Nothing CommandFunction
CFJoinConn
  ByteString
connId <- (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ByteString)
 -> CM ByteString)
-> (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> UserId
-> ByteString
-> Bool
-> ConnectionRequestUri c
-> ByteString
-> PQSupport
-> SubscriptionMode
-> ExceptT AgentErrorType IO ByteString
forall (c :: ConnectionMode).
AgentClient
-> UserId
-> ByteString
-> Bool
-> ConnectionRequestUri c
-> ByteString
-> PQSupport
-> SubscriptionMode
-> ExceptT AgentErrorType IO ByteString
joinConnectionAsync AgentClient
a (User -> UserId
aUserId User
user) (UserId -> ByteString
aCorrId UserId
cmdId) Bool
enableNtfs ConnectionRequestUri c
cReqUri ByteString
cInfo PQSupport
PQSupportOff SubscriptionMode
subMode
  (UserId, ByteString) -> CM (UserId, ByteString)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserId
cmdId, ByteString
connId)

allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Connection
-> ByteString
-> ChatMsgEvent e
-> ExceptT ChatError (ReaderT ChatController IO) ()
allowAgentConnectionAsync User
user conn :: Connection
conn@Connection {UserId
connId :: Connection -> UserId
connId :: UserId
connId, PQSupport
pqSupport :: Connection -> PQSupport
pqSupport :: PQSupport
pqSupport, Version ChatVersion
connChatVersion :: Connection -> Version ChatVersion
connChatVersion :: Version ChatVersion
connChatVersion} ByteString
confId ChatMsgEvent e
msg = do
  UserId
cmdId <- (Connection -> IO UserId) -> CM UserId
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO UserId) -> CM UserId)
-> (Connection -> IO UserId) -> CM UserId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Maybe UserId -> CommandFunction -> IO UserId
createCommand Connection
db User
user (UserId -> Maybe UserId
forall a. a -> Maybe a
Just UserId
connId) CommandFunction
CFAllowConn
  ByteString
dm <- PQSupport -> Version ChatVersion -> ChatMsgEvent e -> CM ByteString
forall (e :: MsgEncoding).
MsgEncodingI e =>
PQSupport -> Version ChatVersion -> ChatMsgEvent e -> CM ByteString
encodeConnInfoPQ PQSupport
pqSupport Version ChatVersion
connChatVersion ChatMsgEvent e
msg
  (AgentClient -> ExceptT AgentErrorType IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (AgentClient -> ExceptT AgentErrorType IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ExceptT AgentErrorType IO ()
allowConnectionAsync AgentClient
a (UserId -> ByteString
aCorrId UserId
cmdId) (Connection -> ByteString
aConnId Connection
conn) ByteString
confId ByteString
dm
  (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> Connection -> ConnStatus -> IO ()
updateConnectionStatus Connection
db Connection
conn ConnStatus
ConnAccepted

agentAcceptContactAsync :: MsgEncodingI e => User -> Bool -> InvitationId -> ChatMsgEvent e -> SubscriptionMode -> PQSupport -> VersionChat -> CM (CommandId, ConnId)
agentAcceptContactAsync :: forall (e :: MsgEncoding).
MsgEncodingI e =>
User
-> Bool
-> ByteString
-> ChatMsgEvent e
-> SubscriptionMode
-> PQSupport
-> Version ChatVersion
-> CM (UserId, ByteString)
agentAcceptContactAsync User
user Bool
enableNtfs ByteString
invId ChatMsgEvent e
msg SubscriptionMode
subMode PQSupport
pqSup Version ChatVersion
chatV = do
  UserId
cmdId <- (Connection -> IO UserId) -> CM UserId
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO UserId) -> CM UserId)
-> (Connection -> IO UserId) -> CM UserId
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> User -> Maybe UserId -> CommandFunction -> IO UserId
createCommand Connection
db User
user Maybe UserId
forall a. Maybe a
Nothing CommandFunction
CFAcceptContact
  ByteString
dm <- PQSupport -> Version ChatVersion -> ChatMsgEvent e -> CM ByteString
forall (e :: MsgEncoding).
MsgEncodingI e =>
PQSupport -> Version ChatVersion -> ChatMsgEvent e -> CM ByteString
encodeConnInfoPQ PQSupport
pqSup Version ChatVersion
chatV ChatMsgEvent e
msg
  ByteString
connId <- (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent ((AgentClient -> ExceptT AgentErrorType IO ByteString)
 -> CM ByteString)
-> (AgentClient -> ExceptT AgentErrorType IO ByteString)
-> CM ByteString
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> UserId
-> ByteString
-> Bool
-> ByteString
-> ByteString
-> PQSupport
-> SubscriptionMode
-> ExceptT AgentErrorType IO ByteString
acceptContactAsync AgentClient
a (User -> UserId
aUserId User
user) (UserId -> ByteString
aCorrId UserId
cmdId) Bool
enableNtfs ByteString
invId ByteString
dm PQSupport
pqSup SubscriptionMode
subMode
  (UserId, ByteString) -> CM (UserId, ByteString)
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserId
cmdId, ByteString
connId)

deleteAgentConnectionAsync :: ConnId -> CM ()
deleteAgentConnectionAsync :: ByteString -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteAgentConnectionAsync ByteString
acId = ByteString
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteAgentConnectionAsync' ByteString
acId Bool
False
{-# INLINE deleteAgentConnectionAsync #-}

deleteAgentConnectionAsync' :: ConnId -> Bool -> CM ()
deleteAgentConnectionAsync' :: ByteString
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteAgentConnectionAsync' ByteString
acId Bool
waitDelivery = do
  (AgentClient -> ExceptT AgentErrorType IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent (\AgentClient
a -> AgentClient -> Bool -> ByteString -> ExceptT AgentErrorType IO ()
deleteConnectionAsync AgentClient
a Bool
waitDelivery ByteString
acId) ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> ExceptT ChatError (ReaderT ChatController IO) ()
eToView

deleteAgentConnectionsAsync :: [ConnId] -> CM ()
deleteAgentConnectionsAsync :: [ByteString] -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteAgentConnectionsAsync [ByteString]
acIds = [ByteString]
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteAgentConnectionsAsync' [ByteString]
acIds Bool
False
{-# INLINE deleteAgentConnectionsAsync #-}

deleteAgentConnectionsAsync' :: [ConnId] -> Bool -> CM ()
deleteAgentConnectionsAsync' :: [ByteString]
-> Bool -> ExceptT ChatError (ReaderT ChatController IO) ()
deleteAgentConnectionsAsync' [] Bool
_ = () -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
deleteAgentConnectionsAsync' [ByteString]
acIds Bool
waitDelivery = do
  (AgentClient -> ExceptT AgentErrorType IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (AgentClient -> ExceptT AgentErrorType IO a) -> CM a
withAgent (\AgentClient
a -> AgentClient -> Bool -> [ByteString] -> ExceptT AgentErrorType IO ()
deleteConnectionsAsync AgentClient
a Bool
waitDelivery [ByteString]
acIds) ExceptT ChatError (ReaderT ChatController IO) ()
-> (ChatError -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
`catchAllErrors` ChatError -> ExceptT ChatError (ReaderT ChatController IO) ()
eToView

agentXFTPDeleteRcvFile :: RcvFileId -> FileTransferId -> CM ()
agentXFTPDeleteRcvFile :: ByteString
-> UserId -> ExceptT ChatError (ReaderT ChatController IO) ()
agentXFTPDeleteRcvFile ByteString
aFileId UserId
fileId = do
  ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ReaderT ChatController IO ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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)
  (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (Connection -> IO ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection -> UserId -> IO ()
setRcvFTAgentDeleted Connection
db UserId
fileId

agentXFTPDeleteRcvFiles :: [(XFTPRcvFile, FileTransferId)] -> CM' ()
agentXFTPDeleteRcvFiles :: [(XFTPRcvFile, UserId)] -> ReaderT ChatController IO ()
agentXFTPDeleteRcvFiles [(XFTPRcvFile, UserId)]
rcvFiles = do
  let rcvFiles' :: [(XFTPRcvFile, UserId)]
rcvFiles' = ((XFTPRcvFile, UserId) -> Bool)
-> [(XFTPRcvFile, UserId)] -> [(XFTPRcvFile, UserId)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((XFTPRcvFile, UserId) -> Bool) -> (XFTPRcvFile, UserId) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPRcvFile -> Bool
agentRcvFileDeleted (XFTPRcvFile -> Bool)
-> ((XFTPRcvFile, UserId) -> XFTPRcvFile)
-> (XFTPRcvFile, UserId)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XFTPRcvFile, UserId) -> XFTPRcvFile
forall a b. (a, b) -> a
fst) [(XFTPRcvFile, UserId)]
rcvFiles
      rfIds :: [(ByteString, UserId)]
rfIds = ((XFTPRcvFile, UserId) -> Maybe (ByteString, UserId))
-> [(XFTPRcvFile, UserId)] -> [(ByteString, UserId)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (XFTPRcvFile, UserId) -> Maybe (ByteString, UserId)
fileIds [(XFTPRcvFile, UserId)]
rcvFiles'
  (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a. (AgentClient -> IO a) -> CM' a
withAgent' ((AgentClient -> IO ()) -> ReaderT ChatController IO ())
-> (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient -> [ByteString] -> IO ()
xftpDeleteRcvFiles AgentClient
a (((ByteString, UserId) -> ByteString)
-> [(ByteString, UserId)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, UserId) -> ByteString
forall a b. (a, b) -> a
fst [(ByteString, UserId)]
rfIds)
  ReaderT ChatController IO [Either ChatError ()]
-> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO [Either ChatError ()]
 -> ReaderT ChatController IO ())
-> ((Connection -> [IO ()])
    -> ReaderT ChatController IO [Either ChatError ()])
-> (Connection -> [IO ()])
-> ReaderT ChatController IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> [IO ()])
-> ReaderT ChatController IO [Either ChatError ()]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' ((Connection -> [IO ()]) -> ReaderT ChatController IO ())
-> (Connection -> [IO ()]) -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ((ByteString, UserId) -> IO ())
-> [(ByteString, UserId)] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> UserId -> IO ()
setRcvFTAgentDeleted Connection
db (UserId -> IO ())
-> ((ByteString, UserId) -> UserId)
-> (ByteString, UserId)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, UserId) -> UserId
forall a b. (a, b) -> b
snd) [(ByteString, UserId)]
rfIds
  where
    fileIds :: (XFTPRcvFile, FileTransferId) -> Maybe (RcvFileId, FileTransferId)
    fileIds :: (XFTPRcvFile, UserId) -> Maybe (ByteString, UserId)
fileIds (XFTPRcvFile {agentRcvFileId :: XFTPRcvFile -> Maybe AgentRcvFileId
agentRcvFileId = Just (AgentRcvFileId ByteString
aFileId)}, UserId
fileId) = (ByteString, UserId) -> Maybe (ByteString, UserId)
forall a. a -> Maybe a
Just (ByteString
aFileId, UserId
fileId)
    fileIds (XFTPRcvFile, UserId)
_ = Maybe (ByteString, UserId)
forall a. Maybe a
Nothing

agentXFTPDeleteSndFileRemote :: User -> XFTPSndFile -> FileTransferId -> CM' ()
agentXFTPDeleteSndFileRemote :: User -> XFTPSndFile -> UserId -> ReaderT ChatController IO ()
agentXFTPDeleteSndFileRemote User
user XFTPSndFile
xsf UserId
fileId =
  User -> [(XFTPSndFile, UserId)] -> ReaderT ChatController IO ()
agentXFTPDeleteSndFilesRemote User
user [(XFTPSndFile
xsf, UserId
fileId)]

agentXFTPDeleteSndFilesRemote :: User -> [(XFTPSndFile, FileTransferId)] -> CM' ()
agentXFTPDeleteSndFilesRemote :: User -> [(XFTPSndFile, UserId)] -> ReaderT ChatController IO ()
agentXFTPDeleteSndFilesRemote User
user [(XFTPSndFile, UserId)]
sndFiles = do
  ([ChatError]
_errs, [[FileTransferMeta]]
redirects) <- [Either ChatError [FileTransferMeta]]
-> ([ChatError], [[FileTransferMeta]])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ChatError [FileTransferMeta]]
 -> ([ChatError], [[FileTransferMeta]]))
-> ReaderT ChatController IO [Either ChatError [FileTransferMeta]]
-> ReaderT ChatController IO ([ChatError], [[FileTransferMeta]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> [IO [FileTransferMeta]])
-> ReaderT ChatController IO [Either ChatError [FileTransferMeta]]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' (\Connection
db -> ((XFTPSndFile, UserId) -> IO [FileTransferMeta])
-> [(XFTPSndFile, UserId)] -> [IO [FileTransferMeta]]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> User -> UserId -> IO [FileTransferMeta]
lookupFileTransferRedirectMeta Connection
db User
user (UserId -> IO [FileTransferMeta])
-> ((XFTPSndFile, UserId) -> UserId)
-> (XFTPSndFile, UserId)
-> IO [FileTransferMeta]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XFTPSndFile, UserId) -> UserId
forall a b. (a, b) -> b
snd) [(XFTPSndFile, UserId)]
sndFiles)
  let redirects' :: [(XFTPSndFile, UserId)]
redirects' = (FileTransferMeta -> Maybe (XFTPSndFile, UserId))
-> [FileTransferMeta] -> [(XFTPSndFile, UserId)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FileTransferMeta -> Maybe (XFTPSndFile, UserId)
mapRedirectMeta ([FileTransferMeta] -> [(XFTPSndFile, UserId)])
-> [FileTransferMeta] -> [(XFTPSndFile, UserId)]
forall a b. (a -> b) -> a -> b
$ [[FileTransferMeta]] -> [FileTransferMeta]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FileTransferMeta]]
redirects
      sndFilesAll :: [(XFTPSndFile, UserId)]
sndFilesAll = [(XFTPSndFile, UserId)]
redirects' [(XFTPSndFile, UserId)]
-> [(XFTPSndFile, UserId)] -> [(XFTPSndFile, UserId)]
forall a. Semigroup a => a -> a -> a
<> [(XFTPSndFile, UserId)]
sndFiles
      sndFilesAll' :: [(XFTPSndFile, UserId)]
sndFilesAll' = ((XFTPSndFile, UserId) -> Bool)
-> [(XFTPSndFile, UserId)] -> [(XFTPSndFile, UserId)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((XFTPSndFile, UserId) -> Bool) -> (XFTPSndFile, UserId) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XFTPSndFile -> Bool
agentSndFileDeleted (XFTPSndFile -> Bool)
-> ((XFTPSndFile, UserId) -> XFTPSndFile)
-> (XFTPSndFile, UserId)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XFTPSndFile, UserId) -> XFTPSndFile
forall a b. (a, b) -> a
fst) [(XFTPSndFile, UserId)]
sndFilesAll
  -- while file is being prepared and uploaded, it would not have description available;
  -- this partitions files into those with and without descriptions -
  -- files with description are deleted remotely, files without description are deleted internally
  ([ByteString]
sfsNoDescr, [(ByteString, ValidFileDescription 'FSender)]
sfsWithDescr) <- [(XFTPSndFile, UserId)]
-> [ByteString]
-> [(ByteString, ValidFileDescription 'FSender)]
-> CM'
     ([ByteString], [(ByteString, ValidFileDescription 'FSender)])
partitionSndDescr [(XFTPSndFile, UserId)]
sndFilesAll' [] []
  (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a. (AgentClient -> IO a) -> CM' a
withAgent' ((AgentClient -> IO ()) -> ReaderT ChatController IO ())
-> (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient -> [ByteString] -> IO ()
xftpDeleteSndFilesInternal AgentClient
a [ByteString]
sfsNoDescr
  (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a. (AgentClient -> IO a) -> CM' a
withAgent' ((AgentClient -> IO ()) -> ReaderT ChatController IO ())
-> (AgentClient -> IO ()) -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ \AgentClient
a -> AgentClient
-> UserId -> [(ByteString, ValidFileDescription 'FSender)] -> IO ()
xftpDeleteSndFilesRemote AgentClient
a (User -> UserId
aUserId User
user) [(ByteString, ValidFileDescription 'FSender)]
sfsWithDescr
  ReaderT ChatController IO [Either ChatError ()]
-> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO [Either ChatError ()]
 -> ReaderT ChatController IO ())
-> ((Connection -> [IO ()])
    -> ReaderT ChatController IO [Either ChatError ()])
-> (Connection -> [IO ()])
-> ReaderT ChatController IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> [IO ()])
-> ReaderT ChatController IO [Either ChatError ()]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' ((Connection -> [IO ()]) -> ReaderT ChatController IO ())
-> (Connection -> [IO ()]) -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ((XFTPSndFile, UserId) -> IO ())
-> [(XFTPSndFile, UserId)] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (Connection -> User -> UserId -> IO ()
setSndFTAgentDeleted Connection
db User
user (UserId -> IO ())
-> ((XFTPSndFile, UserId) -> UserId)
-> (XFTPSndFile, UserId)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XFTPSndFile, UserId) -> UserId
forall a b. (a, b) -> b
snd) [(XFTPSndFile, UserId)]
sndFilesAll'
  where
    mapRedirectMeta :: FileTransferMeta -> Maybe (XFTPSndFile, FileTransferId)
    mapRedirectMeta :: FileTransferMeta -> Maybe (XFTPSndFile, UserId)
mapRedirectMeta FileTransferMeta {fileId :: FileTransferMeta -> UserId
fileId = UserId
fileId, xftpSndFile :: FileTransferMeta -> Maybe XFTPSndFile
xftpSndFile = Just XFTPSndFile
sndFileRedirect} = (XFTPSndFile, UserId) -> Maybe (XFTPSndFile, UserId)
forall a. a -> Maybe a
Just (XFTPSndFile
sndFileRedirect, UserId
fileId)
    mapRedirectMeta FileTransferMeta
_ = Maybe (XFTPSndFile, UserId)
forall a. Maybe a
Nothing
    partitionSndDescr ::
      [(XFTPSndFile, FileTransferId)] ->
      [SndFileId] ->
      [(SndFileId, ValidFileDescription 'FSender)] ->
      CM' ([SndFileId], [(SndFileId, ValidFileDescription 'FSender)])
    partitionSndDescr :: [(XFTPSndFile, UserId)]
-> [ByteString]
-> [(ByteString, ValidFileDescription 'FSender)]
-> CM'
     ([ByteString], [(ByteString, ValidFileDescription 'FSender)])
partitionSndDescr [] [ByteString]
filesWithoutDescr [(ByteString, ValidFileDescription 'FSender)]
filesWithDescr = ([ByteString], [(ByteString, ValidFileDescription 'FSender)])
-> CM'
     ([ByteString], [(ByteString, ValidFileDescription 'FSender)])
forall a. a -> ReaderT ChatController IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString]
filesWithoutDescr, [(ByteString, ValidFileDescription 'FSender)]
filesWithDescr)
    partitionSndDescr ((XFTPSndFile {agentSndFileId :: XFTPSndFile -> AgentSndFileId
agentSndFileId = AgentSndFileId ByteString
aFileId, Maybe ContactName
privateSndFileDescr :: Maybe ContactName
privateSndFileDescr :: XFTPSndFile -> Maybe ContactName
privateSndFileDescr}, UserId
_) : [(XFTPSndFile, UserId)]
xsfs) [ByteString]
filesWithoutDescr [(ByteString, ValidFileDescription 'FSender)]
filesWithDescr =
      case Maybe ContactName
privateSndFileDescr of
        Maybe ContactName
Nothing -> [(XFTPSndFile, UserId)]
-> [ByteString]
-> [(ByteString, ValidFileDescription 'FSender)]
-> CM'
     ([ByteString], [(ByteString, ValidFileDescription 'FSender)])
partitionSndDescr [(XFTPSndFile, UserId)]
xsfs (ByteString
aFileId ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
filesWithoutDescr) [(ByteString, ValidFileDescription 'FSender)]
filesWithDescr
        Just ContactName
sfdText ->
          ExceptT
  ChatError
  (ReaderT ChatController IO)
  (ValidFileDescription 'FSender)
-> ReaderT
     ChatController
     IO
     (Either ChatError (ValidFileDescription 'FSender))
forall e (m :: * -> *) a.
(AnyError e, MonadUnliftIO m) =>
ExceptT e m a -> m (Either e a)
tryAllErrors' (ContactName
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     (ValidFileDescription 'FSender)
forall (p :: FileParty).
FilePartyI p =>
ContactName -> CM (ValidFileDescription p)
parseFileDescription ContactName
sfdText) ReaderT
  ChatController
  IO
  (Either ChatError (ValidFileDescription 'FSender))
-> (Either ChatError (ValidFileDescription 'FSender)
    -> CM'
         ([ByteString], [(ByteString, ValidFileDescription 'FSender)]))
-> CM'
     ([ByteString], [(ByteString, ValidFileDescription 'FSender)])
forall a b.
ReaderT ChatController IO a
-> (a -> ReaderT ChatController IO b)
-> ReaderT ChatController IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left ChatError
_ -> [(XFTPSndFile, UserId)]
-> [ByteString]
-> [(ByteString, ValidFileDescription 'FSender)]
-> CM'
     ([ByteString], [(ByteString, ValidFileDescription 'FSender)])
partitionSndDescr [(XFTPSndFile, UserId)]
xsfs (ByteString
aFileId ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
filesWithoutDescr) [(ByteString, ValidFileDescription 'FSender)]
filesWithDescr
            Right ValidFileDescription 'FSender
sfd -> [(XFTPSndFile, UserId)]
-> [ByteString]
-> [(ByteString, ValidFileDescription 'FSender)]
-> CM'
     ([ByteString], [(ByteString, ValidFileDescription 'FSender)])
partitionSndDescr [(XFTPSndFile, UserId)]
xsfs [ByteString]
filesWithoutDescr ((ByteString
aFileId, ValidFileDescription 'FSender
sfd) (ByteString, ValidFileDescription 'FSender)
-> [(ByteString, ValidFileDescription 'FSender)]
-> [(ByteString, ValidFileDescription 'FSender)]
forall a. a -> [a] -> [a]
: [(ByteString, ValidFileDescription 'FSender)]
filesWithDescr)

connRequestPQEncryption :: ConnectionRequestUri c -> Maybe PQEncryption
connRequestPQEncryption :: forall (c :: ConnectionMode).
ConnectionRequestUri c -> Maybe PQEncryption
connRequestPQEncryption = \case
  CRContactUri ConnReqUriData
_ -> Maybe PQEncryption
forall a. Maybe a
Nothing
  CRInvitationUri ConnReqUriData
_ (CR.E2ERatchetParamsUri VersionRangeE2E
vr' PublicKey 'X448
_ PublicKey 'X448
_ Maybe (RKEMParams 'RKSProposed)
pq) ->
    PQEncryption -> Maybe PQEncryption
forall a. a -> Maybe a
Just (PQEncryption -> Maybe PQEncryption)
-> PQEncryption -> Maybe PQEncryption
forall a b. (a -> b) -> a -> b
$ Bool -> PQEncryption
PQEncryption (Bool -> PQEncryption) -> Bool -> PQEncryption
forall a b. (a -> b) -> a -> b
$ VersionRangeE2E -> Version E2EVersion
forall v. VersionRange v -> Version v
maxVersion VersionRangeE2E
vr' Version E2EVersion -> Version E2EVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version E2EVersion
CR.pqRatchetE2EEncryptVersion Bool -> Bool -> Bool
&& Maybe (RKEMParams 'RKSProposed) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (RKEMParams 'RKSProposed)
pq

createRcvFeatureItems :: User -> Contact -> Contact -> CM' ()
createRcvFeatureItems :: User -> Contact -> Contact -> ReaderT ChatController IO ()
createRcvFeatureItems User
user Contact
ct Contact
ct' =
  User
-> Contact
-> Contact
-> (Contact -> ChatDirection 'CTDirect 'MDRcv)
-> FeatureContent PrefEnabled 'MDRcv
-> FeatureContent FeatureAllowed 'MDRcv
-> (forall (f :: ChatFeature).
    ContactUserPreference (FeaturePreference f) -> FeaturePreference f)
-> ReaderT ChatController IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> Contact
-> Contact
-> (Contact -> ChatDirection 'CTDirect d)
-> FeatureContent PrefEnabled d
-> FeatureContent FeatureAllowed d
-> (forall (f :: ChatFeature).
    ContactUserPreference (FeaturePreference f) -> FeaturePreference f)
-> ReaderT ChatController IO ()
createFeatureItems User
user Contact
ct Contact
ct' Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv FeatureContent PrefEnabled 'MDRcv
CIRcvChatFeature FeatureContent FeatureAllowed 'MDRcv
CIRcvChatPreference ContactUserPreference (FeaturePreference f) -> FeaturePreference f
forall p. ContactUserPreference p -> p
forall (f :: ChatFeature).
ContactUserPreference (FeaturePreference f) -> FeaturePreference f
contactPreference

createSndFeatureItems :: User -> Contact -> Contact -> CM' ()
createSndFeatureItems :: User -> Contact -> Contact -> ReaderT ChatController IO ()
createSndFeatureItems User
user Contact
ct Contact
ct' =
  User
-> Contact
-> Contact
-> (Contact -> ChatDirection 'CTDirect 'MDSnd)
-> FeatureContent PrefEnabled 'MDSnd
-> FeatureContent FeatureAllowed 'MDSnd
-> (forall (f :: ChatFeature).
    ContactUserPreference (FeaturePreference f) -> FeaturePreference f)
-> ReaderT ChatController IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> Contact
-> Contact
-> (Contact -> ChatDirection 'CTDirect d)
-> FeatureContent PrefEnabled d
-> FeatureContent FeatureAllowed d
-> (forall (f :: ChatFeature).
    ContactUserPreference (FeaturePreference f) -> FeaturePreference f)
-> ReaderT ChatController IO ()
createFeatureItems User
user Contact
ct Contact
ct' Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectSnd FeatureContent PrefEnabled 'MDSnd
CISndChatFeature FeatureContent FeatureAllowed 'MDSnd
CISndChatPreference ContactUserPreference (FeaturePreference f) -> FeaturePreference f
forall p. ContactUserPreference p -> p
forall (f :: ChatFeature).
ContactUserPreference (FeaturePreference f) -> FeaturePreference f
getPref
  where
    getPref :: ContactUserPreference p -> p
getPref ContactUserPreference {ContactUserPref p
userPreference :: ContactUserPref p
userPreference :: forall p. ContactUserPreference p -> ContactUserPref p
userPreference} = case ContactUserPref p
userPreference of
      CUPContact {p
preference :: p
preference :: forall p. ContactUserPref p -> p
preference} -> p
preference
      CUPUser {p
preference :: forall p. ContactUserPref p -> p
preference :: p
preference} -> p
preference

-- Used when contact is changed after creating initial feature items via createFeatureEnabledItems_
-- (APIChangePreparedContactUser, APIConnectPreparedContact with incognito = True);
-- creates feature items with CDDirectRcv direction so that changed feature items stay in the same place in chat view
createContactChangedFeatureItems :: User -> Contact -> Contact -> CM' ()
createContactChangedFeatureItems :: User -> Contact -> Contact -> ReaderT ChatController IO ()
createContactChangedFeatureItems User
user Contact
ct Contact
ct' =
  User
-> Contact
-> Contact
-> (Contact -> ChatDirection 'CTDirect 'MDRcv)
-> FeatureContent PrefEnabled 'MDRcv
-> FeatureContent FeatureAllowed 'MDRcv
-> (forall (f :: ChatFeature).
    ContactUserPreference (FeaturePreference f) -> FeaturePreference f)
-> ReaderT ChatController IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> Contact
-> Contact
-> (Contact -> ChatDirection 'CTDirect d)
-> FeatureContent PrefEnabled d
-> FeatureContent FeatureAllowed d
-> (forall (f :: ChatFeature).
    ContactUserPreference (FeaturePreference f) -> FeaturePreference f)
-> ReaderT ChatController IO ()
createFeatureItems User
user Contact
ct Contact
ct' Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv FeatureContent PrefEnabled 'MDRcv
CIRcvChatFeature FeatureContent FeatureAllowed 'MDRcv
CIRcvChatPreference ContactUserPreference (FeaturePreference f) -> FeaturePreference f
forall p. ContactUserPreference p -> p
forall (f :: ChatFeature).
ContactUserPreference (FeaturePreference f) -> FeaturePreference f
getPref
  where
    getPref :: ContactUserPreference p -> p
getPref ContactUserPreference {ContactUserPref p
userPreference :: forall p. ContactUserPreference p -> ContactUserPref p
userPreference :: ContactUserPref p
userPreference} = case ContactUserPref p
userPreference of
      CUPContact {p
preference :: forall p. ContactUserPref p -> p
preference :: p
preference} -> p
preference
      CUPUser {p
preference :: forall p. ContactUserPref p -> p
preference :: p
preference} -> p
preference

type FeatureContent a d = ChatFeature -> a -> Maybe Int -> CIContent d

createFeatureEnabledItems :: User -> Contact -> CM ()
createFeatureEnabledItems :: User -> Contact -> ExceptT ChatError (ReaderT ChatController IO) ()
createFeatureEnabledItems User
user Contact
ct = User -> Contact -> CM [AChatItem]
createFeatureEnabledItems_ User
user Contact
ct CM [AChatItem]
-> ([AChatItem]
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ([AChatItem] -> ChatEvent)
-> [AChatItem]
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user

createFeatureEnabledItems_ :: User -> Contact -> CM [AChatItem]
createFeatureEnabledItems_ :: User -> Contact -> CM [AChatItem]
createFeatureEnabledItems_ User
user ct :: Contact
ct@Contact {ContactUserPreferences
mergedPreferences :: ContactUserPreferences
mergedPreferences :: Contact -> ContactUserPreferences
mergedPreferences} =
  [AChatFeature]
-> (AChatFeature
    -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> CM [AChatItem]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AChatFeature]
allChatFeatures ((AChatFeature
  -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
 -> CM [AChatItem])
-> (AChatFeature
    -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> CM [AChatItem]
forall a b. (a -> b) -> a -> b
$ \(ACF SChatFeature f
f) -> do
    let state :: (PrefEnabled, Maybe Int)
state = ContactUserPreference (FeaturePreference f)
-> (PrefEnabled, Maybe Int)
forall (f :: ChatFeature).
FeatureI f =>
ContactUserPreference (FeaturePreference f)
-> (PrefEnabled, Maybe Int)
featureState (ContactUserPreference (FeaturePreference f)
 -> (PrefEnabled, Maybe Int))
-> ContactUserPreference (FeaturePreference f)
-> (PrefEnabled, Maybe Int)
forall a b. (a -> b) -> a -> b
$ SChatFeature f
-> ContactUserPreferences
-> ContactUserPreference (FeaturePreference f)
forall (f :: ChatFeature).
SChatFeature f
-> ContactUserPreferences
-> ContactUserPreference (FeaturePreference f)
getContactUserPreference SChatFeature f
f ContactUserPreferences
mergedPreferences
    User
-> ChatDirection 'CTDirect 'MDRcv
-> Bool
-> CIContent 'MDRcv
-> Maybe SharedMsgId
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
createChatItem User
user (Contact -> ChatDirection 'CTDirect 'MDRcv
CDDirectRcv Contact
ct) Bool
False ((PrefEnabled -> Maybe Int -> CIContent 'MDRcv)
-> (PrefEnabled, Maybe Int) -> CIContent 'MDRcv
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (FeatureContent PrefEnabled 'MDRcv
CIRcvChatFeature FeatureContent PrefEnabled 'MDRcv
-> FeatureContent PrefEnabled 'MDRcv
forall a b. (a -> b) -> a -> b
$ SChatFeature f -> ChatFeature
forall (f :: ChatFeature). SChatFeature f -> ChatFeature
chatFeature SChatFeature f
f) (PrefEnabled, Maybe Int)
state) Maybe SharedMsgId
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing

createFeatureItems ::
  MsgDirectionI d =>
  User ->
  Contact ->
  Contact ->
  (Contact -> ChatDirection 'CTDirect d) ->
  FeatureContent PrefEnabled d ->
  FeatureContent FeatureAllowed d ->
  (forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) ->
  CM' ()
createFeatureItems :: forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> Contact
-> Contact
-> (Contact -> ChatDirection 'CTDirect d)
-> FeatureContent PrefEnabled d
-> FeatureContent FeatureAllowed d
-> (forall (f :: ChatFeature).
    ContactUserPreference (FeaturePreference f) -> FeaturePreference f)
-> ReaderT ChatController IO ()
createFeatureItems User
user Contact
ct Contact
ct' = User
-> [(Contact, Contact)]
-> (Contact -> ChatDirection 'CTDirect d)
-> FeatureContent PrefEnabled d
-> FeatureContent FeatureAllowed d
-> (forall (f :: ChatFeature).
    ContactUserPreference (FeaturePreference f) -> FeaturePreference f)
-> ReaderT ChatController IO ()
forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> [(Contact, Contact)]
-> (Contact -> ChatDirection 'CTDirect d)
-> FeatureContent PrefEnabled d
-> FeatureContent FeatureAllowed d
-> (forall (f :: ChatFeature).
    ContactUserPreference (FeaturePreference f) -> FeaturePreference f)
-> ReaderT ChatController IO ()
createContactsFeatureItems User
user [(Contact
ct, Contact
ct')]

createContactsFeatureItems ::
  forall d.
  MsgDirectionI d =>
  User ->
  [(Contact, Contact)] ->
  (Contact -> ChatDirection 'CTDirect d) ->
  FeatureContent PrefEnabled d ->
  FeatureContent FeatureAllowed d ->
  (forall f. ContactUserPreference (FeaturePreference f) -> FeaturePreference f) ->
  CM' ()
createContactsFeatureItems :: forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> [(Contact, Contact)]
-> (Contact -> ChatDirection 'CTDirect d)
-> FeatureContent PrefEnabled d
-> FeatureContent FeatureAllowed d
-> (forall (f :: ChatFeature).
    ContactUserPreference (FeaturePreference f) -> FeaturePreference f)
-> ReaderT ChatController IO ()
createContactsFeatureItems User
user [(Contact, Contact)]
cts Contact -> ChatDirection 'CTDirect d
chatDir FeatureContent PrefEnabled d
ciFeature FeatureContent FeatureAllowed d
ciOffer forall (f :: ChatFeature).
ContactUserPreference (FeaturePreference f) -> FeaturePreference f
getPref = do
  let dirsCIContents :: [(ChatDirection 'CTDirect d, Bool,
  [(CIContent d, Maybe SharedMsgId)])]
dirsCIContents = ((Contact, Contact)
 -> (ChatDirection 'CTDirect d, Bool,
     [(CIContent d, Maybe SharedMsgId)]))
-> [(Contact, Contact)]
-> [(ChatDirection 'CTDirect d, Bool,
     [(CIContent d, Maybe SharedMsgId)])]
forall a b. (a -> b) -> [a] -> [b]
map (Contact, Contact)
-> (ChatDirection 'CTDirect d, Bool,
    [(CIContent d, Maybe SharedMsgId)])
contactChangedFeatures [(Contact, Contact)]
cts
  ([ChatError]
errs, [AChatItem]
acis) <- [Either ChatError AChatItem] -> ([ChatError], [AChatItem])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ChatError AChatItem] -> ([ChatError], [AChatItem]))
-> ReaderT ChatController IO [Either ChatError AChatItem]
-> ReaderT ChatController IO ([ChatError], [AChatItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> User
-> Maybe UTCTime
-> [(ChatDirection 'CTDirect d, Bool,
     [(CIContent d, Maybe SharedMsgId)])]
-> ReaderT ChatController IO [Either ChatError AChatItem]
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> Maybe UTCTime
-> [(ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])]
-> ReaderT ChatController IO [Either ChatError AChatItem]
createChatItems User
user Maybe UTCTime
forall a. Maybe a
Nothing [(ChatDirection 'CTDirect d, Bool,
  [(CIContent d, Maybe SharedMsgId)])]
dirsCIContents
  Bool
-> ReaderT ChatController IO () -> ReaderT ChatController IO ()
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) (ReaderT ChatController IO () -> ReaderT ChatController IO ())
-> ReaderT ChatController IO () -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> ReaderT ChatController IO ()
toView' (ChatEvent -> ReaderT ChatController IO ())
-> ChatEvent -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ [ChatError] -> ChatEvent
CEvtChatErrors [ChatError]
errs
  ChatEvent -> ReaderT ChatController IO ()
toView' (ChatEvent -> ReaderT ChatController IO ())
-> ChatEvent -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [AChatItem]
acis
  where
    contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)])
    contactChangedFeatures :: (Contact, Contact)
-> (ChatDirection 'CTDirect d, Bool,
    [(CIContent d, Maybe SharedMsgId)])
contactChangedFeatures (Contact {mergedPreferences :: Contact -> ContactUserPreferences
mergedPreferences = ContactUserPreferences
cups}, ct' :: Contact
ct'@Contact {mergedPreferences :: Contact -> ContactUserPreferences
mergedPreferences = ContactUserPreferences
cups'}) = do
      let contents :: [(CIContent d, Maybe SharedMsgId)]
contents = (AChatFeature -> Maybe (CIContent d, Maybe SharedMsgId))
-> [AChatFeature] -> [(CIContent d, Maybe SharedMsgId)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(ACF SChatFeature f
f) -> SChatFeature f -> Maybe (CIContent d, Maybe SharedMsgId)
forall (f :: ChatFeature).
FeatureI f =>
SChatFeature f -> Maybe (CIContent d, Maybe SharedMsgId)
featureCIContent_ SChatFeature f
f) [AChatFeature]
allChatFeatures
      (Contact -> ChatDirection 'CTDirect d
chatDir Contact
ct', Bool
False, [(CIContent d, Maybe SharedMsgId)]
contents)
      where
        featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d, Maybe SharedMsgId)
        featureCIContent_ :: forall (f :: ChatFeature).
FeatureI f =>
SChatFeature f -> Maybe (CIContent d, Maybe SharedMsgId)
featureCIContent_ SChatFeature f
f
          | (PrefEnabled, Maybe Int)
state (PrefEnabled, Maybe Int) -> (PrefEnabled, Maybe Int) -> Bool
forall a. Eq a => a -> a -> Bool
/= (PrefEnabled, Maybe Int)
state' = (CIContent d, Maybe SharedMsgId)
-> Maybe (CIContent d, Maybe SharedMsgId)
forall a. a -> Maybe a
Just (FeatureContent PrefEnabled d
-> (PrefEnabled, Maybe Int) -> CIContent d
forall a. FeatureContent a d -> (a, Maybe Int) -> CIContent d
fContent FeatureContent PrefEnabled d
ciFeature (PrefEnabled, Maybe Int)
state', Maybe SharedMsgId
forall a. Maybe a
Nothing)
          | (FeatureAllowed, Maybe Int)
prefState (FeatureAllowed, Maybe Int) -> (FeatureAllowed, Maybe Int) -> Bool
forall a. Eq a => a -> a -> Bool
/= (FeatureAllowed, Maybe Int)
prefState' = (CIContent d, Maybe SharedMsgId)
-> Maybe (CIContent d, Maybe SharedMsgId)
forall a. a -> Maybe a
Just (FeatureContent FeatureAllowed d
-> (FeatureAllowed, Maybe Int) -> CIContent d
forall a. FeatureContent a d -> (a, Maybe Int) -> CIContent d
fContent FeatureContent FeatureAllowed d
ciOffer (FeatureAllowed, Maybe Int)
prefState', Maybe SharedMsgId
forall a. Maybe a
Nothing)
          | Bool
otherwise = Maybe (CIContent d, Maybe SharedMsgId)
forall a. Maybe a
Nothing
          where
            fContent :: FeatureContent a d -> (a, Maybe Int) -> CIContent d
            fContent :: forall a. FeatureContent a d -> (a, Maybe Int) -> CIContent d
fContent FeatureContent a d
ci (a
s, Maybe Int
param) = FeatureContent a d
ci ChatFeature
f' a
s Maybe Int
param
            f' :: ChatFeature
f' = SChatFeature f -> ChatFeature
forall (f :: ChatFeature). SChatFeature f -> ChatFeature
chatFeature SChatFeature f
f
            state :: (PrefEnabled, Maybe Int)
state = ContactUserPreference (FeaturePreference f)
-> (PrefEnabled, Maybe Int)
forall (f :: ChatFeature).
FeatureI f =>
ContactUserPreference (FeaturePreference f)
-> (PrefEnabled, Maybe Int)
featureState ContactUserPreference (FeaturePreference f)
cup
            state' :: (PrefEnabled, Maybe Int)
state' = ContactUserPreference (FeaturePreference f)
-> (PrefEnabled, Maybe Int)
forall (f :: ChatFeature).
FeatureI f =>
ContactUserPreference (FeaturePreference f)
-> (PrefEnabled, Maybe Int)
featureState ContactUserPreference (FeaturePreference f)
cup'
            prefState :: (FeatureAllowed, Maybe Int)
prefState = FeaturePreference f -> (FeatureAllowed, Maybe Int)
forall (f :: ChatFeature).
FeatureI f =>
FeaturePreference f -> (FeatureAllowed, Maybe Int)
preferenceState (FeaturePreference f -> (FeatureAllowed, Maybe Int))
-> FeaturePreference f -> (FeatureAllowed, Maybe Int)
forall a b. (a -> b) -> a -> b
$ ContactUserPreference (FeaturePreference f) -> FeaturePreference f
forall (f :: ChatFeature).
ContactUserPreference (FeaturePreference f) -> FeaturePreference f
getPref ContactUserPreference (FeaturePreference f)
cup
            prefState' :: (FeatureAllowed, Maybe Int)
prefState' = FeaturePreference f -> (FeatureAllowed, Maybe Int)
forall (f :: ChatFeature).
FeatureI f =>
FeaturePreference f -> (FeatureAllowed, Maybe Int)
preferenceState (FeaturePreference f -> (FeatureAllowed, Maybe Int))
-> FeaturePreference f -> (FeatureAllowed, Maybe Int)
forall a b. (a -> b) -> a -> b
$ ContactUserPreference (FeaturePreference f) -> FeaturePreference f
forall (f :: ChatFeature).
ContactUserPreference (FeaturePreference f) -> FeaturePreference f
getPref ContactUserPreference (FeaturePreference f)
cup'
            cup :: ContactUserPreference (FeaturePreference f)
cup = SChatFeature f
-> ContactUserPreferences
-> ContactUserPreference (FeaturePreference f)
forall (f :: ChatFeature).
SChatFeature f
-> ContactUserPreferences
-> ContactUserPreference (FeaturePreference f)
getContactUserPreference SChatFeature f
f ContactUserPreferences
cups
            cup' :: ContactUserPreference (FeaturePreference f)
cup' = SChatFeature f
-> ContactUserPreferences
-> ContactUserPreference (FeaturePreference f)
forall (f :: ChatFeature).
SChatFeature f
-> ContactUserPreferences
-> ContactUserPreference (FeaturePreference f)
getContactUserPreference SChatFeature f
f ContactUserPreferences
cups'

createGroupFeatureChangedItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> GroupInfo -> CM ()
createGroupFeatureChangedItems :: forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> ChatDirection 'CTGroup d
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent d)
-> GroupInfo
-> GroupInfo
-> ExceptT ChatError (ReaderT ChatController IO) ()
createGroupFeatureChangedItems User
user ChatDirection 'CTGroup d
cd GroupFeature
-> GroupPreference
-> Maybe Int
-> Maybe GroupMemberRole
-> CIContent d
ciContent GroupInfo {fullGroupPreferences :: GroupInfo -> FullGroupPreferences
fullGroupPreferences = FullGroupPreferences
gps} GroupInfo {fullGroupPreferences :: GroupInfo -> FullGroupPreferences
fullGroupPreferences = FullGroupPreferences
gps'} =
  [AGroupFeature]
-> (AGroupFeature
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AGroupFeature]
allGroupFeatures ((AGroupFeature
  -> ExceptT ChatError (ReaderT ChatController IO) ())
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> (AGroupFeature
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ \(AGF SGroupFeature f
f) -> do
    let state :: (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
state = GroupFeaturePreference f
-> (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
forall (f :: GroupFeature).
GroupFeatureI f =>
GroupFeaturePreference f
-> (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
groupFeatureState (GroupFeaturePreference f
 -> (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole))
-> GroupFeaturePreference f
-> (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
forall a b. (a -> b) -> a -> b
$ SGroupFeature f -> FullGroupPreferences -> GroupFeaturePreference f
forall p (f :: GroupFeature).
GroupPreferenceI p =>
SGroupFeature f -> p -> GroupFeaturePreference f
forall (f :: GroupFeature).
SGroupFeature f -> FullGroupPreferences -> GroupFeaturePreference f
getGroupPreference SGroupFeature f
f FullGroupPreferences
gps
        pref' :: GroupFeaturePreference f
pref' = SGroupFeature f -> FullGroupPreferences -> GroupFeaturePreference f
forall p (f :: GroupFeature).
GroupPreferenceI p =>
SGroupFeature f -> p -> GroupFeaturePreference f
forall (f :: GroupFeature).
SGroupFeature f -> FullGroupPreferences -> GroupFeaturePreference f
getGroupPreference SGroupFeature f
f FullGroupPreferences
gps'
        state' :: (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
state'@(GroupFeatureEnabled
_, Maybe Int
param', Maybe GroupMemberRole
role') = GroupFeaturePreference f
-> (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
forall (f :: GroupFeature).
GroupFeatureI f =>
GroupFeaturePreference f
-> (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
groupFeatureState GroupFeaturePreference f
pref'
    Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
state (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
-> (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole) -> Bool
forall a. Eq a => a -> a -> Bool
/= (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
state') (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$
      User
-> ChatDirection 'CTGroup d
-> CIContent d
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> CIContent d
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
createInternalChatItem User
user ChatDirection 'CTGroup d
cd (GroupFeature
-> GroupPreference
-> Maybe Int
-> Maybe GroupMemberRole
-> CIContent d
ciContent (SGroupFeature f -> GroupFeature
forall (f :: GroupFeature). SGroupFeature f -> GroupFeature
toGroupFeature SGroupFeature f
f) (GroupFeaturePreference f -> GroupPreference
forall (f :: GroupFeature).
GroupFeatureI f =>
GroupFeaturePreference f -> GroupPreference
toGroupPreference GroupFeaturePreference f
pref') Maybe Int
param' Maybe GroupMemberRole
role') Maybe UTCTime
forall a. Maybe a
Nothing

sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool
sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool
sameGroupProfileInfo GroupProfile
p GroupProfile
p' = GroupProfile
p {groupPreferences = Nothing} GroupProfile -> GroupProfile -> Bool
forall a. Eq a => a -> a -> Bool
== GroupProfile
p' {groupPreferences = Nothing}

createGroupFeatureItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> CM ()
createGroupFeatureItems :: forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> ChatDirection 'CTGroup d
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent d)
-> GroupInfo
-> ExceptT ChatError (ReaderT ChatController IO) ()
createGroupFeatureItems User
user ChatDirection 'CTGroup d
cd GroupFeature
-> GroupPreference
-> Maybe Int
-> Maybe GroupMemberRole
-> CIContent d
ciContent GroupInfo
g = User
-> ChatDirection 'CTGroup d
-> Bool
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent d)
-> GroupInfo
-> CM [AChatItem]
forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> ChatDirection 'CTGroup d
-> Bool
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent d)
-> GroupInfo
-> CM [AChatItem]
createGroupFeatureItems_ User
user ChatDirection 'CTGroup d
cd Bool
False GroupFeature
-> GroupPreference
-> Maybe Int
-> Maybe GroupMemberRole
-> CIContent d
ciContent GroupInfo
g CM [AChatItem]
-> ([AChatItem]
    -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
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 -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ([AChatItem] -> ChatEvent)
-> [AChatItem]
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user

createGroupFeatureItems_ :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> ShowGroupAsSender -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> CM [AChatItem]
createGroupFeatureItems_ :: forall (d :: MsgDirection).
MsgDirectionI d =>
User
-> ChatDirection 'CTGroup d
-> Bool
-> (GroupFeature
    -> GroupPreference
    -> Maybe Int
    -> Maybe GroupMemberRole
    -> CIContent d)
-> GroupInfo
-> CM [AChatItem]
createGroupFeatureItems_ User
user ChatDirection 'CTGroup d
cd Bool
showGroupAsSender GroupFeature
-> GroupPreference
-> Maybe Int
-> Maybe GroupMemberRole
-> CIContent d
ciContent GroupInfo {FullGroupPreferences
fullGroupPreferences :: GroupInfo -> FullGroupPreferences
fullGroupPreferences :: FullGroupPreferences
fullGroupPreferences} =
  [AGroupFeature]
-> (AGroupFeature
    -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> CM [AChatItem]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AGroupFeature]
allGroupFeatures ((AGroupFeature
  -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
 -> CM [AChatItem])
-> (AGroupFeature
    -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> CM [AChatItem]
forall a b. (a -> b) -> a -> b
$ \(AGF SGroupFeature f
f) -> do
    let p :: GroupFeaturePreference f
p = SGroupFeature f -> FullGroupPreferences -> GroupFeaturePreference f
forall p (f :: GroupFeature).
GroupPreferenceI p =>
SGroupFeature f -> p -> GroupFeaturePreference f
forall (f :: GroupFeature).
SGroupFeature f -> FullGroupPreferences -> GroupFeaturePreference f
getGroupPreference SGroupFeature f
f FullGroupPreferences
fullGroupPreferences
        (GroupFeatureEnabled
_, Maybe Int
param, Maybe GroupMemberRole
role) = GroupFeaturePreference f
-> (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
forall (f :: GroupFeature).
GroupFeatureI f =>
GroupFeaturePreference f
-> (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
groupFeatureState GroupFeaturePreference f
p
    User
-> ChatDirection 'CTGroup d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
createChatItem User
user ChatDirection 'CTGroup d
cd Bool
showGroupAsSender (GroupFeature
-> GroupPreference
-> Maybe Int
-> Maybe GroupMemberRole
-> CIContent d
ciContent (SGroupFeature f -> GroupFeature
forall (f :: GroupFeature). SGroupFeature f -> GroupFeature
toGroupFeature SGroupFeature f
f) (GroupFeaturePreference f -> GroupPreference
forall (f :: GroupFeature).
GroupFeatureI f =>
GroupFeaturePreference f -> GroupPreference
toGroupPreference GroupFeaturePreference f
p) Maybe Int
param Maybe GroupMemberRole
role) Maybe SharedMsgId
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing

createInternalChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem :: forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> CIContent d
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) ()
createInternalChatItem User
user ChatDirection c d
cd CIContent d
content Maybe UTCTime
itemTs_ = do
  AChatItem
ci <- User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
createChatItem User
user ChatDirection c d
cd Bool
False CIContent d
content Maybe SharedMsgId
forall a. Maybe a
Nothing Maybe UTCTime
itemTs_
  ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ User -> [AChatItem] -> ChatEvent
CEvtNewChatItems User
user [Item [AChatItem]
AChatItem
ci]

createChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Maybe UTCTime -> CM AChatItem
createChatItem :: forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> Maybe UTCTime
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
createChatItem User
user ChatDirection c d
cd Bool
showGroupAsSender CIContent d
content Maybe SharedMsgId
sharedMsgId Maybe UTCTime
itemTs_ =
  ReaderT ChatController IO [Either ChatError AChatItem]
-> ExceptT
     ChatError (ReaderT ChatController IO) [Either ChatError AChatItem]
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 (User
-> Maybe UTCTime
-> [(ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])]
-> ReaderT ChatController IO [Either ChatError AChatItem]
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> Maybe UTCTime
-> [(ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])]
-> ReaderT ChatController IO [Either ChatError AChatItem]
createChatItems User
user Maybe UTCTime
itemTs_ [(ChatDirection c d
cd, Bool
showGroupAsSender, [(CIContent d
content, Maybe SharedMsgId
sharedMsgId)])]) ExceptT
  ChatError (ReaderT ChatController IO) [Either ChatError AChatItem]
-> ([Either ChatError AChatItem]
    -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> ExceptT ChatError (ReaderT ChatController IO) 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
    [Right AChatItem
ci] -> AChatItem
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AChatItem
ci
    [Left ChatError
e] -> ChatError
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a.
ChatError -> ExceptT ChatError (ReaderT ChatController IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ChatError
e
    [Either ChatError AChatItem]
rs -> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a. ChatErrorType -> CM a
throwChatError (ChatErrorType
 -> ExceptT ChatError (ReaderT ChatController IO) AChatItem)
-> ChatErrorType
-> ExceptT ChatError (ReaderT ChatController IO) AChatItem
forall a b. (a -> b) -> a -> b
$ String -> ChatErrorType
CEInternalError (String -> ChatErrorType) -> String -> ChatErrorType
forall a b. (a -> b) -> a -> b
$ String
"createInternalChatItem: expected 1 result, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Either ChatError AChatItem] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either ChatError AChatItem]
rs)

-- Supports items with shared msg ID that are created for all conversation parties, but were not communicated via the usual messages.
-- This includes address welcome message and contact request message.
createChatItems ::
  forall c d.
  (ChatTypeI c, MsgDirectionI d) =>
  User ->
  Maybe UTCTime ->
  [(ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)])] ->
  CM' [Either ChatError AChatItem]
createChatItems :: forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
User
-> Maybe UTCTime
-> [(ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])]
-> ReaderT ChatController IO [Either ChatError AChatItem]
createChatItems User
user Maybe UTCTime
itemTs_ [(ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])]
dirsCIContents = do
  UTCTime
createdAt <- IO UTCTime -> ReaderT ChatController IO UTCTime
forall a. IO a -> ReaderT ChatController IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let itemTs :: UTCTime
itemTs = UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe UTCTime
createdAt Maybe UTCTime
itemTs_
  VersionRangeChat
vr <- CM' VersionRangeChat
chatVersionRange'
  ReaderT ChatController IO [Either ChatError ()]
-> ReaderT ChatController IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT ChatController IO [Either ChatError ()]
 -> ReaderT ChatController IO ())
-> ((Connection -> [IO ()])
    -> ReaderT ChatController IO [Either ChatError ()])
-> (Connection -> [IO ()])
-> ReaderT ChatController IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> [IO ()])
-> ReaderT ChatController IO [Either ChatError ()]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' ((Connection -> [IO ()]) -> ReaderT ChatController IO ())
-> (Connection -> [IO ()]) -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ((ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])
 -> IO ())
-> [(ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])]
-> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (Connection
-> VersionRangeChat
-> UTCTime
-> (ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])
-> IO ()
updateChat Connection
db VersionRangeChat
vr UTCTime
createdAt) [(ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])]
dirsCIContents
  (Connection -> [IO AChatItem])
-> ReaderT ChatController IO [Either ChatError AChatItem]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' ((Connection -> [IO AChatItem])
 -> ReaderT ChatController IO [Either ChatError AChatItem])
-> (Connection -> [IO AChatItem])
-> ReaderT ChatController IO [Either ChatError AChatItem]
forall a b. (a -> b) -> a -> b
$ \Connection
db -> ((ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])
 -> [IO AChatItem])
-> [(ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])]
-> [IO AChatItem]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Connection
-> UTCTime
-> UTCTime
-> (ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])
-> [IO AChatItem]
createACIs Connection
db UTCTime
itemTs UTCTime
createdAt) [(ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])]
dirsCIContents
  where
    updateChat :: DB.Connection -> VersionRangeChat -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> IO ()
    updateChat :: Connection
-> VersionRangeChat
-> UTCTime
-> (ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])
-> IO ()
updateChat Connection
db VersionRangeChat
vr UTCTime
createdAt (ChatDirection c d
cd, Bool
_, [(CIContent d, Maybe SharedMsgId)]
contents)
      | ((CIContent d, Maybe SharedMsgId) -> Bool)
-> [(CIContent d, Maybe SharedMsgId)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CIContent d -> Bool
forall (d :: MsgDirection). MsgDirectionI d => CIContent d -> Bool
ciRequiresAttention (CIContent d -> Bool)
-> ((CIContent d, Maybe SharedMsgId) -> CIContent d)
-> (CIContent d, Maybe SharedMsgId)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CIContent d, Maybe SharedMsgId) -> CIContent d
forall a b. (a, b) -> a
fst) [(CIContent d, Maybe SharedMsgId)]
contents Bool -> Bool -> Bool
|| ChatDirection c d -> Bool
forall (c :: ChatType) (d :: MsgDirection).
ChatDirection c d -> Bool
contactChatDeleted ChatDirection c d
cd = IO (ChatInfo c) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ChatInfo c) -> IO ()) -> IO (ChatInfo c) -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection
-> VersionRangeChat
-> User
-> ChatDirection c d
-> UTCTime
-> Maybe (Int, MemberAttention, Int)
-> IO (ChatInfo c)
forall (c :: ChatType) (d :: MsgDirection).
Connection
-> VersionRangeChat
-> User
-> ChatDirection c d
-> UTCTime
-> Maybe (Int, MemberAttention, Int)
-> IO (ChatInfo c)
updateChatTsStats Connection
db VersionRangeChat
vr User
user ChatDirection c d
cd UTCTime
createdAt Maybe (Int, MemberAttention, Int)
memberChatStats
      | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        memberChatStats :: Maybe (Int, MemberAttention, Int)
        memberChatStats :: Maybe (Int, MemberAttention, Int)
memberChatStats = case ChatDirection c d
cd of
          CDGroupRcv GroupInfo
_g (Just GroupChatScopeInfo
scope) GroupMember
m -> do
            let unread :: Int
unread = [(CIContent d, Maybe SharedMsgId)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(CIContent d, Maybe SharedMsgId)] -> Int)
-> [(CIContent d, Maybe SharedMsgId)] -> Int
forall a b. (a -> b) -> a -> b
$ ((CIContent d, Maybe SharedMsgId) -> Bool)
-> [(CIContent d, Maybe SharedMsgId)]
-> [(CIContent d, Maybe SharedMsgId)]
forall a. (a -> Bool) -> [a] -> [a]
filter (CIContent d -> Bool
forall (d :: MsgDirection). MsgDirectionI d => CIContent d -> Bool
ciRequiresAttention (CIContent d -> Bool)
-> ((CIContent d, Maybe SharedMsgId) -> CIContent d)
-> (CIContent d, Maybe SharedMsgId)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CIContent d, Maybe SharedMsgId) -> CIContent d
forall a b. (a, b) -> a
fst) [(CIContent d, Maybe SharedMsgId)]
contents
             in (Int, MemberAttention, Int) -> Maybe (Int, MemberAttention, Int)
forall a. a -> Maybe a
Just (Int
unread, Int
-> Maybe UTCTime
-> GroupMember
-> GroupChatScopeInfo
-> MemberAttention
memberAttentionChange Int
unread Maybe UTCTime
itemTs_ GroupMember
m GroupChatScopeInfo
scope, Int
0)
          ChatDirection c d
_ -> Maybe (Int, MemberAttention, Int)
forall a. Maybe a
Nothing
    createACIs :: DB.Connection -> UTCTime -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> [IO AChatItem]
    createACIs :: Connection
-> UTCTime
-> UTCTime
-> (ChatDirection c d, Bool, [(CIContent d, Maybe SharedMsgId)])
-> [IO AChatItem]
createACIs Connection
db UTCTime
itemTs UTCTime
createdAt (ChatDirection c d
cd, Bool
showGroupAsSender, [(CIContent d, Maybe SharedMsgId)]
contents) = ((CIContent d, Maybe SharedMsgId) -> IO AChatItem)
-> [(CIContent d, Maybe SharedMsgId)] -> [IO AChatItem]
forall a b. (a -> b) -> [a] -> [b]
map (CIContent d, Maybe SharedMsgId) -> IO AChatItem
createACI [(CIContent d, Maybe SharedMsgId)]
contents
      where
        createACI :: (CIContent d, Maybe SharedMsgId) -> IO AChatItem
createACI (CIContent d
content, Maybe SharedMsgId
sharedMsgId) = do
          UserId
ciId <- Connection
-> User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> UTCTime
-> UTCTime
-> IO UserId
forall (c :: ChatType) (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> ChatDirection c d
-> Bool
-> CIContent d
-> Maybe SharedMsgId
-> UTCTime
-> UTCTime
-> IO UserId
createNewChatItemNoMsg Connection
db User
user ChatDirection c d
cd Bool
showGroupAsSender CIContent d
content Maybe SharedMsgId
sharedMsgId UTCTime
itemTs UTCTime
createdAt
          let ci :: ChatItem c d
ci = ChatDirection c d
-> Bool
-> UserId
-> CIContent d
-> Maybe (CIFile d)
-> Maybe (CIQuote c)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem c d
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
ChatDirection c d
-> Bool
-> UserId
-> CIContent d
-> Maybe (CIFile d)
-> Maybe (CIQuote c)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem c d
mkChatItem ChatDirection c d
cd Bool
showGroupAsSender UserId
ciId CIContent d
content Maybe (CIFile d)
forall a. Maybe a
Nothing Maybe (CIQuote c)
forall a. Maybe a
Nothing Maybe SharedMsgId
forall a. Maybe a
Nothing Maybe CIForwardedFrom
forall a. Maybe a
Nothing Maybe CITimed
forall a. Maybe a
Nothing Bool
False Bool
False UTCTime
itemTs Maybe UserId
forall a. Maybe a
Nothing UTCTime
createdAt
          AChatItem -> IO AChatItem
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AChatItem -> IO AChatItem) -> AChatItem -> IO AChatItem
forall a b. (a -> b) -> a -> b
$ SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
SChatType c
-> SMsgDirection d -> ChatInfo c -> ChatItem c d -> AChatItem
AChatItem (forall (c :: ChatType). ChatTypeI c => SChatType c
chatTypeI @c) (forall (d :: MsgDirection). MsgDirectionI d => SMsgDirection d
msgDirection @d) (ChatDirection c d -> ChatInfo c
forall (c :: ChatType) (d :: MsgDirection).
ChatDirection c d -> ChatInfo c
toChatInfo ChatDirection c d
cd) ChatItem c d
ci

memberAttentionChange :: Int -> (Maybe UTCTime) -> GroupMember -> GroupChatScopeInfo -> MemberAttention
memberAttentionChange :: Int
-> Maybe UTCTime
-> GroupMember
-> GroupChatScopeInfo
-> MemberAttention
memberAttentionChange Int
unread Maybe UTCTime
brokerTs_ GroupMember
rcvMem = \case
  GCSIMemberSupport (Just GroupMember
suppMem)
    | GroupMember -> UserId
groupMemberId' GroupMember
suppMem UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMember -> UserId
groupMemberId' GroupMember
rcvMem -> Int -> Maybe UTCTime -> MemberAttention
MAInc Int
unread Maybe UTCTime
brokerTs_
    | Bool
msgIsNewerThanLastUnanswered -> MemberAttention
MAReset
    | Bool
otherwise -> Int -> Maybe UTCTime -> MemberAttention
MAInc Int
0 Maybe UTCTime
forall a. Maybe a
Nothing
    where
      msgIsNewerThanLastUnanswered :: Bool
msgIsNewerThanLastUnanswered = case (GroupMember -> Maybe GroupSupportChat
supportChat GroupMember
suppMem Maybe GroupSupportChat
-> (GroupSupportChat -> 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
>>= GroupSupportChat -> Maybe UTCTime
lastMsgFromMemberTs, Maybe UTCTime
brokerTs_) of
        (Just UTCTime
lastMsgTs, Just UTCTime
brokerTs) -> UTCTime
lastMsgTs UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
brokerTs
        (Maybe UTCTime, Maybe UTCTime)
_ -> Bool
False
  GCSIMemberSupport Maybe GroupMember
Nothing -> Int -> Maybe UTCTime -> MemberAttention
MAInc Int
0 Maybe UTCTime
forall a. Maybe a
Nothing

createLocalChatItems ::
  User ->
  ChatDirection 'CTLocal 'MDSnd ->
  NonEmpty (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) ->
  UTCTime ->
  CM [ChatItem 'CTLocal 'MDSnd]
createLocalChatItems :: User
-> ChatDirection 'CTLocal 'MDSnd
-> NonEmpty
     (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom,
      (ContactName, Maybe MarkdownList))
-> UTCTime
-> CM [ChatItem 'CTLocal 'MDSnd]
createLocalChatItems User
user ChatDirection 'CTLocal 'MDSnd
cd NonEmpty
  (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom,
   (ContactName, Maybe MarkdownList))
itemsData UTCTime
createdAt = do
  VersionRangeChat
vr <- CM VersionRangeChat
chatVersionRange
  ExceptT ChatError (ReaderT ChatController IO) (ChatInfo 'CTLocal)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT ChatError (ReaderT ChatController IO) (ChatInfo 'CTLocal)
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT
     ChatError (ReaderT ChatController IO) (ChatInfo 'CTLocal)
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ (Connection -> IO (ChatInfo 'CTLocal))
-> ExceptT
     ChatError (ReaderT ChatController IO) (ChatInfo 'CTLocal)
forall a. (Connection -> IO a) -> CM a
withStore' ((Connection -> IO (ChatInfo 'CTLocal))
 -> ExceptT
      ChatError (ReaderT ChatController IO) (ChatInfo 'CTLocal))
-> (Connection -> IO (ChatInfo 'CTLocal))
-> ExceptT
     ChatError (ReaderT ChatController IO) (ChatInfo 'CTLocal)
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> VersionRangeChat
-> User
-> ChatDirection 'CTLocal 'MDSnd
-> UTCTime
-> Maybe (Int, MemberAttention, Int)
-> IO (ChatInfo 'CTLocal)
forall (c :: ChatType) (d :: MsgDirection).
Connection
-> VersionRangeChat
-> User
-> ChatDirection c d
-> UTCTime
-> Maybe (Int, MemberAttention, Int)
-> IO (ChatInfo c)
updateChatTsStats Connection
db VersionRangeChat
vr User
user ChatDirection 'CTLocal 'MDSnd
cd UTCTime
createdAt Maybe (Int, MemberAttention, Int)
forall a. Maybe a
Nothing
  ([ChatError]
errs, [ChatItem 'CTLocal 'MDSnd]
items) <- ReaderT ChatController IO ([ChatError], [ChatItem 'CTLocal 'MDSnd])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItem 'CTLocal 'MDSnd])
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 ([ChatError], [ChatItem 'CTLocal 'MDSnd])
 -> ExceptT
      ChatError
      (ReaderT ChatController IO)
      ([ChatError], [ChatItem 'CTLocal 'MDSnd]))
-> ReaderT
     ChatController IO ([ChatError], [ChatItem 'CTLocal 'MDSnd])
-> ExceptT
     ChatError
     (ReaderT ChatController IO)
     ([ChatError], [ChatItem 'CTLocal 'MDSnd])
forall a b. (a -> b) -> a -> b
$ [Either ChatError (ChatItem 'CTLocal 'MDSnd)]
-> ([ChatError], [ChatItem 'CTLocal 'MDSnd])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ChatError (ChatItem 'CTLocal 'MDSnd)]
 -> ([ChatError], [ChatItem 'CTLocal 'MDSnd]))
-> ReaderT
     ChatController IO [Either ChatError (ChatItem 'CTLocal 'MDSnd)]
-> ReaderT
     ChatController IO ([ChatError], [ChatItem 'CTLocal 'MDSnd])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Connection -> [IO (ChatItem 'CTLocal 'MDSnd)])
-> ReaderT
     ChatController IO [Either ChatError (ChatItem 'CTLocal 'MDSnd)]
forall (t :: * -> *) a.
Traversable t =>
(Connection -> t (IO a)) -> CM' (t (Either ChatError a))
withStoreBatch' (\Connection
db -> ((CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom,
  (ContactName, Maybe MarkdownList))
 -> IO (ChatItem 'CTLocal 'MDSnd))
-> [(CIContent 'MDSnd, Maybe (CIFile 'MDSnd),
     Maybe CIForwardedFrom, (ContactName, Maybe MarkdownList))]
-> [IO (ChatItem 'CTLocal 'MDSnd)]
forall a b. (a -> b) -> [a] -> [b]
map (Connection
-> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom,
    (ContactName, Maybe MarkdownList))
-> IO (ChatItem 'CTLocal 'MDSnd)
createItem Connection
db) ([(CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom,
   (ContactName, Maybe MarkdownList))]
 -> [IO (ChatItem 'CTLocal 'MDSnd)])
-> [(CIContent 'MDSnd, Maybe (CIFile 'MDSnd),
     Maybe CIForwardedFrom, (ContactName, Maybe MarkdownList))]
-> [IO (ChatItem 'CTLocal 'MDSnd)]
forall a b. (a -> b) -> a -> b
$ NonEmpty
  (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom,
   (ContactName, Maybe MarkdownList))
-> [(CIContent 'MDSnd, Maybe (CIFile 'MDSnd),
     Maybe CIForwardedFrom, (ContactName, Maybe MarkdownList))]
forall a. NonEmpty a -> [a]
L.toList NonEmpty
  (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom,
   (ContactName, Maybe MarkdownList))
itemsData)
  Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
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) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
toView (ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ChatEvent -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ [ChatError] -> ChatEvent
CEvtChatErrors [ChatError]
errs
  [ChatItem 'CTLocal 'MDSnd] -> CM [ChatItem 'CTLocal 'MDSnd]
forall a. a -> ExceptT ChatError (ReaderT ChatController IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ChatItem 'CTLocal 'MDSnd]
items
  where
    createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd)
    createItem :: Connection
-> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom,
    (ContactName, Maybe MarkdownList))
-> IO (ChatItem 'CTLocal 'MDSnd)
createItem Connection
db (CIContent 'MDSnd
content, Maybe (CIFile 'MDSnd)
ciFile, Maybe CIForwardedFrom
itemForwarded, (ContactName, Maybe MarkdownList)
ts) = do
      UserId
ciId <- Connection
-> User
-> ChatDirection 'CTLocal 'MDSnd
-> Bool
-> Maybe UserId
-> Maybe SharedMsgId
-> CIContent 'MDSnd
-> NewQuoteRow
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> IO UserId
forall (c :: ChatType) (d :: MsgDirection).
MsgDirectionI d =>
Connection
-> User
-> ChatDirection c d
-> Bool
-> Maybe UserId
-> Maybe SharedMsgId
-> CIContent d
-> NewQuoteRow
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> IO UserId
createNewChatItem_ Connection
db User
user ChatDirection 'CTLocal 'MDSnd
cd Bool
False Maybe UserId
forall a. Maybe a
Nothing Maybe SharedMsgId
forall a. Maybe a
Nothing CIContent 'MDSnd
content (Maybe SharedMsgId
forall a. Maybe a
Nothing, Maybe UTCTime
forall a. Maybe a
Nothing, Maybe MsgContent
forall a. Maybe a
Nothing, Maybe Bool
forall a. Maybe a
Nothing, Maybe MemberId
forall a. Maybe a
Nothing) Maybe CIForwardedFrom
itemForwarded Maybe CITimed
forall a. Maybe a
Nothing Bool
False Bool
False UTCTime
createdAt Maybe UserId
forall a. Maybe a
Nothing UTCTime
createdAt
      Maybe (CIFile 'MDSnd) -> (CIFile 'MDSnd -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (CIFile 'MDSnd)
ciFile ((CIFile 'MDSnd -> IO ()) -> IO ())
-> (CIFile 'MDSnd -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CIFile {UserId
fileId :: forall (d :: MsgDirection). CIFile d -> UserId
fileId :: UserId
fileId} -> Connection -> UserId -> UserId -> UTCTime -> IO ()
updateFileTransferChatItemId Connection
db UserId
fileId UserId
ciId UTCTime
createdAt
      ChatItem 'CTLocal 'MDSnd -> IO (ChatItem 'CTLocal 'MDSnd)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChatItem 'CTLocal 'MDSnd -> IO (ChatItem 'CTLocal 'MDSnd))
-> ChatItem 'CTLocal 'MDSnd -> IO (ChatItem 'CTLocal 'MDSnd)
forall a b. (a -> b) -> a -> b
$ ChatDirection 'CTLocal 'MDSnd
-> Bool
-> UserId
-> CIContent 'MDSnd
-> (ContactName, Maybe MarkdownList)
-> Maybe (CIFile 'MDSnd)
-> Maybe (CIQuote 'CTLocal)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem 'CTLocal 'MDSnd
forall (c :: ChatType) (d :: MsgDirection).
(ChatTypeI c, MsgDirectionI d) =>
ChatDirection c d
-> Bool
-> UserId
-> CIContent d
-> (ContactName, Maybe MarkdownList)
-> Maybe (CIFile d)
-> Maybe (CIQuote c)
-> Maybe SharedMsgId
-> Maybe CIForwardedFrom
-> Maybe CITimed
-> Bool
-> Bool
-> UTCTime
-> Maybe UserId
-> UTCTime
-> ChatItem c d
mkChatItem_ ChatDirection 'CTLocal 'MDSnd
cd Bool
False UserId
ciId CIContent 'MDSnd
content (ContactName, Maybe MarkdownList)
ts Maybe (CIFile 'MDSnd)
ciFile Maybe (CIQuote 'CTLocal)
forall a. Maybe a
Nothing Maybe SharedMsgId
forall a. Maybe a
Nothing Maybe CIForwardedFrom
itemForwarded Maybe CITimed
forall a. Maybe a
Nothing Bool
False Bool
False UTCTime
createdAt Maybe UserId
forall a. Maybe a
Nothing UTCTime
createdAt

withUser' :: (User -> CM ChatResponse) -> CM ChatResponse
withUser' :: (User -> CM ChatResponse) -> CM ChatResponse
withUser' User -> CM ChatResponse
action =
  (ChatController -> TVar (Maybe User))
-> ExceptT
     ChatError (ReaderT ChatController IO) (TVar (Maybe User))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Maybe User)
currentUser
    ExceptT ChatError (ReaderT ChatController IO) (TVar (Maybe User))
-> (TVar (Maybe User)
    -> ExceptT ChatError (ReaderT ChatController IO) (Maybe User))
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe User)
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
>>= TVar (Maybe User)
-> ExceptT ChatError (ReaderT ChatController IO) (Maybe User)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO
    ExceptT ChatError (ReaderT ChatController IO) (Maybe User)
-> (Maybe User -> CM ChatResponse) -> CM ChatResponse
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
>>= CM ChatResponse
-> (User -> CM ChatResponse) -> Maybe User -> CM ChatResponse
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ChatErrorType -> CM ChatResponse
forall a. ChatErrorType -> CM a
throwChatError ChatErrorType
CENoActiveUser) User -> CM ChatResponse
action

withUser :: (User -> CM ChatResponse) -> CM ChatResponse
withUser :: (User -> CM ChatResponse) -> CM ChatResponse
withUser User -> CM ChatResponse
action = (User -> CM ChatResponse) -> CM ChatResponse
withUser' ((User -> CM ChatResponse) -> CM ChatResponse)
-> (User -> CM ChatResponse) -> CM ChatResponse
forall a b. (a -> b) -> a -> b
$ \User
user ->
  CM Bool -> CM ChatResponse -> CM ChatResponse -> CM ChatResponse
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (ReaderT ChatController IO Bool -> CM Bool
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 Bool
chatStarted) (User -> CM ChatResponse
action User
user) (ChatErrorType -> CM ChatResponse
forall a. ChatErrorType -> CM a
throwChatError ChatErrorType
CEChatNotStarted)

withUser_ :: CM ChatResponse -> CM ChatResponse
withUser_ :: CM ChatResponse -> CM ChatResponse
withUser_ = (User -> CM ChatResponse) -> CM ChatResponse
withUser ((User -> CM ChatResponse) -> CM ChatResponse)
-> (CM ChatResponse -> User -> CM ChatResponse)
-> CM ChatResponse
-> CM ChatResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CM ChatResponse -> User -> CM ChatResponse
forall a b. a -> b -> a
const

withUserId' :: UserId -> (User -> CM ChatResponse) -> CM ChatResponse
withUserId' :: UserId -> (User -> CM ChatResponse) -> CM ChatResponse
withUserId' UserId
userId User -> CM ChatResponse
action = (User -> CM ChatResponse) -> CM ChatResponse
withUser' ((User -> CM ChatResponse) -> CM ChatResponse)
-> (User -> CM ChatResponse) -> CM ChatResponse
forall a b. (a -> b) -> a -> b
$ \User
user -> do
  UserId -> User -> ExceptT ChatError (ReaderT ChatController IO) ()
checkSameUser UserId
userId User
user
  User -> CM ChatResponse
action User
user

withUserId :: UserId -> (User -> CM ChatResponse) -> CM ChatResponse
withUserId :: UserId -> (User -> CM ChatResponse) -> CM ChatResponse
withUserId UserId
userId User -> CM ChatResponse
action = (User -> CM ChatResponse) -> CM ChatResponse
withUser ((User -> CM ChatResponse) -> CM ChatResponse)
-> (User -> CM ChatResponse) -> CM ChatResponse
forall a b. (a -> b) -> a -> b
$ \User
user -> do
  UserId -> User -> ExceptT ChatError (ReaderT ChatController IO) ()
checkSameUser UserId
userId User
user
  User -> CM ChatResponse
action User
user

checkSameUser :: UserId -> User -> CM ()
checkSameUser :: UserId -> User -> ExceptT ChatError (ReaderT ChatController IO) ()
checkSameUser UserId
userId User {userId :: User -> UserId
userId = UserId
activeUserId} = Bool
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UserId
userId UserId -> UserId -> Bool
forall a. Eq a => a -> a -> Bool
/= UserId
activeUserId) (ExceptT ChatError (ReaderT ChatController IO) ()
 -> ExceptT ChatError (ReaderT ChatController IO) ())
-> ExceptT ChatError (ReaderT ChatController IO) ()
-> ExceptT ChatError (ReaderT ChatController IO) ()
forall a b. (a -> b) -> a -> b
$ ChatErrorType -> ExceptT ChatError (ReaderT ChatController IO) ()
forall a. ChatErrorType -> CM a
throwChatError (UserId -> UserId -> ChatErrorType
CEDifferentActiveUser UserId
userId UserId
activeUserId)

chatStarted :: CM' Bool
chatStarted :: ReaderT ChatController IO Bool
chatStarted = (Maybe (Async (), Maybe (Async ())) -> Bool)
-> ReaderT ChatController IO (Maybe (Async (), Maybe (Async ())))
-> ReaderT ChatController IO Bool
forall a b.
(a -> b)
-> ReaderT ChatController IO a -> ReaderT ChatController IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Async (), Maybe (Async ())) -> Bool
forall a. Maybe a -> Bool
isJust (ReaderT ChatController IO (Maybe (Async (), Maybe (Async ())))
 -> ReaderT ChatController IO Bool)
-> (TVar (Maybe (Async (), Maybe (Async ())))
    -> ReaderT ChatController IO (Maybe (Async (), Maybe (Async ()))))
-> TVar (Maybe (Async (), Maybe (Async ())))
-> ReaderT ChatController IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Maybe (Async (), Maybe (Async ())))
-> ReaderT ChatController IO (Maybe (Async (), Maybe (Async ())))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (Maybe (Async (), Maybe (Async ())))
 -> ReaderT ChatController IO Bool)
-> ReaderT
     ChatController IO (TVar (Maybe (Async (), Maybe (Async ()))))
-> ReaderT ChatController IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ChatController -> TVar (Maybe (Async (), Maybe (Async ()))))
-> ReaderT
     ChatController IO (TVar (Maybe (Async (), Maybe (Async ()))))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Maybe (Async (), Maybe (Async ())))
agentAsync

waitChatStartedAndActivated :: CM' ()
waitChatStartedAndActivated :: ReaderT ChatController IO ()
waitChatStartedAndActivated = do
  TVar (Maybe (Async (), Maybe (Async ())))
agentStarted <- (ChatController -> TVar (Maybe (Async (), Maybe (Async ()))))
-> ReaderT
     ChatController IO (TVar (Maybe (Async (), Maybe (Async ()))))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar (Maybe (Async (), Maybe (Async ())))
agentAsync
  TVar Bool
chatActivated <- (ChatController -> TVar Bool)
-> ReaderT ChatController IO (TVar Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> TVar Bool
chatActivated
  STM () -> ReaderT ChatController IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT ChatController IO ())
-> STM () -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (Async (), Maybe (Async ()))
started <- TVar (Maybe (Async (), Maybe (Async ())))
-> STM (Maybe (Async (), Maybe (Async ())))
forall a. TVar a -> STM a
readTVar TVar (Maybe (Async (), Maybe (Async ())))
agentStarted
    Bool
activated <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
chatActivated
    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (Async (), Maybe (Async ())) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Async (), Maybe (Async ()))
started Bool -> Bool -> Bool
&& Bool
activated) STM ()
forall a. STM a
retry

chatVersionRange :: CM VersionRangeChat
chatVersionRange :: CM VersionRangeChat
chatVersionRange = CM' VersionRangeChat -> CM VersionRangeChat
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 CM' VersionRangeChat
chatVersionRange'
{-# INLINE chatVersionRange #-}

chatVersionRange' :: CM' VersionRangeChat
chatVersionRange' :: CM' VersionRangeChat
chatVersionRange' = do
  ChatConfig {VersionRangeChat
chatVRange :: VersionRangeChat
chatVRange :: ChatConfig -> VersionRangeChat
chatVRange} <- (ChatController -> ChatConfig)
-> ReaderT ChatController IO ChatConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ChatController -> ChatConfig
config
  VersionRangeChat -> CM' VersionRangeChat
forall a. a -> ReaderT ChatController IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VersionRangeChat
chatVRange
{-# INLINE chatVersionRange' #-}

adminContactReq :: ConnReqContact
adminContactReq :: ConnectionRequestUri 'CMContact
adminContactReq =
  (String -> ConnectionRequestUri 'CMContact)
-> (ConnectionRequestUri 'CMContact
    -> ConnectionRequestUri 'CMContact)
-> Either String (ConnectionRequestUri 'CMContact)
-> ConnectionRequestUri 'CMContact
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ConnectionRequestUri 'CMContact
forall a. HasCallStack => String -> a
error ConnectionRequestUri 'CMContact -> ConnectionRequestUri 'CMContact
forall a. a -> a
id (Either String (ConnectionRequestUri 'CMContact)
 -> ConnectionRequestUri 'CMContact)
-> Either String (ConnectionRequestUri 'CMContact)
-> ConnectionRequestUri 'CMContact
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String (ConnectionRequestUri 'CMContact)
forall a. StrEncoding a => ByteString -> Either String a
strDecode ByteString
"simplex:/contact#/?v=1&smp=smp%3A%2F%2FPQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo%3D%40smp6.simplex.im%2FK1rslx-m5bpXVIdMZg9NLUZ_8JBm8xTt%23MCowBQYDK2VuAyEALDeVe-sG8mRY22LsXlPgiwTNs9dbiLrNuA7f3ZMAJ2w%3D"

simplexTeamContactProfile :: Profile
simplexTeamContactProfile :: Profile
simplexTeamContactProfile =
  Profile
    { displayName :: ContactName
displayName = ContactName
"Ask SimpleX Team",
      fullName :: ContactName
fullName = ContactName
"",
      shortDescr :: Maybe ContactName
shortDescr = ContactName -> Maybe ContactName
forall a. a -> Maybe a
Just ContactName
"Send questions about SimpleX Chat app and your suggestions",
      image :: Maybe ImageData
image = ImageData -> Maybe ImageData
forall a. a -> Maybe a
Just (ContactName -> ImageData
ImageData ContactName
"data:image/jpg;base64,/9j/4AAQSkZJRgABAgAAAQABAAD/2wBDAAUDBAQEAwUEBAQFBQUGBwwIBwcHBw8KCwkMEQ8SEhEPERATFhwXExQaFRARGCEYGhwdHx8fExciJCIeJBweHx7/2wBDAQUFBQcGBw4ICA4eFBEUHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh4eHh7/wAARCAETARMDASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAAAgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKSo0NTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl5ufo6erx8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREAAgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYkNOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOEhYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwD7LooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiivP/iF4yFvv0rSpAZek0yn7v+yPeunC4WpiqihBf8A8rOc5w2UYZ4jEPTourfZDvH3jL7MW03SpR53SWUfw+w96veA/F0erRLY3zKl6owD2k/8Ar15EWLEljknqadDK8MqyxMUdTlWB5Br66WS0Hh/ZLfv1ufiNLj7Mo5m8ZJ3g9OTpy+Xn5/pofRdFcd4B8XR6tEthfMEvVHyk9JB/jXY18fiMPUw9R06i1P3PK80w2aYaOIw8rxf3p9n5hRRRWB6AUUVDe3UFlavc3MixxIMsxppNuyJnOMIuUnZIL26gsrV7m5kWOJBlmNeU+I/Gd9e6sk1hI8FvA2Y1z973NVPGnimfXLoxRFo7JD8if3vc1zefevr8syiNKPtKyvJ9Ox+F8Ycb1cdU+rYCTjTi/iWjk1+nbue3eEPEdtrtoMER3SD95Hn9R7Vu18+6bf3On3kd1aSmOVDkEd/Y17J4P8SW2vWY6R3aD97F/Ue1eVmmVPDP2lP4fyPtODeMoZrBYXFO1Zf+Tf8AB7r5o3qKKK8Q/QgooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAqavbTXmmz20Fw1vJIhVZB1FeDa3p15pWoSWl6hWQHr2YeoNfQlY3izw9Z6/YGGZQky8xSgcqf8K9jKcyWEnyzXuv8D4njLhZ51RVSi7VYLRdGu3k+z+88HzRuq1rWmXmkX8lnexFHU8Hsw9RVLNfcxlGcVKLumfgFahUozdOorSWjT6E0M0kMqyxOyOpyrKcEGvXPAPjCPVolsb9wl6owGPAkH+NeO5p8M0kMqyxOyOpyrA4INcWPy+njKfLLfoz2+HuIMTkmI9pT1i/ij0a/wA+zPpGiuM+H/jCPV4lsL91S+QfKTwJR/jXW3t1BZWslzcyLHFGMsxNfB4jC1aFX2U1r+fof0Rl2bYXMMKsVRl7vXy7p9rBfXVvZWr3NzKscSDLMTXjnjbxVPrtyYoiY7JD8if3vc0zxv4ruNeujFEWjsoz8if3vc1zOa+synKFh0qtVe9+X/BPxvjLjKWZSeEwjtSW7/m/4H5kmaM1HmlB54r3bH51YkzXo3wz8MXMc0es3ZeED/VR5wW9z7VB8O/BpnMerarEREDuhhb+L3Pt7V6cAAAAAAOgFfL5xmqs6FH5v9D9a4H4MlzQzHGq1tYR/KT/AEXzCiiivlj9hCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxfFvh208QWBhmASdRmKUdVP+FeH63pl5pGoSWV5EUdTwezD1HtX0VWL4t8O2fiHTzBONk6g+TKByp/wr28pzZ4WXs6msH+B8NxdwhTzeDxGHVqy/8m8n59n954FmjNW9b0y80fUHsr2MpIp4PZh6iqWfevuYyjOKlF3TPwetQnRm6dRWktGmSwzSQyrLE7I6nKsDgg1teIPFOqa3a29vdy4jiUAheN7f3jWBmjNROhTnJTkrtbGtLF4ijSnRpzajPddHbuP3e9Lmo80ua0scth+a9E+HXgw3Hl6tqsZEX3oYmH3vc+1J8OPBZnKavq0eIhzDCw+9/tH29q9SAAAAGAOgr5bOM35b0KD16v8ARH6twXwXz8uPx0dN4xfXzf6IFAUAAAAdBRRRXyZ+wBRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFB4GTXyj+1p+0ONJjufA3ga6DX7qU1DUY24gB4McZH8Xqe38tqFCdefLETaSufQ3h/4geEde8Uah4a0rWra51Ow/wBfCrD8ceuO+OldRX5I+GfEWseG/ENvr2j30ttqFvJ5iSqxyT3z6g96/RH9nD41aT8U9AWGcx2fiK1QC7tC33/+mieqn07V14zL3QXNHVEQnc9dooorzjQKKKKACiis7xHrel+HdGudY1m8is7K2QvLLI2AAP600m3ZAYfxUg8Pr4VutT1+7isYbSMuLp/4Pb3z6V8++HNd0zxDpq6hpVys8DHGRwVPoR2NeIftJ/G7VPifrbWVk8lp4btZD9mtwcGU/wDPR/c9h2rgfh34z1LwdrAurV2ktZCBcW5PyyD/AB9DX2WTyqYWny1Ho+nY+C4t4Wp5tF16CtVX/k3k/Ps/vPr/ADRmsjwx4g07xFpMWpaZOJInHI/iQ9wR61qbq+mVmro/D6tCdGbp1FZrdEma6/4XafpWoa7jUpV3oA0MLdJD/ntXG5p8E0kMqyxOyOhyrKcEGsMTRlWpShGVm+p1ZbiYYPFQr1IKai72fU+nFAUAKAAOABRXEfDnxpFrMK6fqDhL9BhSeko9frXb1+a4rDVMNUdOotT+k8szLD5lh44jDu8X968n5hRRRXOegFFFFABUGoXlvYWkl1dSrHFGMliaL+7t7C0kuruVYoYxlmNeI+OvFtx4huzHFuisYz+7jz97/aNenluW1MbU00it2fM8S8SUMkoXetR/DH9X5fmeteF/E+m+IFkFoxSWMnMb9cev0rbr5t0vULrTb6K8s5TFNGcgj+R9q9w8E+KbXxDYjlY7xB+9i/qPaurNsneE/eUtYfkeTwlxjHNV9XxVo1V90vTz8vmjoqKKK8I+8CiiigAooooAKKKKACiiigD5V/a8+P0mgvdeAvCUskepFdl9eDjyQR9xPfHeviiR3lkaSR2d2OWZjkk+tfoj+058CtP+Jektq2jxRWnie2T91KMKLlR/yzf+h7V+fOuaVqGiarcaXqtpLaXls5jlikXDKRX0mWSpOlaG/U56l76lKtPwtr+reGNetdb0S8ls761cPHJG2D9D6g9MVmUV6TSasyD9Jf2cfjXpPxR0MW9w0dp4gtkAubYnHmf7aeo/lXr1fkh4W1/V/DGuW2taHey2d9bOHjkjP6H1HtX6Jfs5fGvR/inoQgmeOz8RWqD7XaE439vMT1U+navnMfgHRfPD4fyN4Tvoz12iis7xJremeHdEutZ1i7jtLK1jLyyucAAf1rzUm3ZGgeJNb0vw7otzrOs3kVpZWyF5ZZDgAD+Z9q/PL9pP436r8UNZaxs2ks/Dlq5+z24ODMf77+p9B2o/aU+N2p/FDXDZ2LS2fhy1ci3t84Mx/wCej+/oO1eNV9DgMAqS55/F+RhOd9EFFFABJwBkmvUMzqPh34y1Lwjq63FszSWshAntyeHHt719Z2EstzpVlqD2txbR3kCzxLPGUbawyODXK/slfs8nUpbXx144tGFkhElhp8q4849pHB/h9B3r608X+GLDxBpX2WRFiljX9xIowUPYfT2rGnnkMPWVJ6x6vt/XU+P4o4SjmtN4igrVV/5N5Pz7P7z56zRmrmvaVe6LqMljexMkiHg9mHqKoZr6uEozipRd0z8Rq0J0ZunUVmtGmTwTSQTJNC7JIhyrKcEGvZvhz41j1mJdP1GRUv0GFY8CX/69eJZqSCaWCVZYXZHU5VlOCDXDmGXU8bT5ZaPo+x7WQZ9iMlxHtKesX8UejX+fZn1FRXDfDbxtHrUKadqDqmoIuAx4EoHf613NfnWKwtTC1HTqKzR/QGW5lh8yw8cRh3eL+9Ps/MKr6heW1hZyXd3KsUUYyzGjUby20+zku7yZYoY13MzGvDPHvi+48RXpjiZorCM/u4/73+0feuvLMsqY6pZaRW7/AK6nlcScR0MloXetR/DH9X5D/Hni648Q3nlxlo7GM/u48/e9zXL7qZmjNfodDDwoU1TpqyR+AY7G18dXlXryvJ/19w/dVvSdRutMvo7yzlaOVDkY7+xqkDmvTPhn4HMxj1jV4v3Y+aCFh97/AGjWGPxNHDUXKrt27+R15JlWLzHFxp4XSS1v/L53PQ/C+oXGqaJb3t1bNbyyLkoe/v8AQ1p0AAAAAADoBRX5nUkpSbirLsf0lh6c6dKMJy5mkrvv5hRRRUGwUUUUAFFFFABRRRQAV4d+038CdO+JWkyavo8cdp4mtkzHIBhbkD+B/f0Ne40VpSqypSUovUTV9GfkTruk6joer3Ok6taS2d7ayGOaGVdrKRVKv0T/AGnfgXp/xK0h9Y0iOO18TWqZikAwLkD+B/6Gvz51zStQ0TVbjS9UtZbW8tnKSxSLgqRX1GExccRG636o55RcSlWp4V1/VvDGvWut6JeSWl9bOGjkQ4/A+oPpWXRXU0mrMk/RP4LftDeFvF3ge41HxDfW+lappkG+/idsBwP40HfJ7V8o/tJ/G/VPifrbWVk8tn4btn/0e2zgykfxv6n0HavGwSM4JGeuO9JXFRwFKlUc18vIpzbVgoooAJIAGSa7SQr6x/ZM/Z4k1J7Xxz44tClkMSWFhIuDL3Ejg/w+g70fsmfs8NqMtt448c2eLJCJLCwlX/WnqHcH+H0HevtFFVECIoVVGAAMACvFx+PtenTfqzWEOrEjRI41jjUIigBVAwAPSnUUV4ZsYXjLwzZeJNOaCcBLhQfJmA5U/wCFeBa/pV7ompSWF9GUkToccMOxHtX01WF4z8M2XiXTTBOAk6AmGYDlD/hXvZPnEsHL2dTWD/A+K4r4UhmsHXoK1Zf+TeT8+z+8+c80Zq5r2k3ui6jJY30ZSRTwezD1FUM1+gQlGcVKLumfiFWjOjN06is1umTwTSQTJNE7JIh3KynBBr2PwL8QrO701odbnSC5t0yZCcCUD+teK5pd1cWPy2ljoctTdbPqetkme4rJ6rqUHdPdPZ/8Mdb4/wDGFz4ivDFGxisIz+7j/ve5rls1HuozXTQw1PD01TpqyR5+OxlfHV5V68ryf9fcSZozTAa9P+GHgQzmPWdZhIjHzQQMPvf7R9qxxuMpYOk6lR/8E6MpyfEZriFQoL1fRLux/wAMvApmMesazFiP70EDfxf7R9vavWFAUAAAAcACgAAAAAAdBRX5xjsdVxtXnn8l2P3/ACXJcNlGHVGivV9W/wCugUUUVxHrhRRRQAUUUUAFFFFABRRRQAUUUUAFeH/tOfArT/iXpUmsaSsVp4mto/3UuMLcgDhH/oe1e4Vn+I9a0zw7otzrGsXkVpZWyF5ZZGwAB/WtaNSdOalDcTSa1PyZ1zStQ0TVrnStVtZLS8tnMcsUgwVIqlXp/wC0l8S7T4nePn1aw0q3srO3XyYJBGBNOoPDSHv7DtXmFfXU5SlBOSszlYUUUVYAAScDk19Zfsmfs7vqLW3jjx1ZFLMESafYSjmXuJHHZfQd6+VtLvJtO1K2v7cRtLbyrKgkQOpKnIyp4I46Gv0b/Zv+NOjfFDw+lrIIrDX7RAtzZ8AMMffj9V9u1efmVSrCn7m3Vl00m9T16NEjjWONVRFGFUDAA9KWiivmToCiiigAooooAwfGnhiy8S6cYJwEuEH7mYDlT/hXz7r+k32h6lJYahFskQ8Hsw9QfSvpjUr2106ykvLyZYYYxlmY18+/EXxa/ijU1aOMRWkGRCCBuPuT/Svr+GK2KcnTSvT/ACfl/kfmPiBhMvUI1m7Vn0XVefp0fy9Oa3UbqZmjNfa2PynlJM+9AOajzTo5GjkV0YqynIPoaVg5T1P4XeA/P8vWdaiIj+9BAw+9/tH29q9dAAAAAAHQVwPwx8dQ63Ammai6R6hGuFJ4Ew9vf2rvq/Ms5qYmeJaxGjWy6W8j+gOFcPl9LAReBd0931b8+3oFFFFeSfSBRRRQAUUUUAFFFFABRRRQAUUUUAFFFZ3iTW9L8OaJdazrN5HaWNqheWWQ4AH+NNJt2QB4l1vTPDmiXWs6xdx2llaxl5ZHOAAO3ufavzx/aT+N2qfFDWzZWbSWfhy2ci3tg2DKf77+p9B2pf2lfjdqfxQ1trGxeW08N2z/AOj2+cGYj/lo/v6DtXjVfQ4DAKkuefxfkYTnfRBRRQAScAZNeoZhRXv3w2/Zh8V+Lfh7deJprgadcvHv02zlT5rgdcsf4Qe1eHa5pWoaJq1zpWq2ktpeW0hjlikXDKwrOFanUk4xd2htNFKtTwrr+reGNdtta0S8ltL22cPHIhx07H1HtWXRWjSasxH6S/s4/GrSfijoYtp3jtfENqg+1WpON4/vp6j27V69X5IeFfEGr+F9etdc0O9ks7+1cPHKh/QjuD3Ffoj+zl8bNI+KWhLbztFZ+IraMfa7TON+Osieqn07V85j8A6L54fD+RvCd9GevUUUV5hoFVtTvrXTbGW9vJligiXczNRqd9aabYy3t7MsMEQyzMa+ffiN42uvE96YoS0OmxH91F3b/ab3r1spympmFSy0it3+i8z57iDiCjlFG71qPZfq/Id8RPGl14lvTFEzRafGf3cf97/aNclmmZozX6Xh8NTw1NU6askfheNxdbG1pV68ryY/NGTTM16R4J+GVxrGkSX+pSSWfmJ/oq45J7MR6Vni8ZRwkOes7I1y7K8TmNX2WHjd7/0zzvJozV3xDpF7oepyWF/EUkQ8HHDD1FZ+feuiEozipRd0zjq0Z0puE1ZrdE0E8sEyTQu0ciHKspwQa9z+GHjuLXIU0zUpFTUEXCseBKB/WvBs1JBPLBMk0LmORCGVlOCDXn5lllLH0uWWjWz7HsZFnlfJ6/tKesXuu6/z7M+tKK4D4X+PItdhTTNSdY9SQYVicCYDuPf2rv6/M8XhKuEqulVVmj92y7MaGYUFXoO6f4Ps/MKKKK5juCiiigAooooAKKKKACiig9KAM7xLrmleG9EudZ1q8jtLG2QvLK5wAPQep9q/PH9pP43ap8T9beyspJbTw3bSH7NbZx5pH8b+p9u1bH7YPxL8XeJPG114V1G0udH0jT5SIrNuDOR0kbs2e3pXgdfRZfgVTSqT3/IwnO+iCiigAkgAZJr1DMK+s/2TP2d31Brbxz46tNtmMSafp8i8y9/MkB6L0wO9J+yb+zwdSe28b+ObLFmpEljYSr/rT1DuP7voO9faCKqIERQqqMAAYAFeLj8fa9Om/VmsIdWEaJGixooVFGFUDAA9K8Q/ac+BWnfErSZNY0mOO08T2yZilAwtyAPuP/Q9q9worx6VWVKSlF6mrSasfkTrmlahomrXOlaray2l7bSGOaKRcMrCqVfon+098C7D4l6U+s6Skdr4mtY/3UmMC5UdI29/Q1+fOt6XqGi6rcaVqlrJa3ls5SWKQYKkV9RhMXHERut+qOeUeUpVqeFfEGreGNdttb0W7ktb22cNG6HH4H1FZdFdTSasyT9Jf2cPjVpXxR0Fbe4eK18Q2qD7Va7sbx/z0T1H8q9V1O+tdNsZb29mWGCJdzMxr8ovAOoeIdK8W2GoeF5podVhlDQtEefcH2PevsbxP4417xTp1jDq3lQGKFPOigJ2NLj5m59849K4KHD0sTX9x2h18vJHj55xDSyqhd61Hsv1fkaXxG8bXXie9MURaLTo2/dR5+9/tH3rkM1HmjNffYfC08NTVOmrJH4ljMXWxtaVau7yZJmgHmmAmvWfhN8PTceVrmuQkRDDW9uw+9/tN7Vjj8dSwNJ1ar9F3OjK8pr5nXVGivV9Eu7H/Cf4emcx63rkJEfDW9u4+9/tMPT2r2RQFAVQABwAKAAAAAAB0Aor8uzDMKuOq+0qfJdj9zyjKMPlVBUaK9X1bOf8b+FbHxRppt7gCO4UfuZwOUP9R7V86+IdHv8AQtTk0/UIikqHg9mHqD6V9VVz3jnwrY+KNMNvcKEuEBME2OUP+FenkmdywUvZVdab/A8PijheGZw9vQVqq/8AJvJ+fZnzLuo3Ve8Q6Pf6FqclhqERjkQ8Hsw9Qazs1+jwlGpFSi7pn4xVozpTcJqzW6J7eeSCZJoZGjkQhlZTgg17t8LvHsWuQppmpOseooMKxPEw/wAa8DzV3Q7fULvVIIdLWQ3ZcGMx8EH1z2rzs1y2jjaLVTRrZ9v+AezkGcYnK8SpUVzKWjj3/wCD2PrCiqOgx38Oj20eqTJNeLGBK6jAJq9X5VOPLJq9z98pyc4KTVr9H0CiiipLCiiigAooooAKKKKAPK/2hfg3o/xT8PFdsVprlupNnebec/3W9VNfnR4y8Naz4R8RXWg69ZvaXts5V1YcEdmB7g9jX6115V+0P8GtF+Knh05SO0161UmzvQuD/uP6qf0r08DjnRfJP4fyM5wvqj80RycCvrP9kz9ndtRNr458dWTLaAiTT9PlXBl9JJB/d7gd+tXv2bv2Y7yz19vEHxFs1VbKYi1sCQwlZTw7f7PcDvX2CiLGioihVUYAAwAK6cfmGns6T9WTCHVhGiRoqRqFRRgKBgAUtFFeGbBRRRQAV4h+038CtP8AiZpTatpCQ2fia2jPlS4wtyo52P8A0Pavb6K0pVZUpKUXqJq+jPyJ1zStQ0TVrnStVtJbS9tnMcsUgwVIqPS7C61O+isrKFpZ5W2qor9AP2r/AIM6J448OzeJLV7fTtesoyRO3yrcqP4H9/Q14F8OvBlp4XsvMkCTajKP3suM7f8AZX0H86+1yiDzFcy0S3Pms+zqllNLXWb2X6vyH/DnwZaeF7EPIEm1CUDzZcfd/wBke1dfmo80ua+0pUY0oqMVofjWLxNXF1XWrO8mSZozUea9N+B/hTTdau5NUv5opvsrjbak8k9mYelc+OxcMHQlWqbI1y3LqmYYmOHpbvuafwj+HhnMWva5DiMENb27D73ozD09q9oAAAAAAHQCkUBVCqAAOABS1+U5jmNXH1XUqfJdj9yyjKKGV0FRor1fVsKKKK4D1AooooA57xz4UsPFOmG3uFEdwgJgnA5Q/wBR7V84eI9Gv9A1SXT9RhMcqHg/wuOxB7ivrCud8d+E7DxTpZt51CXKDMEwHKn/AAr6LI88lgpeyq603+Hmv1Pj+J+GIZnB16KtVX/k3k/Psz5p0uxu9Tv4rGxheaeVtqIoyTX0T8OPBNp4XsRJKFm1GQfvZf7v+yvtR8OfBFn4UtDIxW41CUfvJsdB/dX0FdfWue568W3RoP3Pz/4BhwvwtHL0sTiVeq9l/L/wQooor5g+3CiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKrarf2ml2E19fTpBbwrud2OAKTVdQtNLsJb6+mWGCJcszGvm34nePLzxXfmGEtDpkTfuos/f/wBpvevZyfJ6uZVbLSC3f6LzPBz3PaOVUbvWb2X6vyH/ABM8d3fiq/MULPDpsR/dRdN3+03vXF5pm6jdX6phsLTw1JUqSskfjGLxVbGVnWrO8mSZ96M0wGnSq8UhjkRkdeCrDBFb2OXlFzWn4b1y/wBA1SPUNPmMciHkdmHoR6Vk7hS596ipTjUi4zV0y6c50pqcHZrZn1X4C8W2HizShc27BLmMATwZ5Q/4V0dfIfhvXL/w/qseo6dMY5U6js47gj0r6Y8BeLtP8WaUtzbER3KAefATyh/qPevzPPshlgJe1pa03+Hk/wBGfr/DfEkcygqNbSqv/JvNefdHSUUUV80fWhRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFFFFABRRRQAUUUUAFVtVv7TS7CW+vp1ht4l3O7HpSatqNnpWny319OsMES7mZjXzP8UfH154tv8AyYWeDS4WPlQ5xvP95vU/yr2smyarmVWy0gt3+i8zws8zylldK71m9l+r8h/xP8eXfiy/MUJaHTIm/cxZ5b/ab3ris0zNGa/V8NhaWFpKlSVkj8bxeKrYuq61Z3kx+aX2pmTXsnwc+GrXBh8Qa/CViB3W9sw5b0Zh6e1YZhj6OAourVfourfY3y3LK+Y11Ror1fRLux3wc+GxuPK1/X4SIgQ1tbuPvf7TD09BXT/Fv4dQ6/bPqukxpFqca5KgYE4Hb6+9ekKAqhVAAHAApa/L62fYupi1ilKzWy6W7f5n63R4bwVPBPBuN0931v3/AMj4wuIZred4J42jlQlWVhgg0zNfRHxc+HUXiCB9W0mNI9TRcso4EwH9a+eLiKW2neCeNo5UO1kYYIPpX6TlOa0cypc8NJLddv8AgH5XnOS1srrck9YvZ9/+CJmtPw1rl/4f1WLUdPmMcqHkZ4Yeh9qys0Zr0qlONSLhNXTPKpznSmpwdmtmfWHgDxfp/i3SVubZhHcoAJ4CfmQ/1HvXSV8feGdd1Dw9q0WpabMY5UPIz8rr3UjuK+nPAHjDT/FulLcW7CO6QYngJ5Q/1FfmGfZBLAS9rS1pv8PJ/oz9c4c4jjmMFRraVV/5N5rz7o6WiiivmT6wKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAOY+JXhRfFvh5rAXDwTod8LA/KW9GHcV8s65pV/oupzadqNu0FxC2GVu/uPUV9m1x/xM8DWHi/TD8qw6jEP3E4HP+6fUV9Tw7n7wEvY1v4b/AAf+Xc+S4k4eWYR9vR/iL8V29ex8q5o+gq9ruk32i6nLp2oQNFPG2CCOvuPUV6v8Gvhk1w0PiDxDBiH71tbOPvejMPT2r9Cx2Z4fB4f283o9rdfQ/OMBlWIxuI+rwjZre/T1F+DPw0NwYfEPiCDEQ+a2tnH3vRmHp6Cvc1AVQqgADgAUKoVQqgAAYAHalr8lzPMq2Y1nVqv0XRI/YsryuhltBUqS9X1bCiiivOPSCvNfi98OYvEVu+raTEseqRrllHAnHoff3r0qiuvBY2tgqyq0nZr8fJnHjsDRx1F0ayun+Hmj4ruIZbad4J42ilQlWRhgg1Hmvoz4vfDiLxDA+raRGseqRjLIOBOP8a8AsdI1K91hdIgtJDetJ5ZiK4Knvn0xX6zleb0Mwoe1Ts1uu3/A8z8dzbJK+XYj2TV0/hff/g+Q3SbC81XUIbCwgee4mYKiKOpr6a+F3ga28IaaWkYTajOo8+Tsv+yvtTPhd4DtPCWnCWULNqcq/vZcfd/2V9q7avh+IeIHjG6FB/u1u+//AAD73hrhuOBSxGIV6j2X8v8AwQooor5M+xCiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAxdd8LaHrd/a32pWKTT2rbo2Pf2PqK2VAVQqgAAYAHalorSVWc4qMm2lt5GcKNOEnKMUm9/MKKKKzNAooooAKKKKACs+HRdLh1iXV4rKFb6VQrzBfmIrQoqozlG/K7XJlCMrOSvYKKKKkoKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooA//2Q=="),
      contactLink :: Maybe ConnLinkContact
contactLink = ConnLinkContact -> Maybe ConnLinkContact
forall a. a -> Maybe a
Just (ConnLinkContact -> Maybe ConnLinkContact)
-> ConnLinkContact -> Maybe ConnLinkContact
forall a b. (a -> b) -> a -> b
$ ConnectionRequestUri 'CMContact -> ConnLinkContact
forall (m :: ConnectionMode).
ConnectionRequestUri m -> ConnectionLink m
CLFull ConnectionRequestUri 'CMContact
adminContactReq,
      peerType :: Maybe ChatPeerType
peerType = Maybe ChatPeerType
forall a. Maybe a
Nothing,
      preferences :: Maybe Preferences
preferences = Maybe Preferences
forall a. Maybe a
Nothing
    }

simplexStatusContactProfile :: Profile
simplexStatusContactProfile :: Profile
simplexStatusContactProfile =
  Profile
    { displayName :: ContactName
displayName = ContactName
"SimpleX Status",
      fullName :: ContactName
fullName = ContactName
"",
      shortDescr :: Maybe ContactName
shortDescr = ContactName -> Maybe ContactName
forall a. a -> Maybe a
Just ContactName
"Automatic server status and app release updates",
      image :: Maybe ImageData
image = ImageData -> Maybe ImageData
forall a. a -> Maybe a
Just (ContactName -> ImageData
ImageData ContactName
"data:image/jpg;base64,/9j/4AAQSkZJRgABAQAASABIAAD/4QBYRXhpZgAATU0AKgAAAAgAAgESAAMAAAABAAEAAIdpAAQAAAABAAAAJgAAAAAAA6ABAAMAAAABAAEAAKACAAQAAAABAAAAr6ADAAQAAAABAAAArwAAAAD/7QA4UGhvdG9zaG9wIDMuMAA4QklNBAQAAAAAAAA4QklNBCUAAAAAABDUHYzZjwCyBOmACZjs+EJ+/8AAEQgArwCvAwEiAAIRAQMRAf/EAB8AAAEFAQEBAQEBAAAAAAAAAAABAgMEBQYHCAkKC//EALUQAAIBAwMCBAMFBQQEAAABfQECAwAEEQUSITFBBhNRYQcicRQygZGhCCNCscEVUtHwJDNicoIJChYXGBkaJSYnKCkqNDU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6g4SFhoeIiYqSk5SVlpeYmZqio6Slpqeoqaqys7S1tre4ubrCw8TFxsfIycrS09TV1tfY2drh4uPk5ebn6Onq8fLz9PX29/j5+v/EAB8BAAMBAQEBAQEBAQEAAAAAAAABAgMEBQYHCAkKC//EALURAAIBAgQEAwQHBQQEAAECdwABAgMRBAUhMQYSQVEHYXETIjKBCBRCkaGxwQkjM1LwFWJy0QoWJDThJfEXGBkaJicoKSo1Njc4OTpDREVGR0hJSlNUVVZXWFlaY2RlZmdoaWpzdHV2d3h5eoKDhIWGh4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uLj5OXm5+jp6vLz9PX29/j5+v/bAEMAAQEBAQEBAgEBAgMCAgIDBAMDAwMEBgQEBAQEBgcGBgYGBgYHBwcHBwcHBwgICAgICAkJCQkJCwsLCwsLCwsLC//bAEMBAgICAwMDBQMDBQsIBggLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLCwsLC//dAAQAC//aAAwDAQACEQMRAD8A/v4ooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAP/Q/v4ooooAKKKKACiiigAoorE8R+ItF8J6Jc+IvEVwlrZ2iGSWWQ4CgVUISlJRirtmdatTo05VaslGMU223ZJLVtvokbdFfl3of/BRbS734rtpup2Ig8LSsIYrjnzkOcea3bafTqBX6cafqFjq1jFqemSrPbzqHjkQ5VlPIINetm2Q43LXD65T5eZXX+XquqPiuC/Efh/itYh5HiVUdGTjJWaflJJ6uEvsy2fqXKKKK8c+5Ciq17e2mnWkl/fyLDDCpd3c4VVHJJJr8c/2kf8Ago34q8M3mpTfByG3fT7CGSJZrlC3nStwJF5GFU8gd69LA5VicXTrVaMfdpxcpPokk397toj4LjvxKyLhGjRqZxValVkowhFc05O9m0tPdjfV7dN2kfq346+J3w9+GWlPrXxA1m00i1QZL3Uqxj8Mnn8K/Mj4tf8ABYD4DeEJ5dM+Gmn3niq4TIE0YEFtn/ffBI+imv51vHfxA8b/ABR1+bxT8RNUuNXvp3LtJcOWCk84VeigdgBXI18LXzupLSkrL72fzrxH9IXNsTKVPKKMaMOkpe/P8fdXpaXqfqvrf/BYH9p6+1w3+iafo1jZA8WrRPKSPeTcpz9BX1l8J/8Ags34PvxDp/xn8M3OmSnAe709hcQfUoSHA/A1/PtSE4/GuKGZ4mLvz39T4TL/ABe4swlZ1ljpTvvGaUo/dbT/ALdsf2rfCX9pT4HfHGzF18M/EdnqTYBaFXCzJn+9G2GH5V7nX8IOm6hqGkX8eraLcy2d3EcpPbuY5FPsykGv6gf+CWf7QPxB+OPwX1Ky+JF22pX3h69+yJdyf62WJlDrvPdlzjPevdwGae3l7OcbP8D+i/DTxm/1ixkcqx2H5K7TalF3jLlV2rPWLtqtWvM/T2iiivYP3c//0f7+KKKKACiiigAooooAK/Fv/goX8Qvi2fFcXgfWrRtP8NDEls0bZS7YfxORxlT0Xt1r9pK8u+L/AMI/Cfxp8F3HgvxbFujlGYpgB5kMg6Op9R+tfR8K5vQy3MYYnE01KK0843+0vNf8NZn5f4wcFZhxTwziMpy3FOjVeqSdo1Lf8u5u11GXk97Xuro/mBFyDX3t+yL+2Be/CW+h8B+OHafw7cyALIxJa0Ldx6p6jt1FfMvx/wDgR4w/Z+8YN4d8RoZrSbLWd4owk6D+TDuK8KF0K/pLFYHA51geWVp0pq6a/Brs1/wH2P8ALvJsz4h4D4h9tR5qGLoS5ZRls11jJbSjJferSi9mf1uafqFlqtlFqWmyrPBOoeORDlWU8gg069vrPTbSS/v5FhghUu7ucKqjqSa/CH9j79sm++EuoQ/D/wAeSNceHbmRVjlZstZk9x6p6jt2q3+15+2fffFS8n8AfD2V7bw9CxWWZThrwj+Se3evxB+G2Zf2n9TX8Lf2nTl/+S/u/PbU/v2P0nuGv9Vf7cf+9/D9Xv73tLd/+ffXn7afF7pqftbfth3nxUu5vAXgGR7fw/A5WWUHDXZX19E9B361+Z/xKm3eCL9R3UfzFbQul6Cn+I/A3ivxR8LPEXivSbVn07RoVkurg8Iu5gAue7HPSv1HOsrwmVcN4uhRSjBUp6vq3Fq7fVt/5I/gTNeI884x4kjmeYOVWtKSdop2hCPvWjFbQjFNv5ybbuz4Toqa0ge9uoLOIhWnkSNSxwAXIUEnsBnmv0+/aK/4Jg+O/gj8Hoviz4b1n/hJFt40l1G2ig2NDG4yZEIJ3KvfgHHNfxVTw9SpGUoK6W5+xZVw1mWZYfEYrA0XOFBKU2raJ31te72b0T0R+XRIAyegr+gr/glx+yZoHhjwBc/tKfFywiafUY2OmpeIGS3sVGWmIbgF+TkjhR71+YP7DX7Lt9+1H8ZLfR75WTw5pBS61ScDKsoIKwg+snf0Ffqd/wAFSv2o4Phf4Ltv2WvhmVtrjUbRBfvA2Ps1kOFhAHQyAc9ML9a9HL6UacHi6q0W3mz9Q8M8owuV4KvxpnEL0aN40Yv/AJeVXpp5LZPo7v7J+M/7U/jX4e/EL4/+JfFXwrsI9P0Ke5K26RKESTZw0oUcAOeQBX7J/wDBFU5+HPjYf9RWH/0SK/nqACgKOgr+hT/giouPh143b11SH/0SKWVzc8YpPrf8jHwexk8XxzSxVRJSn7WTSVknKMnoui7H7a0UUV9cf3Mf/9L+/iiiigAoorzX4wfGD4afAP4bav8AF74v6xbaD4d0K3e6vb26cJHHGgyevUnoAOSeBTjFyajFXYHpVFf55Xxt/wCDu34nj9vzS/G3wX0Qz/ArQ2ksLnSp1CXurQyMA15uPMTqBmJD2+914/uU/Y//AGxfgH+3P8ENL+P37OutxazoWpoNwHyzW02PmhmjPKSKeCD9RxXqY/JcXg4QqV4WUvw8n2ZnCrGTaTPqGiiivKNDy/4u/CLwd8afBtx4N8ZW4kilBMUoH7yGTs6HsR+tfzjftA/AXxl+z54yfw34jQzWkuXs7xF/dzR/0YdxX9OPiDxBofhPQ7vxN4mu4rDT7CF57m4ncJHFFGMszMcAAAZJNf53n/Bav/g5W1H4ufGjTvg5+xB5F14E8JX4l1HVriIE6xNE2GjhLDKQdRuGC55HHX9L8Os+x2ExP1eKcsO/iX8vmvPy6/ifg3jZ4NYDjDBPFUEqeYU17k/50vsT8n0lvF+V0fq0LhTUgnA4r4y/ZG/bJ+FX7YXw9HjDwBP5N/ahV1LTZeJrSUjoR3U/wsOK+sRdL/n/APXX9G0nCrBTpu6Z/mVmuSYvLcXUwOPpOnWg7SjJWaf9ap7NarQ+pf2dP2evGH7Q3i4aLogNvp1uQ15esMpEnoPVj2Ffrd+1V8GvDnw5/YU8X+APh/Z7IrewEjYGXlZGUs7nqSQM18C/sO/ti6b8F7o/Dnx6qpoN9LvS6RRvglbjL45ZT69vpX7wX1poHjjwxNYzbL3TdUt2jbaQySRSrg4PoQa/nnxXxGaTxLwmIjy4e3uW2lpu33Xbp87v+7Po58I8L4nhfFVMuqKeY1oTp1nJe9S5k0oxWtoPfmXxve1uVfwqKA0YHYiv6Ev+CZ37bVv490eP9mb4zXAn1GKJo9Murg5F3bgYMLk9XUcD+8tflR+1/wDsn+Nv2XfiNdadqFs8vh28md9Mv1GY3iJyEY9nXoQa+UrC/v8ASr+DVdJnktbq2dZYZomKvG6nIZSOhFfztQrVMJW1Xqu5+Z8PZ5mvBWeSc4NSg+WrTeinHqv1jL56ptP+s7xHZ/A//gnR8EfE/jTwra+RHqF5JdxWpbLTXcwwkSnrsGPwXNfyrfEDx54l+J/jXU/iB4wna51LVZ3nmdj3Y8KPQKOAPQV2vxX/AGhvjT8corC3+K2vz6vFpq7beNgERT3YqvBY92NeNVeOxirNRpq0Fsju8RePKWfTo4TLqPscFRXuU9F7z+KTSuvJK7srvqwr+ir/AIIuaVd2/wAH/FesSIRDd6uFjb+8Y41Dfka/BX4YfCzx78ZfGVr4C+G+nyajqV22Aqj5I17u7dFUdya/r+/ZV+Aenfs2fBLSPhbZyC4ntVaW7nAx5tzKd0jfTJwPYV1ZLQk63tbaI+w8AOHcXiM8ebcjVClGS5ujlJWUV3sm27baX3R9FUUUV9Uf2gf/0/7+KKKKACv4If8Ag8QT9vN9W8IsVk/4Z+WJedOL7f7Xyd32/HGNu3yc/LnPev73q84+Lnwj+G/x3+HGr/CT4uaRba74d123e1vbK6QPHJG4weD0I6gjkHkV6WUY9YLFQxDgpJdP8vMipDmi0f4W1frt/wAEhP8Agrt8af8AglD8b38V+Fo21zwPr7xp4i0B3KpcRoeJoTyEnjBO04+boeK+m/8AguZ/wQz+I3/BMD4kyfEn4Ww3fiD4Oa5KzWWolC76XKx4tbphwOuI3PDAc81/PdX7LCeFzHC3VpU5f18mjympU5eZ/t9fsk/tb/Av9tv4G6N+0F+z3rUWs6BrEQYFCPNt5cfPDMnVJEPDKf5V794h8Q6F4T0O78TeJ7uGw06wiae4uZ3EcUUaDLMzHAAA6k1/j9f8EiP+Cunxv/4JTfHAeKPCZfWfAuuyRx+IvD8jkRTxg486Lsk8YJ2n+Loa/V7/AILy/wDBxZd/t2eHl/Zc/Y6mu9I+Gl1DDNrWoSBoLvUpGAY2+OqQoeH/AL5GOlfneI4OxCxio0taT+12Xn59u53xxMeW73ND/g4M/wCDgzVP2yNV1H9jz9j3UZrD4ZWE7waxrEDlH110ONiEYItgQe/7z6V/I6AAMDgCgAKNo6Cv0j/4Jkf8Ex/j/wD8FOvj/Y/Cj4UWE9voFvNGdf18xk2um2pPzEt0MhGdiZyTX6FhsNhctwvLH3YR1bfXzfn/AEjhlKVSR77/AMEMf2Rf2v8A9qr9tPRrb9mNpdL0fSp438UaxKjNYW+nk/PHKOA7uoIjTrnniv7Lfj98CvG37PPjiXwj4uiLxNl7S7UYjuIuzD39R1Ffvt+wn+wd+z5/wTy+A+n/AAF/Z70pbKyt1V728cA3V/c4w0079WYnoOijgV7V8cPgb4G+Pngqfwb41twwYEwXCgebBJ2ZT/MdDXi5N4mTwmYWqRvhXpb7S/vL9V28z8c8YfBXC8XYL61hbQx9Ne7LpNfyT8v5ZfZfkfyXi5r9Lf2Jv24bn4S3UHwz+JkzT+HZ5AsNy5LNZlu3vHn8q+KPj38CPHf7PPjabwn4yt2ELMxtLsD91cRg8Mp6Z9R2rxAXAPANfuePyzL89y/2c7TpTV1JdOzT6Nf8Bn8C5FnGfcEZ79Yw96OJpPlnCS0a6xkusX/k4u9mf2IeK/B/w++Mngt9C8U2ltrWi6lEGCuA6OrDhlPY+hHNfztftw/8E4tN+AGlTfE34ba3HJo0koVdMvGC3CFv4Ym/5aAenBArvf2PP2+9R+CGmv4B+JSy6joEUbtaOp3TQOBkRj1Rjx7V8uftEftH+Nf2i/G7+KPEzmG0hyllZqT5cEef1Y9zX4LT8GMTisynhsY7UI6qot5J7Jefe+i87o/prxI8YuEM/wCF6WM+rc2ZSXKo6qVJrdykvih/Ktebsmnb4DkilicxyqVYdQRzXUaN4R1HVMSzjyIf7zDk/QV6dIlpJIJ5Y1Z16MRk1+qf7DX7Ed58ULmH4p/Fe2kt/D8Dq9paSDabwjncf+mf/oX0rKXg3lOR+0zDPMW6lCL92EVyufZN3vfyjbvdI/AeFsJnHFOPp5TktD97L4pP4YLrJu2iXnq3ok20es/8Erv2f/G/gf8AtD4ozj7Bo2pwiFIpY/3t2VOQ4J5VFzx659q/aKq9paWthax2VlGsUMShERBtVVHAAA6AVYr4LNcdTxWIdSjRjSpqyjGKslFber7t6tn+k3APB1LhjJaOUUqsqjjdylJ/FKTvJpfZV9orbzd2yiiivNPsj//U/v4ooooAKKKKAPO/iz8Jvh18c/h1q/wm+LGk2+ueHtdt3tb2yukDxyxuMEEHoR1B6g81/lm/8Fy/+CFfxG/4Jh/ENvid8J4bzxF8Htdmke1vliaRtHctxbXTAEBecRyHAbGDzX+q54j8R6B4Q0C88U+KbyHT9N0+F7i5ubhxHFFFGMszMcAADqa/zM/+Dhb/AIL06p+3f4rvP2Tf2Xr6S0+Eui3DR397GcHXriM8N7W6EfIP4jz6V9fwfPGLFctD+H9q+3/D9jmxKjy+9ufyq0UAY4or9ZPMP0v/AOCX3/BLf9oT/gqP8d4Phf8ACa0lsvDtjLG3iDxDJGTa6bbse56NKwB8uPOSfav9ZX9hD9hT4Df8E8v2fdK/Z7+AenLbWNkoe8vHUfab+6I+eeZhyWY9B0UcCv8AKC/4JUf8FV/j1/wSu+PCfEf4aSHUvC+rPHH4i0CViIL63U43D+7MgJKN+B4r/Wd/Yy/bM+BH7eHwH0j9oL9n7Vo9S0fU4182LI8+0nx88MydVdTxz16ivzbjZ43nipfwOlu/n59uh6GE5Labn1ZRRRXwB2Hi3x3+BPgj9oHwJceCPGcIIYFre4UfvYJezKf5jvX8vH7QvwB8d/s4eOZfB/jKEtDIS9neKP3VxFngqfX1Hav6gvj58e/An7PHgK48ceN7gLtBW2twf3txL2RR/M9hX8rX7Qn7Rnjz9o3x5L418ZyhUXKWlqh/dW8WeFUevqe5r988G4Zu3Ut/ueu/839z/wBu6fM/jj6UdPhlwo8y/wCFTS3Lb+H/ANPf/bPtf9unlQuAec077SPWueFznrTxc1+/eyP4udE/XX9g79h24+K8tv8AF74qQvD4fgkDWdo64N4V53H/AKZg/wDfX0r+ge0tLWwtY7KyjWKGJQiIgwqqOAAOwFfzc/sIft2XnwO1KH4ZfEeVp/Ct5L8k7Es9k7YHH/TMnkjt1r+kDTNT07WtOg1fSJ0ubW5QSRSxncjowyCCOoNfyr4q0s3jmreYfwtfZW+Hl/8Akv5r6/Kx/or9HSXDX+rqhkqtidPb81vac/d/3P5Lab/auXqKKK/Lz+gwooooA//V/v4ooooAKxfEniTQPB2gXnirxVew6dpunQvcXV1cOI4oYoxlndjgAADJJrar/PV/4Ozf+CiX7Xlr8Yrf9hCx0u98GfDaS0iv5L1GZT4iZs5HmKceTERgx9d3LcYr08py2eOxMaEXbu/L9SKk1CN2fIX/AAcD/wDBfrXv27vFF1+yx+ylqFzpnwl0id476+icxSa/MhwGOMEWykHYv8fU9hX8qoAAwOAKUAAYFfqj/wAEnf8AglH8cv8Agqp8ek+Hvw/R9M8I6NJFJ4k19lzHZW7k/ImeGmcAhF/E8V+xUKGFyzC2Xuwju/1fds8tuVSXmM/4JQ/8Epfjr/wVU+Pcfw5+HiPpXhPSXjl8ReIZEJhsoGP3E7PO4B2J+J4r7o/4Li/8EC/H3/BL/UYPjH8Hp7vxV8JNQMcL3sy7rnTLkgDbcFRjZI3KPwATg9q/0rP2MP2MPgL+wZ8BdI/Z5/Z60hNM0bS4x5kpANxeTn7887gAvI55JPToOK9y+J/ww8AfGfwBqvwu+KOlW+t6Brdu9re2V0gkilicYIIP6HqDXwVbjSu8YqlNfulpy9139e3Y7VhY8tnuf4VdfqD/AMErP+Cpvx1/4Jb/ALQNn8S/h7cS6j4VvpUj8QeH2kIt723zgsB0WVRyjetffn/BeH/ghJ4x/wCCZvjlvjP8EYbvXPg5rk7GKcqZJdGmc5FvOwH+rOcRyH0wea/nCr9ApVcNmOGuvehL+vk0cLUqcvM/24v2Mf20PgH+3l8CdK/aA/Z61iPVNI1FF86LI+0Wc+PnhnTqjqeOevUcV3nx/wD2gfh/+zp4CuPHHjq5CBQVtrZT+9uJeyIP5noBX+Ud/wAEL/25f2t/2NP2u7A/s7xPrPhzW5Yk8T6LOzCyls1PzTE9I5UXJRupPHIr+p39o79pXx/+0v8AEGbxv42l2RrlLO0QnyreLPCqPX1PUmvM4b8KauYZg5VJWwkdW/tP+6vPu+i8z8r8VvF3D8L4P6vhbTx017sekF/PL/21fafkjV/aF/aN8e/tHePZ/GvjOc+XuK2lopPlW8WeFUevqe9eFfasDmsL7UB1r9kv+Cen/BPuX4mPa/Gv41Wrw6HE4k0/T5FwbsjkO4PPl56D+L6V/QWbZjlnDmW+1q2hSgrRit2+kYrq/wDh2fw9kXDmdcZ526NK9SvUfNOctorrKT6JdF6JIh/Yq/4JyXXxq8MSfEn4wtPpukXkLLp1vH8s0hYcTHPRR1Ud6+KP2nP2bvHX7MXj+Twl4pUz2U+Xsb5QRHcRZ/Rh/Etf2D2trbWNtHZ2caxRRKEREGFVRwAAOgFeSfHL4G+Af2gvAVz4A8f2wmt5huimUDzYJB0dD2I/Wv5/yrxgx0c3niMcr4abtyL7C6OPdrr/ADeWlv604g+jdlFTh6ngsrfLjaauqj/5eS6xn2i/s2+Hz1v/ABi+d3r9O/2DP28r/wCBGpRfDT4lSvdeFL2UBJmYs9izcZX1j7kduor48/ah/Zr8bfsu/EWTwZ4pHn2c4MtheqMJcQ5IB9mHRhXzd9oAFf0Djsuy3iHLeSdqlGorpr8Gn0a/4DW6P5DyrMc74Mzz2tG9LE0XaUXs11jJdYv/ACaezP7pdK1bTNd02DWdGnS6tLlBJFLEwZHRuQQR1FaFfix/wSG1n47X3hPVLHXUL+BoT/oEtxneLjPzLD6pjr2B6d6/aev424nyP+yMyrZf7RT5Huvv17NdV0Z/pTwPxP8A6w5Lh82dGVJ1FrGXdaNp9YveL6oKKKK8A+sP/9b+/iiiigAr4E/4KI/8E4f2b/8AgpZ8DLr4M/H7SklljV5NJ1aJQLzTblhxLC/Uc43L0YcGvvuitKNadKaqU3aS2Ymk1Zn+Vt8Nf+DZH9vDxJ/wUEn/AGQfGti+m+DdMkF5eeNlTNjLpRb5Xgz964cfL5XVWyTx1/0lv2L/ANif9nv9gn4H6b8Bv2dNDh0jSrFF8+YKDcXs4GGmuJOskjHPJ6dBxX1lgZz3pa9bNc+xWPjGFV2iui6vu/60M6dKMNgooorxTU4T4m/DHwB8ZfAeqfDH4paRba7oGtQPbXtjeRiWGaJxghlII/wr/M//AOCw/wDwbq/En9kb9o7Ttc/ZhQ6h8KvGl4VgknkUyaJIxy0UmTueMDmNgCexr/SN/aA/aA+Hf7N3w6u/iL8RbtYYIFIggBHm3Ev8Mca9yfyA5NfyB/tTftZfEX9qv4gSeL/GEv2exgLJYWEZPlW8WeOO7H+Ju9fsXhRwnmOZYl4hNwwi+Jv7T/lj5930Xnofj3iv4nYThrCPD0bTxs17kekV/PPy7L7T8rn58fs1fs1/Df8AZg8Dp4U8CwB7qYK19fuAZrmQDkseyjsvQV9GfaWrAWcjvUnnt6mv62w+Cp0KapUo2itkfwFmOLxWPxNTGYyo51Zu8pN6t/1stktEftx/wTa/YHsfi6sHx2+L8aT6BFJnT7DcGFy6dWlAzhQf4T171/SBaWltY20dlZRrFDEoREQYVVHAAA6AV/Hv+xJ+3N4y/ZO8Wi0ui+oeE9QkX7dYk5KdjLFzw49Ohr+tj4c/Efwb8WPB1l498A30eoaZqEYkiljOevVWHZh0IPIr+TPGXLs6p5p9Zxz5sO9KbXwxX8rXSXd/a3Wmi/t76P8AmHD08l+qZZDkxUdaydueT/mT0vDsl8Oz1d33FFFFfjR/QB4x8dPgN8O/2hvA1x4F+Idms8MgJhmAxLbydnjbqCP1r8RPg3/wSV8Z/wDC9r7T/izMreDNIlEkM8TYfUVPKpgcoAPv+/Ar+iKivrsh43zbKMLWweCq2hUXXXlf80eza0/HdJnwPFHhpkHEGOw+YZlQ5qlJ7rTnXSM/5op6/hs2jD8NeGdA8HaHbeGvC9nFYWFmgjhghUIiKOwArcoor5Oc5Tk5Sd292fd06cacVCCtFaJLZLsgoooqSz//1/7+KKKKACiiigAooooAK8J/aK/aG+H37M/wzvPiX8QrgRwwDbb26kebczH7saDuSep7DmvdW3bTt69s1/Hj/wAFS9c/acu/2hbiw+Psf2fTYWf+w47bd9ha2zw0ZPWQj7+eQfav0Dw44PpcRZssLXqqFOK5pK9pSS6RXfu+i1PzvxN4zrcN5PLF4ei51JPli7XjFv7U327Lq9Dwr9qv9rn4lftZ+Pv+Ev8AG8i29na7ksNPiJ8m2iJ7Ak5Y/wATHrXy/wDacDJNYfn45PFftR/wTX/4Ju6j8aryz+OXxttpLXwtbSrJY2Mi7W1Bl53MD0hB/wC+vpX9jZpmGU8LZT7WolTo01aMVu30jFdW/wDNvqz+HcryTOeLs4dODdSvUd5Tlsl1lJ9Eui9Elsix/wAE8/8Agmpc/Hq3HxZ+OcFxY+F8f6Daj93Jen++eMiMdum76V88ft4fsM+LP2RvGH9p6MJtS8G6gxNnfMMmFj/yxmIAAYfwnuPev7DbGxs9Ms4tP0+JYIIFCRxoNqqq8AADoBXL+P8AwB4R+KHhG+8C+OrGPUNM1CMxTQyjIIPcehHUEdDX8x4PxqzWOdvH11fDS0dJbKPRp/zrdvrtta39V47wCyWeQRy7D6YqOqrPeUuqkv5Hsl9ndXd7/wACwuGHevvT9iL9u7x1+yP4n+wMDqXhPUJVN/YMTlOxlh/uuB+BqH9vD9hXxl+yD4v/ALS03zNT8HajIfsV8VyYSf8AljNjgMOx/iHvX59C6bHav6fjDKeJsqurVcPVX9ecZRfzTP5LdLOeE850vRxNJ/15SjJfJo/v3+GnxJ8HfF3wRp/xC8BXiX2l6lEJYZEPr1Vh2YdCDyDXd1/PD/wRa8KftJW8moeKfPNp8N7kMBBdKT9ouR/Hbgn5QP4m6Gv6Hq/iHjXh6lkmb1svoVlUjF6Nbq/2ZdOZdbfhsf6AcC8SVs9yahmWIoOlOS1T2dvtR68r3V/x3ZRRRXyh9eFFFFABRRRQB//Q/v4ooooAKKKKACiiigAr5u/aj/Zg+HX7VvwyuPh14+i2N/rLO8jA861mHR0Pp2YdCOK+kaK6sDjq+DxEMVhZuFSDumt00cmOwOHxuHnhcVBTpzVpJ7NM/nF/ZW/4I2eINL+MV9rH7Rk0Vz4d0G5H2GCA8anjlXfuiDjcvJJ46V/RfY2FlpdlFpumxJBbwII444wFVEUYAAHAAFW6K9/injHM+Ia8a+Y1L8qsorSK7tLu3q3+iSPn+E+C8q4dw86GW07czvJvWT7Jvstkv1bYUUUV8sfVnEfEb4c+Dvix4Mv/AAB49sY9Q0vUYjFNDIMjB7j0YdQRyDX4HeH/APgiNJB+0LKNe1vzvhzARcxBeLyUEn/R27ADu46jtmv6KKK+r4d42zjI6Vajl1ZxjUVmt7P+aN9pW0uv0R8lxJwNk2e1aFfMqCnKk7p7XX8srbxvrZ/qzn/CnhXw/wCCPDll4R8K2sdlp2nQrBbwRDCoiDAAFdBRRXy05ynJzm7t6tvqfVwhGEVCCsloktkgoooqSgooooAKKKKAP//R/v4ooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKACiiigAooooAKKKKAP/Z"),
      contactLink :: Maybe ConnLinkContact
contactLink = ConnLinkContact -> Maybe ConnLinkContact
forall a. a -> Maybe a
Just ((String -> ConnLinkContact)
-> (ConnectionRequestUri 'CMContact -> ConnLinkContact)
-> Either String (ConnectionRequestUri 'CMContact)
-> ConnLinkContact
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ConnLinkContact
forall a. HasCallStack => String -> a
error ConnectionRequestUri 'CMContact -> ConnLinkContact
forall (m :: ConnectionMode).
ConnectionRequestUri m -> ConnectionLink m
CLFull (Either String (ConnectionRequestUri 'CMContact)
 -> ConnLinkContact)
-> Either String (ConnectionRequestUri 'CMContact)
-> ConnLinkContact
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String (ConnectionRequestUri 'CMContact)
forall a. StrEncoding a => ByteString -> Either String a
strDecode ByteString
"simplex:/contact/#/?v=1-2&smp=smp%3A%2F%2Fu2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU%3D%40smp4.simplex.im%2FShQuD-rPokbDvkyotKx5NwM8P3oUXHxA%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEA6fSx1k9zrOmF0BJpCaTarZvnZpMTAVQhd3RkDQ35KT0%253D%26srv%3Do5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"),
      peerType :: Maybe ChatPeerType
peerType = ChatPeerType -> Maybe ChatPeerType
forall a. a -> Maybe a
Just ChatPeerType
CPTBot,
      preferences :: Maybe Preferences
preferences = Maybe Preferences
forall a. Maybe a
Nothing
    }

timeItToView :: String -> CM' a -> CM' a
timeItToView :: forall a. String -> CM' a -> CM' a
timeItToView String
s CM' a
action = do
  UTCTime
t1 <- IO UTCTime -> ReaderT ChatController IO UTCTime
forall a. IO a -> ReaderT ChatController IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  a
a <- CM' a
action
  UTCTime
t2 <- IO UTCTime -> ReaderT ChatController IO UTCTime
forall a. IO a -> ReaderT ChatController IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let diff :: UserId
diff = NominalDiffTime -> UserId
diffToMilliseconds (NominalDiffTime -> UserId) -> NominalDiffTime -> UserId
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t2 UTCTime
t1
  ChatEvent -> ReaderT ChatController IO ()
toView' (ChatEvent -> ReaderT ChatController IO ())
-> ChatEvent -> ReaderT ChatController IO ()
forall a b. (a -> b) -> a -> b
$ String -> UserId -> ChatEvent
CEvtTimedAction String
s UserId
diff
  a -> CM' a
forall a. a -> ReaderT ChatController IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

epochStart :: UTCTime
epochStart :: UTCTime
epochStart = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
1970 Int
1 Int
1) (Integer -> DiffTime
secondsToDiffTime Integer
0)