-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.
module Galley.API.Create
  ( createGroupConversationUpToV3,
    createGroupConversation,
    createProteusSelfConversation,
    createOne2OneConversation,
    createConnectConversation,
  )
where

import Control.Error (headMay)
import Control.Lens hiding ((??))
import Data.Id
import Data.Json.Util
import Data.List.NonEmpty qualified as NonEmpty
import Data.Misc (FutureWork (FutureWork))
import Data.Qualified
import Data.Range
import Data.Set qualified as Set
import Data.Time
import Data.UUID.Tagged qualified as U
import Galley.API.Action
import Galley.API.Error
import Galley.API.MLS
import Galley.API.Mapping
import Galley.API.One2One
import Galley.API.Util
import Galley.App (Env)
import Galley.Data.Conversation qualified as Data
import Galley.Data.Conversation.Types
import Galley.Effects
import Galley.Effects.BrigAccess
import Galley.Effects.ConversationStore qualified as E
import Galley.Effects.FederatorAccess qualified as E
import Galley.Effects.MemberStore qualified as E
import Galley.Effects.TeamStore qualified as E
import Galley.Options
import Galley.Types.Conversations.Members
import Galley.Types.Teams (notTeamMember)
import Galley.Types.ToUserRole
import Galley.Types.UserList
import Galley.Validation
import Gundeck.Types.Push.V2 qualified as PushV2
import Imports hiding ((\\))
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.TinyLog qualified as P
import Wire.API.Conversation hiding (Conversation, Member)
import Wire.API.Conversation qualified as Public
import Wire.API.Error
import Wire.API.Error.Galley
import Wire.API.Event.Conversation
import Wire.API.Federation.Error
import Wire.API.FederationStatus
import Wire.API.Routes.Public.Galley.Conversation
import Wire.API.Routes.Public.Util
import Wire.API.Team
import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented))
import Wire.API.Team.Member
import Wire.API.Team.Permission hiding (self)
import Wire.API.User
import Wire.NotificationSubsystem

----------------------------------------------------------------------------
-- Group conversations

-- | The public-facing endpoint for creating group conversations in the client
-- API up to and including version 3.
createGroupConversationUpToV3 ::
  ( Member BackendNotificationQueueAccess r,
    Member BrigAccess r,
    Member ConversationStore r,
    Member (ErrorS 'ConvAccessDenied) r,
    Member (Error FederationError) r,
    Member (Error InternalError) r,
    Member (Error InvalidInput) r,
    Member (ErrorS 'NotATeamMember) r,
    Member (ErrorS OperationDenied) r,
    Member (ErrorS 'NotConnected) r,
    Member (ErrorS 'MLSNotEnabled) r,
    Member (ErrorS 'MLSNonEmptyMemberList) r,
    Member (ErrorS 'MissingLegalholdConsent) r,
    Member (Error UnreachableBackendsLegacy) r,
    Member FederatorAccess r,
    Member NotificationSubsystem r,
    Member (Input Env) r,
    Member (Input Opts) r,
    Member (Input UTCTime) r,
    Member LegalHoldStore r,
    Member TeamStore r,
    Member P.TinyLog r
  ) =>
  Local UserId ->
  Maybe ConnId ->
  NewConv ->
  Sem r (ConversationResponse Public.Conversation)
createGroupConversationUpToV3 :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r, Member BrigAccess r,
 Member ConversationStore r, Member (ErrorS 'ConvAccessDenied) r,
 Member (Error FederationError) r, Member (Error InternalError) r,
 Member (Error InvalidInput) r, Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS OperationDenied) r, Member (ErrorS 'NotConnected) r,
 Member (ErrorS 'MLSNotEnabled) r,
 Member (ErrorS 'MLSNonEmptyMemberList) r,
 Member (ErrorS 'MissingLegalholdConsent) r,
 Member (Error UnreachableBackendsLegacy) r,
 Member FederatorAccess r, Member NotificationSubsystem r,
 Member (Input Env) r, Member (Input Opts) r,
 Member (Input UTCTime) r, Member LegalHoldStore r,
 Member TeamStore r, Member TinyLog r) =>
Local UserId
-> Maybe ConnId
-> NewConv
-> Sem r (ConversationResponse Conversation)
createGroupConversationUpToV3 Local UserId
lusr Maybe ConnId
conn NewConv
newConv = (UnreachableBackends -> UnreachableBackendsLegacy)
-> Sem
     (Error UnreachableBackends : r) (ConversationResponse Conversation)
-> Sem r (ConversationResponse Conversation)
forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError UnreachableBackends -> UnreachableBackendsLegacy
UnreachableBackendsLegacy (Sem
   (Error UnreachableBackends : r) (ConversationResponse Conversation)
 -> Sem r (ConversationResponse Conversation))
-> Sem
     (Error UnreachableBackends : r) (ConversationResponse Conversation)
-> Sem r (ConversationResponse Conversation)
forall a b. (a -> b) -> a -> b
$
  do
    Conversation
conv <-
      Local UserId
-> Maybe ConnId
-> NewConv
-> Sem (Error UnreachableBackends : r) Conversation
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r, Member BrigAccess r,
 Member ConversationStore r, Member (ErrorS 'ConvAccessDenied) r,
 Member (Error FederationError) r, Member (Error InternalError) r,
 Member (Error InvalidInput) r, Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS OperationDenied) r, Member (ErrorS 'NotConnected) r,
 Member (ErrorS 'MLSNotEnabled) r,
 Member (ErrorS 'MLSNonEmptyMemberList) r,
 Member (ErrorS 'MissingLegalholdConsent) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r, Member (Input Env) r,
 Member (Input Opts) r, Member (Input UTCTime) r,
 Member LegalHoldStore r, Member TeamStore r, Member TinyLog r) =>
Local UserId -> Maybe ConnId -> NewConv -> Sem r Conversation
createGroupConversationGeneric
        Local UserId
lusr
        Maybe ConnId
conn
        NewConv
newConv
    Local UserId
-> Conversation
-> Sem
     (Error UnreachableBackends : r) (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
conversationCreated Local UserId
lusr Conversation
conv

-- | The public-facing endpoint for creating group conversations in the client
-- API in version 4 and above.
createGroupConversation ::
  ( Member BackendNotificationQueueAccess r,
    Member BrigAccess r,
    Member ConversationStore r,
    Member (ErrorS 'ConvAccessDenied) r,
    Member (Error FederationError) r,
    Member (Error InternalError) r,
    Member (Error InvalidInput) r,
    Member (ErrorS 'NotATeamMember) r,
    Member (ErrorS OperationDenied) r,
    Member (Error NonFederatingBackends) r,
    Member (ErrorS 'NotConnected) r,
    Member (ErrorS 'MLSNotEnabled) r,
    Member (ErrorS 'MLSNonEmptyMemberList) r,
    Member (ErrorS 'MissingLegalholdConsent) r,
    Member (Error UnreachableBackends) r,
    Member FederatorAccess r,
    Member NotificationSubsystem r,
    Member (Input Env) r,
    Member (Input Opts) r,
    Member (Input UTCTime) r,
    Member LegalHoldStore r,
    Member TeamStore r,
    Member P.TinyLog r
  ) =>
  Local UserId ->
  Maybe ConnId ->
  NewConv ->
  Sem r CreateGroupConversationResponse
createGroupConversation :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r, Member BrigAccess r,
 Member ConversationStore r, Member (ErrorS 'ConvAccessDenied) r,
 Member (Error FederationError) r, Member (Error InternalError) r,
 Member (Error InvalidInput) r, Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS OperationDenied) r,
 Member (Error NonFederatingBackends) r,
 Member (ErrorS 'NotConnected) r, Member (ErrorS 'MLSNotEnabled) r,
 Member (ErrorS 'MLSNonEmptyMemberList) r,
 Member (ErrorS 'MissingLegalholdConsent) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r, Member (Input Env) r,
 Member (Input Opts) r, Member (Input UTCTime) r,
 Member LegalHoldStore r, Member TeamStore r, Member TinyLog r) =>
Local UserId
-> Maybe ConnId -> NewConv -> Sem r CreateGroupConversationResponse
createGroupConversation Local UserId
lusr Maybe ConnId
conn NewConv
newConv = do
  let remoteDomains :: [Remote ()]
remoteDomains = QualifiedWithTag 'QRemote UserId -> Remote ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (QualifiedWithTag 'QRemote UserId -> Remote ())
-> [QualifiedWithTag 'QRemote UserId] -> [Remote ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([UserId], [QualifiedWithTag 'QRemote UserId])
-> [QualifiedWithTag 'QRemote UserId]
forall a b. (a, b) -> b
snd (Local UserId
-> [Qualified UserId]
-> ([UserId], [QualifiedWithTag 'QRemote UserId])
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> ([a], [Remote a])
partitionQualified Local UserId
lusr ([Qualified UserId]
 -> ([UserId], [QualifiedWithTag 'QRemote UserId]))
-> [Qualified UserId]
-> ([UserId], [QualifiedWithTag 'QRemote UserId])
forall a b. (a -> b) -> a -> b
$ NewConv
newConv.newConvQualifiedUsers)
  RemoteDomains -> Sem r ()
forall (r :: EffectRow).
(Member (Error UnreachableBackends) r,
 Member (Error NonFederatingBackends) r,
 Member FederatorAccess r) =>
RemoteDomains -> Sem r ()
checkFederationStatus (Set (Remote ()) -> RemoteDomains
RemoteDomains (Set (Remote ()) -> RemoteDomains)
-> Set (Remote ()) -> RemoteDomains
forall a b. (a -> b) -> a -> b
$ [Remote ()] -> Set (Remote ())
forall a. Ord a => [a] -> Set a
Set.fromList [Remote ()]
remoteDomains)
  Conversation
cnv <-
    Local UserId -> Maybe ConnId -> NewConv -> Sem r Conversation
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r, Member BrigAccess r,
 Member ConversationStore r, Member (ErrorS 'ConvAccessDenied) r,
 Member (Error FederationError) r, Member (Error InternalError) r,
 Member (Error InvalidInput) r, Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS OperationDenied) r, Member (ErrorS 'NotConnected) r,
 Member (ErrorS 'MLSNotEnabled) r,
 Member (ErrorS 'MLSNonEmptyMemberList) r,
 Member (ErrorS 'MissingLegalholdConsent) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r, Member (Input Env) r,
 Member (Input Opts) r, Member (Input UTCTime) r,
 Member LegalHoldStore r, Member TeamStore r, Member TinyLog r) =>
Local UserId -> Maybe ConnId -> NewConv -> Sem r Conversation
createGroupConversationGeneric
      Local UserId
lusr
      Maybe ConnId
conn
      NewConv
newConv
  Conversation
conv <- Local UserId -> Conversation -> Sem r Conversation
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId -> Conversation -> Sem r Conversation
conversationView Local UserId
lusr Conversation
cnv
  CreateGroupConversationResponse
-> Sem r CreateGroupConversationResponse
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreateGroupConversationResponse
 -> Sem r CreateGroupConversationResponse)
-> (CreateGroupConversation -> CreateGroupConversationResponse)
-> CreateGroupConversation
-> Sem r CreateGroupConversationResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CreateGroupConversation -> CreateGroupConversationResponse
GroupConversationCreated (CreateGroupConversation -> Sem r CreateGroupConversationResponse)
-> CreateGroupConversation -> Sem r CreateGroupConversationResponse
forall a b. (a -> b) -> a -> b
$
    Conversation -> Map Domain (Set UserId) -> CreateGroupConversation
CreateGroupConversation Conversation
conv Map Domain (Set UserId)
forall a. Monoid a => a
mempty

createGroupConversationGeneric ::
  ( Member BackendNotificationQueueAccess r,
    Member BrigAccess r,
    Member ConversationStore r,
    Member (ErrorS 'ConvAccessDenied) r,
    Member (Error FederationError) r,
    Member (Error InternalError) r,
    Member (Error InvalidInput) r,
    Member (ErrorS 'NotATeamMember) r,
    Member (ErrorS OperationDenied) r,
    Member (ErrorS 'NotConnected) r,
    Member (ErrorS 'MLSNotEnabled) r,
    Member (ErrorS 'MLSNonEmptyMemberList) r,
    Member (ErrorS 'MissingLegalholdConsent) r,
    Member (Error UnreachableBackends) r,
    Member FederatorAccess r,
    Member NotificationSubsystem r,
    Member (Input Env) r,
    Member (Input Opts) r,
    Member (Input UTCTime) r,
    Member LegalHoldStore r,
    Member TeamStore r,
    Member P.TinyLog r
  ) =>
  Local UserId ->
  Maybe ConnId ->
  NewConv ->
  Sem r Conversation
createGroupConversationGeneric :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r, Member BrigAccess r,
 Member ConversationStore r, Member (ErrorS 'ConvAccessDenied) r,
 Member (Error FederationError) r, Member (Error InternalError) r,
 Member (Error InvalidInput) r, Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS OperationDenied) r, Member (ErrorS 'NotConnected) r,
 Member (ErrorS 'MLSNotEnabled) r,
 Member (ErrorS 'MLSNonEmptyMemberList) r,
 Member (ErrorS 'MissingLegalholdConsent) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r, Member (Input Env) r,
 Member (Input Opts) r, Member (Input UTCTime) r,
 Member LegalHoldStore r, Member TeamStore r, Member TinyLog r) =>
Local UserId -> Maybe ConnId -> NewConv -> Sem r Conversation
createGroupConversationGeneric Local UserId
lusr Maybe ConnId
conn NewConv
newConv = do
  (NewConversation
nc, ConvSizeChecked UserList UserId -> UserList UserId
forall {k} (f :: k -> *) (a :: k). ConvSizeChecked f a -> f a
fromConvSize -> UserList UserId
allUsers) <- Local UserId
-> NewConv
-> Sem r (NewConversation, ConvSizeChecked UserList UserId)
forall (r :: EffectRow).
(Member (ErrorS 'MLSNonEmptyMemberList) r,
 Member (Error InvalidInput) r, Member (Input Opts) r) =>
Local UserId
-> NewConv
-> Sem r (NewConversation, ConvSizeChecked UserList UserId)
newRegularConversation Local UserId
lusr NewConv
newConv
  let tinfo :: Maybe ConvTeamInfo
tinfo = NewConv -> Maybe ConvTeamInfo
newConvTeam NewConv
newConv
  Local UserId
-> NewConv -> Maybe ConvTeamInfo -> UserList UserId -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'ConvAccessDenied) r,
 Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS OperationDenied) r, Member (ErrorS 'NotConnected) r,
 Member TeamStore r) =>
Local UserId
-> NewConv -> Maybe ConvTeamInfo -> UserList UserId -> Sem r ()
checkCreateConvPermissions Local UserId
lusr NewConv
newConv Maybe ConvTeamInfo
tinfo UserList UserId
allUsers
  UserList UserId -> Sem r ()
forall (r :: EffectRow).
(Member (ErrorS 'MissingLegalholdConsent) r, Member (Input Opts) r,
 Member LegalHoldStore r, Member TeamStore r) =>
UserList UserId -> Sem r ()
ensureNoLegalholdConflicts UserList UserId
allUsers

  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NewConv -> BaseProtocolTag
newConvProtocol NewConv
newConv BaseProtocolTag -> BaseProtocolTag -> Bool
forall a. Eq a => a -> a -> Bool
== BaseProtocolTag
BaseProtocolMLSTag) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
    -- Here we fail early in order to notify users of this misconfiguration
    Sem r ()
forall (r :: EffectRow).
(Member (Input Env) r, Member (ErrorS 'MLSNotEnabled) r) =>
Sem r ()
assertMLSEnabled

  QualifiedWithTag 'QLocal ConvId
lcnv <- (UserId -> Sem r ConvId)
-> Local UserId -> Sem r (QualifiedWithTag 'QLocal ConvId)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> QualifiedWithTag 'QLocal a -> f (QualifiedWithTag 'QLocal b)
traverse (Sem r ConvId -> UserId -> Sem r ConvId
forall a b. a -> b -> a
const Sem r ConvId
forall (r :: EffectRow). Member ConversationStore r => Sem r ConvId
E.createConversationId) Local UserId
lusr
  do
    Conversation
conv <- QualifiedWithTag 'QLocal ConvId
-> NewConversation -> Sem r Conversation
forall (r :: EffectRow).
Member ConversationStore r =>
QualifiedWithTag 'QLocal ConvId
-> NewConversation -> Sem r Conversation
E.createConversation QualifiedWithTag 'QLocal ConvId
lcnv NewConversation
nc

    -- NOTE: We only send (conversation) events to members of the conversation
    Local UserId -> Maybe ConnId -> Conversation -> Sem r ()
forall (r :: EffectRow).
(Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r,
 Member BackendNotificationQueueAccess r, Member (Input UTCTime) r,
 Member TinyLog r) =>
Local UserId -> Maybe ConnId -> Conversation -> Sem r ()
notifyCreatedConversation Local UserId
lusr Maybe ConnId
conn Conversation
conv
    ConvId -> Sem r (Maybe Conversation)
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Sem r (Maybe Conversation)
E.getConversation (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv)
      Sem r (Maybe Conversation)
-> (Maybe Conversation -> Sem r Conversation) -> Sem r Conversation
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InternalError -> Maybe Conversation -> Sem r Conversation
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note (ConvId -> InternalError
BadConvState (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv))

ensureNoLegalholdConflicts ::
  ( Member (ErrorS 'MissingLegalholdConsent) r,
    Member (Input Opts) r,
    Member LegalHoldStore r,
    Member TeamStore r
  ) =>
  UserList UserId ->
  Sem r ()
ensureNoLegalholdConflicts :: forall (r :: EffectRow).
(Member (ErrorS 'MissingLegalholdConsent) r, Member (Input Opts) r,
 Member LegalHoldStore r, Member TeamStore r) =>
UserList UserId -> Sem r ()
ensureNoLegalholdConflicts (UserList [UserId]
locals [QualifiedWithTag 'QRemote UserId]
remotes) = do
  let FutureWork [QualifiedWithTag 'QRemote UserId]
_remotes = forall {k} (label :: k) payload.
payload -> FutureWork label payload
forall (label :: LegalholdProtectee) payload.
payload -> FutureWork label payload
FutureWork @'LegalholdPlusFederationNotImplemented [QualifiedWithTag 'QRemote UserId]
remotes
  Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ([UserId] -> Sem r Bool
forall (r :: EffectRow).
(Member (Input Opts) r, Member TeamStore r) =>
[UserId] -> Sem r Bool
anyLegalholdActivated [UserId]
locals) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ([UserId] -> Sem r Bool
forall (r :: EffectRow).
(Member (Input Opts) r, Member LegalHoldStore r,
 Member TeamStore r) =>
[UserId] -> Sem r Bool
allLegalholdConsentGiven [UserId]
locals) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
      forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'MissingLegalholdConsent

checkCreateConvPermissions ::
  ( Member BrigAccess r,
    Member (ErrorS 'ConvAccessDenied) r,
    Member (ErrorS 'NotATeamMember) r,
    Member (ErrorS OperationDenied) r,
    Member (ErrorS 'NotConnected) r,
    Member TeamStore r
  ) =>
  Local UserId ->
  NewConv ->
  Maybe ConvTeamInfo ->
  UserList UserId ->
  Sem r ()
checkCreateConvPermissions :: forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'ConvAccessDenied) r,
 Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS OperationDenied) r, Member (ErrorS 'NotConnected) r,
 Member TeamStore r) =>
Local UserId
-> NewConv -> Maybe ConvTeamInfo -> UserList UserId -> Sem r ()
checkCreateConvPermissions Local UserId
lusr NewConv
_newConv Maybe ConvTeamInfo
Nothing UserList UserId
allUsers = do
  Maybe User
activated <- [User] -> Maybe User
forall a. [a] -> Maybe a
listToMaybe ([User] -> Maybe User) -> Sem r [User] -> Sem r (Maybe User)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UserId] -> Sem r [User]
forall (r :: EffectRow).
Member BrigAccess r =>
[UserId] -> Sem r [User]
lookupActivatedUsers [Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr]
  Sem r User -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r User -> Sem r ()) -> Sem r User -> Sem r ()
forall a b. (a -> b) -> a -> b
$ forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Maybe a -> Sem r a
noteS @OperationDenied Maybe User
activated
  -- an external partner is not allowed to create group conversations (except 1:1 team conversations that are handled below)
  Maybe TeamMember
tm <- UserId -> Maybe TeamId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
UserId -> Maybe TeamId -> Sem r (Maybe TeamMember)
getTeamMember (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr) Maybe TeamId
forall a. Maybe a
Nothing
  Maybe TeamMember -> (TeamMember -> Sem r TeamMember) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe TeamMember
tm ((TeamMember -> Sem r TeamMember) -> Sem r ())
-> (TeamMember -> Sem r TeamMember) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    Perm -> Maybe TeamMember -> Sem r TeamMember
forall perm (r :: EffectRow).
(IsPerm perm,
 (Member (ErrorS OperationDenied) r,
  Member (ErrorS 'NotATeamMember) r)) =>
perm -> Maybe TeamMember -> Sem r TeamMember
permissionCheck Perm
AddRemoveConvMember (Maybe TeamMember -> Sem r TeamMember)
-> (TeamMember -> Maybe TeamMember)
-> TeamMember
-> Sem r TeamMember
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TeamMember -> Maybe TeamMember
forall a. a -> Maybe a
Just
  Local UserId -> UserList UserId -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotConnected) r) =>
Local UserId -> UserList UserId -> Sem r ()
ensureConnected Local UserId
lusr UserList UserId
allUsers
checkCreateConvPermissions Local UserId
lusr NewConv
newConv (Just ConvTeamInfo
tinfo) UserList UserId
allUsers = do
  let convTeam :: TeamId
convTeam = ConvTeamInfo -> TeamId
cnvTeamId ConvTeamInfo
tinfo
  Maybe TeamMember
zusrMembership <- UserId -> Maybe TeamId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
UserId -> Maybe TeamId -> Sem r (Maybe TeamMember)
getTeamMember (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr) (TeamId -> Maybe TeamId
forall a. a -> Maybe a
Just TeamId
convTeam)
  Sem r TeamMember -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r TeamMember -> Sem r ()) -> Sem r TeamMember -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Perm -> Maybe TeamMember -> Sem r TeamMember
forall perm (r :: EffectRow).
(IsPerm perm,
 (Member (ErrorS OperationDenied) r,
  Member (ErrorS 'NotATeamMember) r)) =>
perm -> Maybe TeamMember -> Sem r TeamMember
permissionCheck Perm
CreateConversation Maybe TeamMember
zusrMembership
  [Maybe TeamMember]
convLocalMemberships <- (UserId -> Sem r (Maybe TeamMember))
-> [UserId] -> Sem r [Maybe TeamMember]
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 (TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
E.getTeamMember TeamId
convTeam) (UserList UserId -> [UserId]
forall a. UserList a -> [a]
ulLocals UserList UserId
allUsers)
  Set AccessRole -> [(UserId, Maybe TeamMember)] -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS 'ConvAccessDenied) r) =>
Set AccessRole -> [(UserId, Maybe TeamMember)] -> Sem r ()
ensureAccessRole (NewConv -> Set AccessRole
accessRoles NewConv
newConv) ([UserId] -> [Maybe TeamMember] -> [(UserId, Maybe TeamMember)]
forall a b. [a] -> [b] -> [(a, b)]
zip (UserList UserId -> [UserId]
forall a. UserList a -> [a]
ulLocals UserList UserId
allUsers) [Maybe TeamMember]
convLocalMemberships)
  -- In teams we don't have 1:1 conversations, only regular conversations. We want
  -- users without the 'AddRemoveConvMember' permission to still be able to create
  -- regular conversations, therefore we check for 'AddRemoveConvMember' only if
  -- there are going to be more than two users in the conversation.
  -- FUTUREWORK: We keep this permission around because not doing so will break backwards
  -- compatibility in the sense that the team role 'partners' would be able to create group
  -- conversations (which they should not be able to).
  -- Not sure at the moment how to best solve this but it is unlikely
  -- we can ever get rid of the team permission model anyway - the only thing I can
  -- think of is that 'partners' can create convs but not be admins...
  -- this only applies to proteus conversations, because in MLS we have proper 1:1 conversations,
  -- so we don't allow an external partner to create an MLS group conversation at all
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UserList UserId -> Int
forall a. UserList a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length UserList UserId
allUsers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| NewConv
newConv.newConvProtocol BaseProtocolTag -> BaseProtocolTag -> Bool
forall a. Eq a => a -> a -> Bool
== BaseProtocolTag
BaseProtocolMLSTag) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
    Sem r TeamMember -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r TeamMember -> Sem r ()) -> Sem r TeamMember -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Perm -> Maybe TeamMember -> Sem r TeamMember
forall perm (r :: EffectRow).
(IsPerm perm,
 (Member (ErrorS OperationDenied) r,
  Member (ErrorS 'NotATeamMember) r)) =>
perm -> Maybe TeamMember -> Sem r TeamMember
permissionCheck Perm
AddRemoveConvMember Maybe TeamMember
zusrMembership

  -- Team members are always considered to be connected, so we only check
  -- 'ensureConnected' for non-team-members.
  UserId -> [UserId] -> Sem r ()
forall (r :: EffectRow).
(Member (ErrorS 'NotConnected) r, Member BrigAccess r) =>
UserId -> [UserId] -> Sem r ()
ensureConnectedToLocals (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr) ([UserId] -> [TeamMember] -> [UserId]
notTeamMember (UserList UserId -> [UserId]
forall a. UserList a -> [a]
ulLocals UserList UserId
allUsers) ([Maybe TeamMember] -> [TeamMember]
forall a. [Maybe a] -> [a]
catMaybes [Maybe TeamMember]
convLocalMemberships))
  Local UserId -> [QualifiedWithTag 'QRemote UserId] -> Sem r ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotConnected) r) =>
Local UserId -> [QualifiedWithTag 'QRemote UserId] -> Sem r ()
ensureConnectedToRemotes Local UserId
lusr (UserList UserId -> [QualifiedWithTag 'QRemote UserId]
forall a. UserList a -> [Remote a]
ulRemotes UserList UserId
allUsers)

getTeamMember :: (Member TeamStore r) => UserId -> Maybe TeamId -> Sem r (Maybe TeamMember)
getTeamMember :: forall (r :: EffectRow).
Member TeamStore r =>
UserId -> Maybe TeamId -> Sem r (Maybe TeamMember)
getTeamMember UserId
uid (Just TeamId
tid) = TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
E.getTeamMember TeamId
tid UserId
uid
getTeamMember UserId
uid Maybe TeamId
Nothing = UserId -> Sem r [TeamId]
forall (r :: EffectRow).
Member TeamStore r =>
UserId -> Sem r [TeamId]
E.getUserTeams UserId
uid Sem r [TeamId]
-> ([TeamId] -> Sem r (Maybe TeamMember))
-> Sem r (Maybe TeamMember)
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Sem r (Maybe TeamMember)
-> (TeamId -> Sem r (Maybe TeamMember))
-> Maybe TeamId
-> Sem r (Maybe TeamMember)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe TeamMember -> Sem r (Maybe TeamMember)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TeamMember
forall a. Maybe a
Nothing) ((TeamId -> UserId -> Sem r (Maybe TeamMember))
-> UserId -> TeamId -> Sem r (Maybe TeamMember)
forall a b c. (a -> b -> c) -> b -> a -> c
flip TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
E.getTeamMember UserId
uid) (Maybe TeamId -> Sem r (Maybe TeamMember))
-> ([TeamId] -> Maybe TeamId)
-> [TeamId]
-> Sem r (Maybe TeamMember)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TeamId] -> Maybe TeamId
forall a. [a] -> Maybe a
headMay

----------------------------------------------------------------------------
-- Other kinds of conversations

createProteusSelfConversation ::
  forall r.
  ( Member ConversationStore r,
    Member (Error InternalError) r,
    Member P.TinyLog r
  ) =>
  Local UserId ->
  Sem r (ConversationResponse Public.Conversation)
createProteusSelfConversation :: forall (r :: EffectRow).
(Member ConversationStore r, Member (Error InternalError) r,
 Member TinyLog r) =>
Local UserId -> Sem r (ConversationResponse Conversation)
createProteusSelfConversation Local UserId
lusr = do
  let lcnv :: QualifiedWithTag 'QLocal ConvId
lcnv = (UserId -> ConvId)
-> Local UserId -> QualifiedWithTag 'QLocal ConvId
forall a b.
(a -> b)
-> QualifiedWithTag 'QLocal a -> QualifiedWithTag 'QLocal b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UserId -> ConvId
Data.selfConv Local UserId
lusr
  Maybe Conversation
c <- ConvId -> Sem r (Maybe Conversation)
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Sem r (Maybe Conversation)
E.getConversation (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv)
  Sem r (ResponseForExistedCreated Conversation)
-> (Conversation -> Sem r (ResponseForExistedCreated Conversation))
-> Maybe Conversation
-> Sem r (ResponseForExistedCreated Conversation)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (QualifiedWithTag 'QLocal ConvId
-> Sem r (ConversationResponse Conversation)
create QualifiedWithTag 'QLocal ConvId
lcnv) (Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
conversationExisted Local UserId
lusr) Maybe Conversation
c
  where
    create :: Local ConvId -> Sem r (ConversationResponse Public.Conversation)
    create :: QualifiedWithTag 'QLocal ConvId
-> Sem r (ConversationResponse Conversation)
create QualifiedWithTag 'QLocal ConvId
lcnv = do
      let nc :: NewConversation
nc =
            NewConversation
              { $sel:ncMetadata:NewConversation :: ConversationMetadata
ncMetadata = (Maybe UserId -> ConversationMetadata
defConversationMetadata (UserId -> Maybe UserId
forall a. a -> Maybe a
Just (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr))) {cnvmType = SelfConv},
                $sel:ncUsers:NewConversation :: UserList (UserId, RoleName)
ncUsers = [(UserId, RoleName)] -> UserList (UserId, RoleName)
forall a. [a] -> UserList a
ulFromLocals [UserId -> (UserId, RoleName)
forall a. ToUserRole a => a -> (UserId, RoleName)
toUserRole (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr)],
                $sel:ncProtocol:NewConversation :: BaseProtocolTag
ncProtocol = BaseProtocolTag
BaseProtocolProteusTag
              }
      Conversation
c <- QualifiedWithTag 'QLocal ConvId
-> NewConversation -> Sem r Conversation
forall (r :: EffectRow).
Member ConversationStore r =>
QualifiedWithTag 'QLocal ConvId
-> NewConversation -> Sem r Conversation
E.createConversation QualifiedWithTag 'QLocal ConvId
lcnv NewConversation
nc
      Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
conversationCreated Local UserId
lusr Conversation
c

createOne2OneConversation ::
  ( Member BackendNotificationQueueAccess r,
    Member BrigAccess r,
    Member ConversationStore r,
    Member (Error FederationError) r,
    Member (Error InternalError) r,
    Member (Error InvalidInput) r,
    Member (ErrorS 'NotATeamMember) r,
    Member (ErrorS 'NonBindingTeam) r,
    Member (ErrorS 'NoBindingTeamMembers) r,
    Member (ErrorS OperationDenied) r,
    Member (ErrorS 'TeamNotFound) r,
    Member (ErrorS 'InvalidOperation) r,
    Member (ErrorS 'NotConnected) r,
    Member (Error UnreachableBackendsLegacy) r,
    Member FederatorAccess r,
    Member NotificationSubsystem r,
    Member (Input UTCTime) r,
    Member TeamStore r,
    Member P.TinyLog r
  ) =>
  Local UserId ->
  ConnId ->
  NewConv ->
  Sem r (ConversationResponse Public.Conversation)
createOne2OneConversation :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r, Member BrigAccess r,
 Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r, Member (Error InvalidInput) r,
 Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS 'NonBindingTeam) r,
 Member (ErrorS 'NoBindingTeamMembers) r,
 Member (ErrorS OperationDenied) r, Member (ErrorS 'TeamNotFound) r,
 Member (ErrorS 'InvalidOperation) r,
 Member (ErrorS 'NotConnected) r,
 Member (Error UnreachableBackendsLegacy) r,
 Member FederatorAccess r, Member NotificationSubsystem r,
 Member (Input UTCTime) r, Member TeamStore r, Member TinyLog r) =>
Local UserId
-> ConnId -> NewConv -> Sem r (ConversationResponse Conversation)
createOne2OneConversation Local UserId
lusr ConnId
zcon NewConv
j =
  forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError @UnreachableBackends @UnreachableBackendsLegacy UnreachableBackends -> UnreachableBackendsLegacy
UnreachableBackendsLegacy (Sem
   (Error UnreachableBackends : r) (ConversationResponse Conversation)
 -> Sem r (ConversationResponse Conversation))
-> Sem
     (Error UnreachableBackends : r) (ConversationResponse Conversation)
-> Sem r (ConversationResponse Conversation)
forall a b. (a -> b) -> a -> b
$ do
    let allUsers :: UserList UserId
allUsers = Local UserId -> NewConv -> UserList UserId
forall x. Local x -> NewConv -> UserList UserId
newConvMembers Local UserId
lusr NewConv
j
    Qualified UserId
other <- [Qualified UserId]
-> Sem (Error UnreachableBackends : r) (Qualified UserId)
forall (r :: EffectRow) a.
Member (Error InvalidInput) r =>
[a] -> Sem r a
ensureOne (Local UserId -> UserList UserId -> [Qualified UserId]
forall x a. Local x -> UserList a -> [Qualified a]
ulAll Local UserId
lusr UserList UserId
allUsers)
    Bool
-> Sem (Error UnreachableBackends : r) ()
-> Sem (Error UnreachableBackends : r) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr Qualified UserId -> Qualified UserId -> Bool
forall a. Eq a => a -> a -> Bool
== Qualified UserId
other) (Sem (Error UnreachableBackends : r) ()
 -> Sem (Error UnreachableBackends : r) ())
-> Sem (Error UnreachableBackends : r) ()
-> Sem (Error UnreachableBackends : r) ()
forall a b. (a -> b) -> a -> b
$
      forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'InvalidOperation
    Maybe TeamId
mtid <- case NewConv -> Maybe ConvTeamInfo
newConvTeam NewConv
j of
      Just ConvTeamInfo
ti -> do
        Local UserId
-> (Local UserId
    -> Sem (Error UnreachableBackends : r) (Maybe TeamId))
-> (QualifiedWithTag 'QRemote UserId
    -> Sem (Error UnreachableBackends : r) (Maybe TeamId))
-> Qualified UserId
-> Sem (Error UnreachableBackends : r) (Maybe TeamId)
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
          Local UserId
lusr
          (\Local UserId
lother -> Local UserId
-> TeamId -> Sem (Error UnreachableBackends : r) (Maybe TeamId)
forall (r :: EffectRow).
(Member (ErrorS 'NoBindingTeamMembers) r,
 Member (ErrorS 'NonBindingTeam) r,
 Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS OperationDenied) r, Member (ErrorS 'TeamNotFound) r,
 Member TeamStore r) =>
Local UserId -> TeamId -> Sem r (Maybe TeamId)
checkBindingTeamPermissions Local UserId
lother (ConvTeamInfo -> TeamId
cnvTeamId ConvTeamInfo
ti))
          (Sem (Error UnreachableBackends : r) (Maybe TeamId)
-> QualifiedWithTag 'QRemote UserId
-> Sem (Error UnreachableBackends : r) (Maybe TeamId)
forall a b. a -> b -> a
const (Maybe TeamId -> Sem (Error UnreachableBackends : r) (Maybe TeamId)
forall a. a -> Sem (Error UnreachableBackends : r) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TeamId
forall a. Maybe a
Nothing))
          Qualified UserId
other
      Maybe ConvTeamInfo
Nothing -> Local UserId
-> UserList UserId -> Sem (Error UnreachableBackends : r) ()
forall (r :: EffectRow).
(Member BrigAccess r, Member (ErrorS 'NotConnected) r) =>
Local UserId -> UserList UserId -> Sem r ()
ensureConnected Local UserId
lusr UserList UserId
allUsers Sem (Error UnreachableBackends : r) ()
-> Maybe TeamId
-> Sem (Error UnreachableBackends : r) (Maybe TeamId)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe TeamId
forall a. Maybe a
Nothing
    Local UserId
-> (Local UserId
    -> Sem
         (Error UnreachableBackends : r)
         (ResponseForExistedCreated Conversation))
-> (QualifiedWithTag 'QRemote UserId
    -> Sem
         (Error UnreachableBackends : r)
         (ResponseForExistedCreated Conversation))
-> Qualified UserId
-> Sem
     (Error UnreachableBackends : r)
     (ResponseForExistedCreated Conversation)
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
      Local UserId
lusr
      (Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Local UserId
-> Sem
     (Error UnreachableBackends : r) (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
 Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r, Member (Error InvalidInput) r,
 Member FederatorAccess r, Member NotificationSubsystem r,
 Member (Input UTCTime) r, Member TinyLog r) =>
Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Local UserId
-> Sem r (ConversationResponse Conversation)
createLegacyOne2OneConversationUnchecked Local UserId
lusr ConnId
zcon (NewConv -> Maybe (Range 1 256 Text)
newConvName NewConv
j) Maybe TeamId
mtid)
      (Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem
     (Error UnreachableBackends : r) (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
 Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r, Member (Input UTCTime) r,
 Member TinyLog r) =>
Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ConversationResponse Conversation)
createOne2OneConversationUnchecked Local UserId
lusr ConnId
zcon (NewConv -> Maybe (Range 1 256 Text)
newConvName NewConv
j) Maybe TeamId
mtid (Qualified UserId
 -> Sem
      (Error UnreachableBackends : r)
      (ResponseForExistedCreated Conversation))
-> (QualifiedWithTag 'QRemote UserId -> Qualified UserId)
-> QualifiedWithTag 'QRemote UserId
-> Sem
     (Error UnreachableBackends : r)
     (ResponseForExistedCreated Conversation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedWithTag 'QRemote UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged)
      Qualified UserId
other
  where
    verifyMembership ::
      ( Member (ErrorS 'NoBindingTeamMembers) r,
        Member TeamStore r
      ) =>
      TeamId ->
      UserId ->
      Sem r ()
    verifyMembership :: forall (r :: EffectRow).
(Member (ErrorS 'NoBindingTeamMembers) r, Member TeamStore r) =>
TeamId -> UserId -> Sem r ()
verifyMembership TeamId
tid UserId
u = do
      Maybe TeamMember
membership <- TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
E.getTeamMember TeamId
tid UserId
u
      Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe TeamMember -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TeamMember
membership) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
        forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'NoBindingTeamMembers
    checkBindingTeamPermissions ::
      ( Member (ErrorS 'NoBindingTeamMembers) r,
        Member (ErrorS 'NonBindingTeam) r,
        Member (ErrorS 'NotATeamMember) r,
        Member (ErrorS OperationDenied) r,
        Member (ErrorS 'TeamNotFound) r,
        Member TeamStore r
      ) =>
      Local UserId ->
      TeamId ->
      Sem r (Maybe TeamId)
    checkBindingTeamPermissions :: forall (r :: EffectRow).
(Member (ErrorS 'NoBindingTeamMembers) r,
 Member (ErrorS 'NonBindingTeam) r,
 Member (ErrorS 'NotATeamMember) r,
 Member (ErrorS OperationDenied) r, Member (ErrorS 'TeamNotFound) r,
 Member TeamStore r) =>
Local UserId -> TeamId -> Sem r (Maybe TeamId)
checkBindingTeamPermissions Local UserId
lother TeamId
tid = do
      Maybe TeamMember
zusrMembership <- TeamId -> UserId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> UserId -> Sem r (Maybe TeamMember)
E.getTeamMember TeamId
tid (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr)
      Sem r TeamMember -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r TeamMember -> Sem r ()) -> Sem r TeamMember -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Perm -> Maybe TeamMember -> Sem r TeamMember
forall perm (r :: EffectRow).
(IsPerm perm,
 (Member (ErrorS OperationDenied) r,
  Member (ErrorS 'NotATeamMember) r)) =>
perm -> Maybe TeamMember -> Sem r TeamMember
permissionCheck Perm
CreateConversation Maybe TeamMember
zusrMembership
      TeamId -> Sem r (Maybe TeamBinding)
forall (r :: EffectRow).
Member TeamStore r =>
TeamId -> Sem r (Maybe TeamBinding)
E.getTeamBinding TeamId
tid Sem r (Maybe TeamBinding)
-> (Maybe TeamBinding -> Sem r (Maybe TeamId))
-> Sem r (Maybe TeamId)
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just TeamBinding
Binding -> do
          TeamId -> UserId -> Sem r ()
forall (r :: EffectRow).
(Member (ErrorS 'NoBindingTeamMembers) r, Member TeamStore r) =>
TeamId -> UserId -> Sem r ()
verifyMembership TeamId
tid (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr)
          TeamId -> UserId -> Sem r ()
forall (r :: EffectRow).
(Member (ErrorS 'NoBindingTeamMembers) r, Member TeamStore r) =>
TeamId -> UserId -> Sem r ()
verifyMembership TeamId
tid (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lother)
          Maybe TeamId -> Sem r (Maybe TeamId)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TeamId -> Maybe TeamId
forall a. a -> Maybe a
Just TeamId
tid)
        Just TeamBinding
_ -> forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'NonBindingTeam
        Maybe TeamBinding
Nothing -> forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'TeamNotFound

createLegacyOne2OneConversationUnchecked ::
  ( Member BackendNotificationQueueAccess r,
    Member ConversationStore r,
    Member (Error FederationError) r,
    Member (Error InternalError) r,
    Member (Error InvalidInput) r,
    Member FederatorAccess r,
    Member NotificationSubsystem r,
    Member (Input UTCTime) r,
    Member P.TinyLog r
  ) =>
  Local UserId ->
  ConnId ->
  Maybe (Range 1 256 Text) ->
  Maybe TeamId ->
  Local UserId ->
  Sem r (ConversationResponse Public.Conversation)
createLegacyOne2OneConversationUnchecked :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
 Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r, Member (Error InvalidInput) r,
 Member FederatorAccess r, Member NotificationSubsystem r,
 Member (Input UTCTime) r, Member TinyLog r) =>
Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Local UserId
-> Sem r (ConversationResponse Conversation)
createLegacyOne2OneConversationUnchecked Local UserId
self ConnId
zcon Maybe (Range 1 256 Text)
name Maybe TeamId
mtid Local UserId
other = do
  QualifiedWithTag 'QLocal ConvId
lcnv <- Local UserId
-> Local UserId -> Sem r (QualifiedWithTag 'QLocal ConvId)
forall (r :: EffectRow).
Member (Error InvalidInput) r =>
Local UserId
-> Local UserId -> Sem r (QualifiedWithTag 'QLocal ConvId)
localOne2OneConvId Local UserId
self Local UserId
other
  let meta :: ConversationMetadata
meta =
        (Maybe UserId -> ConversationMetadata
defConversationMetadata (UserId -> Maybe UserId
forall a. a -> Maybe a
Just (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
self)))
          { cnvmType = One2OneConv,
            cnvmTeam = mtid,
            cnvmName = fmap fromRange name
          }
  let nc :: NewConversation
nc =
        NewConversation
          { $sel:ncUsers:NewConversation :: UserList (UserId, RoleName)
ncUsers = [(UserId, RoleName)] -> UserList (UserId, RoleName)
forall a. [a] -> UserList a
ulFromLocals ((Local UserId -> (UserId, RoleName))
-> [Local UserId] -> [(UserId, RoleName)]
forall a b. (a -> b) -> [a] -> [b]
map (UserId -> (UserId, RoleName)
forall a. ToUserRole a => a -> (UserId, RoleName)
toUserRole (UserId -> (UserId, RoleName))
-> (Local UserId -> UserId) -> Local UserId -> (UserId, RoleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified) [Local UserId
self, Local UserId
other]),
            $sel:ncProtocol:NewConversation :: BaseProtocolTag
ncProtocol = BaseProtocolTag
BaseProtocolProteusTag,
            $sel:ncMetadata:NewConversation :: ConversationMetadata
ncMetadata = ConversationMetadata
meta
          }
  Maybe Conversation
mc <- ConvId -> Sem r (Maybe Conversation)
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Sem r (Maybe Conversation)
E.getConversation (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv)
  case Maybe Conversation
mc of
    Just Conversation
c -> Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
conversationExisted Local UserId
self Conversation
c
    Maybe Conversation
Nothing -> do
      Conversation
c <- QualifiedWithTag 'QLocal ConvId
-> NewConversation -> Sem r Conversation
forall (r :: EffectRow).
Member ConversationStore r =>
QualifiedWithTag 'QLocal ConvId
-> NewConversation -> Sem r Conversation
E.createConversation QualifiedWithTag 'QLocal ConvId
lcnv NewConversation
nc
      forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError @UnreachableBackends (Local UserId
-> Maybe ConnId
-> Conversation
-> Sem (Error UnreachableBackends : r) ()
forall (r :: EffectRow).
(Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r,
 Member BackendNotificationQueueAccess r, Member (Input UTCTime) r,
 Member TinyLog r) =>
Local UserId -> Maybe ConnId -> Conversation -> Sem r ()
notifyCreatedConversation Local UserId
self (ConnId -> Maybe ConnId
forall a. a -> Maybe a
Just ConnId
zcon) Conversation
c)
        Sem r (Either UnreachableBackends ())
-> (Either UnreachableBackends ()
    -> Sem r (ResponseForExistedCreated Conversation))
-> Sem r (ResponseForExistedCreated Conversation)
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left UnreachableBackends
_ -> do
            InternalError -> Sem r (ResponseForExistedCreated Conversation)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (InternalError -> Sem r (ResponseForExistedCreated Conversation))
-> (LText -> InternalError)
-> LText
-> Sem r (ResponseForExistedCreated Conversation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LText -> InternalError
InternalErrorWithDescription (LText -> Sem r (ResponseForExistedCreated Conversation))
-> LText -> Sem r (ResponseForExistedCreated Conversation)
forall a b. (a -> b) -> a -> b
$
              LText
"A one-to-one conversation on one backend cannot involve unreachable backends"
          Right () -> Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
conversationCreated Local UserId
self Conversation
c

createOne2OneConversationUnchecked ::
  ( Member BackendNotificationQueueAccess r,
    Member ConversationStore r,
    Member (Error FederationError) r,
    Member (Error InternalError) r,
    Member (Error UnreachableBackends) r,
    Member FederatorAccess r,
    Member NotificationSubsystem r,
    Member (Input UTCTime) r,
    Member P.TinyLog r
  ) =>
  Local UserId ->
  ConnId ->
  Maybe (Range 1 256 Text) ->
  Maybe TeamId ->
  Qualified UserId ->
  Sem r (ConversationResponse Public.Conversation)
createOne2OneConversationUnchecked :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
 Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r, Member (Input UTCTime) r,
 Member TinyLog r) =>
Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ConversationResponse Conversation)
createOne2OneConversationUnchecked Local UserId
self ConnId
zcon Maybe (Range 1 256 Text)
name Maybe TeamId
mtid Qualified UserId
other = do
  let create :: Qualified ConvId
-> Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ResponseForExistedCreated Conversation)
create =
        Local UserId
-> (QualifiedWithTag 'QLocal ConvId
    -> Local UserId
    -> ConnId
    -> Maybe (Range 1 256 Text)
    -> Maybe TeamId
    -> Qualified UserId
    -> Sem r (ResponseForExistedCreated Conversation))
-> (Remote ConvId
    -> Local UserId
    -> ConnId
    -> Maybe (Range 1 256 Text)
    -> Maybe TeamId
    -> Qualified UserId
    -> Sem r (ResponseForExistedCreated Conversation))
-> Qualified ConvId
-> Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ResponseForExistedCreated Conversation)
forall x a b.
Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
foldQualified
          Local UserId
self
          QualifiedWithTag 'QLocal ConvId
-> Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ResponseForExistedCreated Conversation)
QualifiedWithTag 'QLocal ConvId
-> Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
 Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r, Member (Input UTCTime) r,
 Member TinyLog r) =>
QualifiedWithTag 'QLocal ConvId
-> Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ConversationResponse Conversation)
createOne2OneConversationLocally
          Remote ConvId
-> Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ResponseForExistedCreated Conversation)
Remote ConvId
-> Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ConversationResponse Conversation)
forall (r :: EffectRow).
Member (Error FederationError) r =>
Remote ConvId
-> Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ConversationResponse Conversation)
createOne2OneConversationRemotely
  Qualified ConvId
-> Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ResponseForExistedCreated Conversation)
create (BaseProtocolTag
-> Qualified UserId -> Qualified UserId -> Qualified ConvId
one2OneConvId BaseProtocolTag
BaseProtocolProteusTag (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
self) Qualified UserId
other) Local UserId
self ConnId
zcon Maybe (Range 1 256 Text)
name Maybe TeamId
mtid Qualified UserId
other

createOne2OneConversationLocally ::
  ( Member BackendNotificationQueueAccess r,
    Member ConversationStore r,
    Member (Error FederationError) r,
    Member (Error InternalError) r,
    Member (Error UnreachableBackends) r,
    Member FederatorAccess r,
    Member NotificationSubsystem r,
    Member (Input UTCTime) r,
    Member P.TinyLog r
  ) =>
  Local ConvId ->
  Local UserId ->
  ConnId ->
  Maybe (Range 1 256 Text) ->
  Maybe TeamId ->
  Qualified UserId ->
  Sem r (ConversationResponse Public.Conversation)
createOne2OneConversationLocally :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
 Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r, Member (Input UTCTime) r,
 Member TinyLog r) =>
QualifiedWithTag 'QLocal ConvId
-> Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ConversationResponse Conversation)
createOne2OneConversationLocally QualifiedWithTag 'QLocal ConvId
lcnv Local UserId
self ConnId
zcon Maybe (Range 1 256 Text)
name Maybe TeamId
mtid Qualified UserId
other = do
  Maybe Conversation
mc <- ConvId -> Sem r (Maybe Conversation)
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Sem r (Maybe Conversation)
E.getConversation (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv)
  case Maybe Conversation
mc of
    Just Conversation
c -> Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
conversationExisted Local UserId
self Conversation
c
    Maybe Conversation
Nothing -> do
      let meta :: ConversationMetadata
meta =
            (Maybe UserId -> ConversationMetadata
defConversationMetadata (UserId -> Maybe UserId
forall a. a -> Maybe a
Just (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
self)))
              { cnvmType = One2OneConv,
                cnvmTeam = mtid,
                cnvmName = fmap fromRange name
              }
      let nc :: NewConversation
nc =
            NewConversation
              { $sel:ncMetadata:NewConversation :: ConversationMetadata
ncMetadata = ConversationMetadata
meta,
                $sel:ncUsers:NewConversation :: UserList (UserId, RoleName)
ncUsers = (UserId -> (UserId, RoleName))
-> UserList UserId -> UserList (UserId, RoleName)
forall a b. (a -> b) -> UserList a -> UserList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UserId -> (UserId, RoleName)
forall a. ToUserRole a => a -> (UserId, RoleName)
toUserRole (QualifiedWithTag 'QLocal ConvId
-> [Qualified UserId] -> UserList UserId
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> UserList a
toUserList QualifiedWithTag 'QLocal ConvId
lcnv [Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
self, Qualified UserId
other]),
                $sel:ncProtocol:NewConversation :: BaseProtocolTag
ncProtocol = BaseProtocolTag
BaseProtocolProteusTag
              }
      Conversation
c <- QualifiedWithTag 'QLocal ConvId
-> NewConversation -> Sem r Conversation
forall (r :: EffectRow).
Member ConversationStore r =>
QualifiedWithTag 'QLocal ConvId
-> NewConversation -> Sem r Conversation
E.createConversation QualifiedWithTag 'QLocal ConvId
lcnv NewConversation
nc
      Local UserId -> Maybe ConnId -> Conversation -> Sem r ()
forall (r :: EffectRow).
(Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r,
 Member BackendNotificationQueueAccess r, Member (Input UTCTime) r,
 Member TinyLog r) =>
Local UserId -> Maybe ConnId -> Conversation -> Sem r ()
notifyCreatedConversation Local UserId
self (ConnId -> Maybe ConnId
forall a. a -> Maybe a
Just ConnId
zcon) Conversation
c
      Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
conversationCreated Local UserId
self Conversation
c

createOne2OneConversationRemotely ::
  (Member (Error FederationError) r) =>
  Remote ConvId ->
  Local UserId ->
  ConnId ->
  Maybe (Range 1 256 Text) ->
  Maybe TeamId ->
  Qualified UserId ->
  Sem r (ConversationResponse Public.Conversation)
createOne2OneConversationRemotely :: forall (r :: EffectRow).
Member (Error FederationError) r =>
Remote ConvId
-> Local UserId
-> ConnId
-> Maybe (Range 1 256 Text)
-> Maybe TeamId
-> Qualified UserId
-> Sem r (ConversationResponse Conversation)
createOne2OneConversationRemotely Remote ConvId
_ Local UserId
_ ConnId
_ Maybe (Range 1 256 Text)
_ Maybe TeamId
_ Qualified UserId
_ =
  FederationError -> Sem r (ResponseForExistedCreated Conversation)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw FederationError
FederationNotImplemented

createConnectConversation ::
  ( Member BackendNotificationQueueAccess r,
    Member ConversationStore r,
    Member (ErrorS 'ConvNotFound) r,
    Member (Error FederationError) r,
    Member (Error InternalError) r,
    Member (Error InvalidInput) r,
    Member (ErrorS 'InvalidOperation) r,
    Member (Error UnreachableBackends) r,
    Member FederatorAccess r,
    Member NotificationSubsystem r,
    Member (Input UTCTime) r,
    Member MemberStore r,
    Member P.TinyLog r
  ) =>
  Local UserId ->
  Maybe ConnId ->
  Connect ->
  Sem r (ConversationResponse Public.Conversation)
createConnectConversation :: forall (r :: EffectRow).
(Member BackendNotificationQueueAccess r,
 Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
 Member (Error FederationError) r, Member (Error InternalError) r,
 Member (Error InvalidInput) r, Member (ErrorS 'InvalidOperation) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r, Member (Input UTCTime) r,
 Member MemberStore r, Member TinyLog r) =>
Local UserId
-> Maybe ConnId
-> Connect
-> Sem r (ConversationResponse Conversation)
createConnectConversation Local UserId
lusr Maybe ConnId
conn Connect
j = do
  Local UserId
lrecipient <- Local UserId -> Qualified UserId -> Sem r (Local UserId)
forall (r :: EffectRow) x a.
Member (Error FederationError) r =>
Local x -> Qualified a -> Sem r (Local a)
ensureLocal Local UserId
lusr (Connect -> Qualified UserId
cRecipient Connect
j)
  Maybe (Range 1 256 Text)
n <- Maybe Text -> Sem r (Maybe (Range 1 256 Text))
forall (r :: EffectRow) (n :: Nat) (m :: Nat) a.
(Member (Error InvalidInput) r, KnownNat n, KnownNat m,
 Within a n m) =>
Maybe a -> Sem r (Maybe (Range n m a))
rangeCheckedMaybe (Connect -> Maybe Text
cName Connect
j)
  let meta :: ConversationMetadata
meta =
        (Maybe UserId -> ConversationMetadata
defConversationMetadata (UserId -> Maybe UserId
forall a. a -> Maybe a
Just (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr)))
          { cnvmType = ConnectConv,
            cnvmName = fmap fromRange n
          }
  QualifiedWithTag 'QLocal ConvId
lcnv <- Local UserId
-> Local UserId -> Sem r (QualifiedWithTag 'QLocal ConvId)
forall (r :: EffectRow).
Member (Error InvalidInput) r =>
Local UserId
-> Local UserId -> Sem r (QualifiedWithTag 'QLocal ConvId)
localOne2OneConvId Local UserId
lusr Local UserId
lrecipient
  let nc :: NewConversation
nc =
        NewConversation
          { -- We add only one member, second one gets added later,
            -- when the other user accepts the connection request.
            $sel:ncUsers:NewConversation :: UserList (UserId, RoleName)
ncUsers = [(UserId, RoleName)] -> UserList (UserId, RoleName)
forall a. [a] -> UserList a
ulFromLocals ([(UserId -> (UserId, RoleName)
forall a. ToUserRole a => a -> (UserId, RoleName)
toUserRole (UserId -> (UserId, RoleName))
-> (Local UserId -> UserId) -> Local UserId -> (UserId, RoleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified) Local UserId
lusr]),
            $sel:ncProtocol:NewConversation :: BaseProtocolTag
ncProtocol = BaseProtocolTag
BaseProtocolProteusTag,
            $sel:ncMetadata:NewConversation :: ConversationMetadata
ncMetadata = ConversationMetadata
meta
          }
  ConvId -> Sem r (Maybe Conversation)
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Sem r (Maybe Conversation)
E.getConversation (QualifiedWithTag 'QLocal ConvId -> ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified QualifiedWithTag 'QLocal ConvId
lcnv)
    Sem r (Maybe Conversation)
-> (Maybe Conversation
    -> Sem r (ResponseForExistedCreated Conversation))
-> Sem r (ResponseForExistedCreated Conversation)
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Sem r (ResponseForExistedCreated Conversation)
-> (Conversation -> Sem r (ResponseForExistedCreated Conversation))
-> Maybe Conversation
-> Sem r (ResponseForExistedCreated Conversation)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (QualifiedWithTag 'QLocal ConvId
-> NewConversation
-> Sem r (ResponseForExistedCreated Conversation)
create QualifiedWithTag 'QLocal ConvId
lcnv NewConversation
nc) (Maybe (Range 1 256 Text)
-> Conversation -> Sem r (ResponseForExistedCreated Conversation)
update Maybe (Range 1 256 Text)
n)
  where
    create :: QualifiedWithTag 'QLocal ConvId
-> NewConversation
-> Sem r (ResponseForExistedCreated Conversation)
create QualifiedWithTag 'QLocal ConvId
lcnv NewConversation
nc = do
      Conversation
c <- QualifiedWithTag 'QLocal ConvId
-> NewConversation -> Sem r Conversation
forall (r :: EffectRow).
Member ConversationStore r =>
QualifiedWithTag 'QLocal ConvId
-> NewConversation -> Sem r Conversation
E.createConversation QualifiedWithTag 'QLocal ConvId
lcnv NewConversation
nc
      UTCTime
now <- Sem r UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
      let e :: Event
e = Qualified ConvId
-> Maybe SubConvId
-> Qualified UserId
-> UTCTime
-> EventData
-> Event
Event (QualifiedWithTag 'QLocal ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged QualifiedWithTag 'QLocal ConvId
lcnv) Maybe SubConvId
forall a. Maybe a
Nothing (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr) UTCTime
now (Connect -> EventData
EdConnect Connect
j)
      Local UserId -> Maybe ConnId -> Conversation -> Sem r ()
forall (r :: EffectRow).
(Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r,
 Member BackendNotificationQueueAccess r, Member (Input UTCTime) r,
 Member TinyLog r) =>
Local UserId -> Maybe ConnId -> Conversation -> Sem r ()
notifyCreatedConversation Local UserId
lusr Maybe ConnId
conn Conversation
c
      Maybe Push -> (Push -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (UserId -> Object -> [Recipient] -> Maybe Push
newPushLocal (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr) (Event -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject Event
e) (LocalMember -> Recipient
localMemberToRecipient (LocalMember -> Recipient) -> [LocalMember] -> [Recipient]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conversation -> [LocalMember]
Data.convLocalMembers Conversation
c)) ((Push -> Sem r ()) -> Sem r ()) -> (Push -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \Push
p ->
        [Push] -> Sem r ()
forall (r :: EffectRow).
Member NotificationSubsystem r =>
[Push] -> Sem r ()
pushNotifications
          [ Push
p
              Push -> (Push -> Push) -> Push
forall a b. a -> (a -> b) -> b
& (Route -> Identity Route) -> Push -> Identity Push
Lens' Push Route
pushRoute ((Route -> Identity Route) -> Push -> Identity Push)
-> Route -> Push -> Push
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Route
PushV2.RouteDirect
              Push -> (Push -> Push) -> Push
forall a b. a -> (a -> b) -> b
& (Maybe ConnId -> Identity (Maybe ConnId)) -> Push -> Identity Push
Lens' Push (Maybe ConnId)
pushConn ((Maybe ConnId -> Identity (Maybe ConnId))
 -> Push -> Identity Push)
-> Maybe ConnId -> Push -> Push
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe ConnId
conn
          ]
      Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
conversationCreated Local UserId
lusr Conversation
c
    update :: Maybe (Range 1 256 Text)
-> Conversation -> Sem r (ResponseForExistedCreated Conversation)
update Maybe (Range 1 256 Text)
n Conversation
conv = do
      let mems :: [LocalMember]
mems = Conversation -> [LocalMember]
Data.convLocalMembers Conversation
conv
       in Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
conversationExisted Local UserId
lusr
            (Conversation -> Sem r (ResponseForExistedCreated Conversation))
-> Sem r Conversation
-> Sem r (ResponseForExistedCreated Conversation)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< if Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr UserId -> [LocalMember] -> Bool
forall (m :: * -> *). Foldable m => UserId -> m LocalMember -> Bool
`isMember` [LocalMember]
mems
              then -- we already were in the conversation, maybe also other
                Maybe (Range 1 256 Text) -> Conversation -> Sem r Conversation
connect Maybe (Range 1 256 Text)
n Conversation
conv
              else do
                let lcid :: QualifiedWithTag 'QLocal ConvId
lcid = Local UserId -> ConvId -> QualifiedWithTag 'QLocal ConvId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local UserId
lusr (Conversation -> ConvId
Data.convId Conversation
conv)
                [LocalMember]
mm <- QualifiedWithTag 'QLocal ConvId
-> Local UserId -> Sem r [LocalMember]
forall (r :: EffectRow).
Member MemberStore r =>
QualifiedWithTag 'QLocal ConvId
-> Local UserId -> Sem r [LocalMember]
E.createMember QualifiedWithTag 'QLocal ConvId
lcid Local UserId
lusr
                let conv' :: Conversation
conv' =
                      Conversation
conv
                        { Data.convLocalMembers = Data.convLocalMembers conv <> toList mm
                        }
                if [LocalMember] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocalMember]
mems
                  then do
                    -- the conversation was empty
                    Maybe (Range 1 256 Text) -> Conversation -> Sem r Conversation
connect Maybe (Range 1 256 Text)
n Conversation
conv'
                  else do
                    -- we were not in the conversation, but someone else
                    Conversation
conv'' <- Local UserId -> Conversation -> Maybe ConnId -> Sem r Conversation
forall (r :: EffectRow).
(Member ConversationStore r, Member (ErrorS 'ConvNotFound) r,
 Member (Error InternalError) r,
 Member (ErrorS 'InvalidOperation) r, Member (Input UTCTime) r,
 Member MemberStore r, Member NotificationSubsystem r) =>
Local UserId -> Conversation -> Maybe ConnId -> Sem r Conversation
acceptOne2One Local UserId
lusr Conversation
conv' Maybe ConnId
conn
                    if Conversation -> ConvType
Data.convType Conversation
conv'' ConvType -> ConvType -> Bool
forall a. Eq a => a -> a -> Bool
== ConvType
ConnectConv
                      then Maybe (Range 1 256 Text) -> Conversation -> Sem r Conversation
connect Maybe (Range 1 256 Text)
n Conversation
conv''
                      else Conversation -> Sem r Conversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conversation
conv''
    connect :: Maybe (Range 1 256 Text) -> Conversation -> Sem r Conversation
connect Maybe (Range 1 256 Text)
n Conversation
conv
      | Conversation -> ConvType
Data.convType Conversation
conv ConvType -> ConvType -> Bool
forall a. Eq a => a -> a -> Bool
== ConvType
ConnectConv = do
          let lcnv :: QualifiedWithTag 'QLocal ConvId
lcnv = Local UserId -> ConvId -> QualifiedWithTag 'QLocal ConvId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local UserId
lusr (Conversation -> ConvId
Data.convId Conversation
conv)
          Maybe Text
n' <- case Maybe (Range 1 256 Text)
n of
            Just Range 1 256 Text
x -> do
              ConvId -> Range 1 256 Text -> Sem r ()
forall (r :: EffectRow).
Member ConversationStore r =>
ConvId -> Range 1 256 Text -> Sem r ()
E.setConversationName (Conversation -> ConvId
Data.convId Conversation
conv) Range 1 256 Text
x
              Maybe Text -> Sem r (Maybe Text)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Sem r (Maybe Text))
-> (Text -> Maybe Text) -> Text -> Sem r (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Sem r (Maybe Text)) -> Text -> Sem r (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Range 1 256 Text -> Text
forall (n :: Nat) (m :: Nat) a. Range n m a -> a
fromRange Range 1 256 Text
x
            Maybe (Range 1 256 Text)
Nothing -> Maybe Text -> Sem r (Maybe Text)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Sem r (Maybe Text))
-> Maybe Text -> Sem r (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Conversation -> Maybe Text
Data.convName Conversation
conv
          UTCTime
t <- Sem r UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
          let e :: Event
e = Qualified ConvId
-> Maybe SubConvId
-> Qualified UserId
-> UTCTime
-> EventData
-> Event
Event (QualifiedWithTag 'QLocal ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged QualifiedWithTag 'QLocal ConvId
lcnv) Maybe SubConvId
forall a. Maybe a
Nothing (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr) UTCTime
t (Connect -> EventData
EdConnect Connect
j)
          Maybe Push -> (Push -> Sem r ()) -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (UserId -> Object -> [Recipient] -> Maybe Push
newPushLocal (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr) (Event -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject Event
e) (LocalMember -> Recipient
localMemberToRecipient (LocalMember -> Recipient) -> [LocalMember] -> [Recipient]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conversation -> [LocalMember]
Data.convLocalMembers Conversation
conv)) ((Push -> Sem r ()) -> Sem r ()) -> (Push -> Sem r ()) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \Push
p ->
            [Push] -> Sem r ()
forall (r :: EffectRow).
Member NotificationSubsystem r =>
[Push] -> Sem r ()
pushNotifications
              [ Push
p
                  Push -> (Push -> Push) -> Push
forall a b. a -> (a -> b) -> b
& (Route -> Identity Route) -> Push -> Identity Push
Lens' Push Route
pushRoute ((Route -> Identity Route) -> Push -> Identity Push)
-> Route -> Push -> Push
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Route
PushV2.RouteDirect
                  Push -> (Push -> Push) -> Push
forall a b. a -> (a -> b) -> b
& (Maybe ConnId -> Identity (Maybe ConnId)) -> Push -> Identity Push
Lens' Push (Maybe ConnId)
pushConn ((Maybe ConnId -> Identity (Maybe ConnId))
 -> Push -> Identity Push)
-> Maybe ConnId -> Push -> Push
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe ConnId
conn
              ]
          Conversation -> Sem r Conversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Conversation -> Sem r Conversation)
-> Conversation -> Sem r Conversation
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Conversation -> Conversation
Data.convSetName Maybe Text
n' Conversation
conv
      | Bool
otherwise = Conversation -> Sem r Conversation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conversation
conv

--------------------------------------------------------------------------------
-- Conversation creation records

-- | Return a 'NewConversation' record suitable for creating a group conversation.
newRegularConversation ::
  ( Member (ErrorS 'MLSNonEmptyMemberList) r,
    Member (Error InvalidInput) r,
    Member (Input Opts) r
  ) =>
  Local UserId ->
  NewConv ->
  Sem r (NewConversation, ConvSizeChecked UserList UserId)
newRegularConversation :: forall (r :: EffectRow).
(Member (ErrorS 'MLSNonEmptyMemberList) r,
 Member (Error InvalidInput) r, Member (Input Opts) r) =>
Local UserId
-> NewConv
-> Sem r (NewConversation, ConvSizeChecked UserList UserId)
newRegularConversation Local UserId
lusr NewConv
newConv = do
  Opts
o <- Sem r Opts
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
  let uncheckedUsers :: UserList UserId
uncheckedUsers = Local UserId -> NewConv -> UserList UserId
forall x. Local x -> NewConv -> UserList UserId
newConvMembers Local UserId
lusr NewConv
newConv
  ConvSizeChecked UserList UserId
users <- case NewConv -> BaseProtocolTag
newConvProtocol NewConv
newConv of
    BaseProtocolTag
BaseProtocolProteusTag -> Opts -> UserList UserId -> Sem r (ConvSizeChecked UserList UserId)
forall (r :: EffectRow) (f :: * -> *) a.
(Member (Error InvalidInput) r, Foldable f) =>
Opts -> f a -> Sem r (ConvSizeChecked f a)
checkedConvSize Opts
o UserList UserId
uncheckedUsers
    BaseProtocolTag
BaseProtocolMLSTag -> do
      Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UserList UserId -> Bool
forall a. UserList a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null UserList UserId
uncheckedUsers) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ forall {k} (e :: k) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
forall (e :: GalleyError) (r :: EffectRow) a.
Member (ErrorS e) r =>
Sem r a
throwS @'MLSNonEmptyMemberList
      ConvSizeChecked UserList UserId
-> Sem r (ConvSizeChecked UserList UserId)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConvSizeChecked UserList UserId
forall a. Monoid a => a
mempty
  let nc :: NewConversation
nc =
        NewConversation
          { $sel:ncMetadata:NewConversation :: ConversationMetadata
ncMetadata =
              ConversationMetadata
                { $sel:cnvmType:ConversationMetadata :: ConvType
cnvmType = ConvType
RegularConv,
                  $sel:cnvmCreator:ConversationMetadata :: Maybe UserId
cnvmCreator = UserId -> Maybe UserId
forall a. a -> Maybe a
Just (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr),
                  $sel:cnvmAccess:ConversationMetadata :: [Access]
cnvmAccess = NewConv -> [Access]
access NewConv
newConv,
                  $sel:cnvmAccessRoles:ConversationMetadata :: Set AccessRole
cnvmAccessRoles = NewConv -> Set AccessRole
accessRoles NewConv
newConv,
                  $sel:cnvmName:ConversationMetadata :: Maybe Text
cnvmName = (Range 1 256 Text -> Text)
-> Maybe (Range 1 256 Text) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Range 1 256 Text -> Text
forall (n :: Nat) (m :: Nat) a. Range n m a -> a
fromRange (NewConv -> Maybe (Range 1 256 Text)
newConvName NewConv
newConv),
                  $sel:cnvmMessageTimer:ConversationMetadata :: Maybe Milliseconds
cnvmMessageTimer = NewConv -> Maybe Milliseconds
newConvMessageTimer NewConv
newConv,
                  $sel:cnvmReceiptMode:ConversationMetadata :: Maybe ReceiptMode
cnvmReceiptMode = NewConv -> Maybe ReceiptMode
newConvReceiptMode NewConv
newConv,
                  $sel:cnvmTeam:ConversationMetadata :: Maybe TeamId
cnvmTeam = (ConvTeamInfo -> TeamId) -> Maybe ConvTeamInfo -> Maybe TeamId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConvTeamInfo -> TeamId
cnvTeamId (NewConv -> Maybe ConvTeamInfo
newConvTeam NewConv
newConv)
                },
            $sel:ncUsers:NewConversation :: UserList (UserId, RoleName)
ncUsers = (UserId, RoleName)
-> UserList (UserId, RoleName) -> UserList (UserId, RoleName)
forall a. a -> UserList a -> UserList a
ulAddLocal (UserId -> (UserId, RoleName)
forall a. ToUserRole a => a -> (UserId, RoleName)
toUserRole (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr)) ((UserId -> (UserId, RoleName))
-> UserList UserId -> UserList (UserId, RoleName)
forall a b. (a -> b) -> UserList a -> UserList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,NewConv -> RoleName
newConvUsersRole NewConv
newConv) (ConvSizeChecked UserList UserId -> UserList UserId
forall {k} (f :: k -> *) (a :: k). ConvSizeChecked f a -> f a
fromConvSize ConvSizeChecked UserList UserId
users)),
            $sel:ncProtocol:NewConversation :: BaseProtocolTag
ncProtocol = NewConv -> BaseProtocolTag
newConvProtocol NewConv
newConv
          }
  (NewConversation, ConvSizeChecked UserList UserId)
-> Sem r (NewConversation, ConvSizeChecked UserList UserId)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewConversation
nc, ConvSizeChecked UserList UserId
users)

-------------------------------------------------------------------------------
-- Helpers

conversationCreated ::
  ( Member (Error InternalError) r,
    Member P.TinyLog r
  ) =>
  Local UserId ->
  Data.Conversation ->
  Sem r (ConversationResponse Public.Conversation)
conversationCreated :: forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId
-> Conversation -> Sem r (ConversationResponse Conversation)
conversationCreated Local UserId
lusr Conversation
cnv = Conversation -> ResponseForExistedCreated Conversation
forall a. a -> ResponseForExistedCreated a
Created (Conversation -> ResponseForExistedCreated Conversation)
-> Sem r Conversation
-> Sem r (ResponseForExistedCreated Conversation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Local UserId -> Conversation -> Sem r Conversation
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
Local UserId -> Conversation -> Sem r Conversation
conversationView Local UserId
lusr Conversation
cnv

-- | The return set contains all the remote users that could not be contacted.
-- Consequently, the unreachable users are not added to the member list. This
-- behavior might be changed later on when a message/event queue per remote
-- backend is implemented.
notifyCreatedConversation ::
  ( Member ConversationStore r,
    Member (Error FederationError) r,
    Member (Error InternalError) r,
    Member (Error UnreachableBackends) r,
    Member FederatorAccess r,
    Member NotificationSubsystem r,
    Member BackendNotificationQueueAccess r,
    Member (Input UTCTime) r,
    Member P.TinyLog r
  ) =>
  Local UserId ->
  Maybe ConnId ->
  Data.Conversation ->
  Sem r ()
notifyCreatedConversation :: forall (r :: EffectRow).
(Member ConversationStore r, Member (Error FederationError) r,
 Member (Error InternalError) r,
 Member (Error UnreachableBackends) r, Member FederatorAccess r,
 Member NotificationSubsystem r,
 Member BackendNotificationQueueAccess r, Member (Input UTCTime) r,
 Member TinyLog r) =>
Local UserId -> Maybe ConnId -> Conversation -> Sem r ()
notifyCreatedConversation Local UserId
lusr Maybe ConnId
conn Conversation
c = do
  UTCTime
now <- Sem r UTCTime
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
  -- Ask remote servers to store conversation membership and notify remote users
  -- of being added to a conversation
  UTCTime -> Local UserId -> Local Conversation -> Sem r ()
forall (r :: EffectRow).
(Member ConversationStore r, Member (Error UnreachableBackends) r,
 Member (Error FederationError) r,
 Member BackendNotificationQueueAccess r,
 Member FederatorAccess r) =>
UTCTime -> Local UserId -> Local Conversation -> Sem r ()
registerRemoteConversationMemberships UTCTime
now Local UserId
lusr (Local UserId -> Conversation -> Local Conversation
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local UserId
lusr Conversation
c)
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([RemoteMember] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Conversation -> [RemoteMember]
Data.convRemoteMembers Conversation
c)) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM Sem r Bool
forall (r :: EffectRow). Member FederatorAccess r => Sem r Bool
E.isFederationConfigured (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
      FederationError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw FederationError
FederationNotConfigured

  -- Notify local users
  [Push] -> Sem r ()
forall (r :: EffectRow).
Member NotificationSubsystem r =>
[Push] -> Sem r ()
pushNotifications ([Push] -> Sem r ()) -> Sem r [Push] -> Sem r ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (LocalMember -> Sem r Push) -> [LocalMember] -> Sem r [Push]
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 (UTCTime -> LocalMember -> Sem r Push
toPush UTCTime
now) (Conversation -> [LocalMember]
Data.convLocalMembers Conversation
c)
  where
    route :: Route
route
      | Conversation -> ConvType
Data.convType Conversation
c ConvType -> ConvType -> Bool
forall a. Eq a => a -> a -> Bool
== ConvType
RegularConv = Route
PushV2.RouteAny
      | Bool
otherwise = Route
PushV2.RouteDirect
    toPush :: UTCTime -> LocalMember -> Sem r Push
toPush UTCTime
t LocalMember
m = do
      let remoteOthers :: [OtherMember]
remoteOthers = RemoteMember -> OtherMember
remoteMemberToOther (RemoteMember -> OtherMember) -> [RemoteMember] -> [OtherMember]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conversation -> [RemoteMember]
Data.convRemoteMembers Conversation
c
          localOthers :: [OtherMember]
localOthers = (LocalMember -> OtherMember) -> [LocalMember] -> [OtherMember]
forall a b. (a -> b) -> [a] -> [b]
map (Domain -> LocalMember -> OtherMember
localMemberToOther (Local UserId -> Domain
forall (t :: QTag) a. QualifiedWithTag t a -> Domain
tDomain Local UserId
lusr)) ([LocalMember] -> [OtherMember]) -> [LocalMember] -> [OtherMember]
forall a b. (a -> b) -> a -> b
$ Conversation -> [LocalMember]
Data.convLocalMembers Conversation
c
          lconv :: QualifiedWithTag 'QLocal ConvId
lconv = Local UserId -> ConvId -> QualifiedWithTag 'QLocal ConvId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local UserId
lusr (Conversation -> ConvId
Data.convId Conversation
c)
      Conversation
c' <- [OtherMember]
-> [OtherMember]
-> Conversation
-> Local UserId
-> Sem r Conversation
forall (r :: EffectRow).
(Member (Error InternalError) r, Member TinyLog r) =>
[OtherMember]
-> [OtherMember]
-> Conversation
-> Local UserId
-> Sem r Conversation
conversationViewWithCachedOthers [OtherMember]
remoteOthers [OtherMember]
localOthers Conversation
c (Local UserId -> UserId -> Local UserId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local UserId
lusr (LocalMember -> UserId
lmId LocalMember
m))
      let e :: Event
e = Qualified ConvId
-> Maybe SubConvId
-> Qualified UserId
-> UTCTime
-> EventData
-> Event
Event (QualifiedWithTag 'QLocal ConvId -> Qualified ConvId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged QualifiedWithTag 'QLocal ConvId
lconv) Maybe SubConvId
forall a. Maybe a
Nothing (Local UserId -> Qualified UserId
forall (t :: QTag) a. QualifiedWithTag t a -> Qualified a
tUntagged Local UserId
lusr) UTCTime
t (Conversation -> EventData
EdConversation Conversation
c')
      Push -> Sem r Push
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Push -> Sem r Push) -> Push -> Sem r Push
forall a b. (a -> b) -> a -> b
$
        UserId -> Object -> NonEmpty Recipient -> Push
newPushLocal1 (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
lusr) (Event -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject Event
e) (Recipient -> NonEmpty Recipient
forall a. a -> NonEmpty a
NonEmpty.singleton (LocalMember -> Recipient
localMemberToRecipient LocalMember
m))
          Push -> (Push -> Push) -> Push
forall a b. a -> (a -> b) -> b
& (Maybe ConnId -> Identity (Maybe ConnId)) -> Push -> Identity Push
Lens' Push (Maybe ConnId)
pushConn ((Maybe ConnId -> Identity (Maybe ConnId))
 -> Push -> Identity Push)
-> Maybe ConnId -> Push -> Push
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe ConnId
conn
          Push -> (Push -> Push) -> Push
forall a b. a -> (a -> b) -> b
& (Route -> Identity Route) -> Push -> Identity Push
Lens' Push Route
pushRoute ((Route -> Identity Route) -> Push -> Identity Push)
-> Route -> Push -> Push
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Route
route

localOne2OneConvId ::
  (Member (Error InvalidInput) r) =>
  Local UserId ->
  Local UserId ->
  Sem r (Local ConvId)
localOne2OneConvId :: forall (r :: EffectRow).
Member (Error InvalidInput) r =>
Local UserId
-> Local UserId -> Sem r (QualifiedWithTag 'QLocal ConvId)
localOne2OneConvId Local UserId
self Local UserId
other = do
  (UUID V4
x, UUID V4
y) <- UserId -> UserId -> Sem r (UUID V4, UUID V4)
forall (r :: EffectRow).
Member (Error InvalidInput) r =>
UserId -> UserId -> Sem r (UUID V4, UUID V4)
toUUIDs (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
self) (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
other)
  QualifiedWithTag 'QLocal ConvId
-> Sem r (QualifiedWithTag 'QLocal ConvId)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QualifiedWithTag 'QLocal ConvId
 -> Sem r (QualifiedWithTag 'QLocal ConvId))
-> (ConvId -> QualifiedWithTag 'QLocal ConvId)
-> ConvId
-> Sem r (QualifiedWithTag 'QLocal ConvId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Local UserId -> ConvId -> QualifiedWithTag 'QLocal ConvId
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local UserId
self (ConvId -> Sem r (QualifiedWithTag 'QLocal ConvId))
-> ConvId -> Sem r (QualifiedWithTag 'QLocal ConvId)
forall a b. (a -> b) -> a -> b
$ UUID V4 -> UUID V4 -> ConvId
Data.localOne2OneConvId UUID V4
x UUID V4
y

toUUIDs ::
  (Member (Error InvalidInput) r) =>
  UserId ->
  UserId ->
  Sem r (U.UUID U.V4, U.UUID U.V4)
toUUIDs :: forall (r :: EffectRow).
Member (Error InvalidInput) r =>
UserId -> UserId -> Sem r (UUID V4, UUID V4)
toUUIDs UserId
a UserId
b = do
  UUID V4
a' <- UUID -> Maybe (UUID V4)
forall {k} (v :: k). Version v => UUID -> Maybe (UUID v)
U.fromUUID (UserId -> UUID
forall {k} (a :: k). Id a -> UUID
toUUID UserId
a) Maybe (UUID V4)
-> (Maybe (UUID V4) -> Sem r (UUID V4)) -> Sem r (UUID V4)
forall a b. a -> (a -> b) -> b
& InvalidInput -> Maybe (UUID V4) -> Sem r (UUID V4)
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note InvalidInput
InvalidUUID4
  UUID V4
b' <- UUID -> Maybe (UUID V4)
forall {k} (v :: k). Version v => UUID -> Maybe (UUID v)
U.fromUUID (UserId -> UUID
forall {k} (a :: k). Id a -> UUID
toUUID UserId
b) Maybe (UUID V4)
-> (Maybe (UUID V4) -> Sem r (UUID V4)) -> Sem r (UUID V4)
forall a b. a -> (a -> b) -> b
& InvalidInput -> Maybe (UUID V4) -> Sem r (UUID V4)
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note InvalidInput
InvalidUUID4
  (UUID V4, UUID V4) -> Sem r (UUID V4, UUID V4)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UUID V4
a', UUID V4
b')

accessRoles :: NewConv -> Set AccessRole
accessRoles :: NewConv -> Set AccessRole
accessRoles NewConv
b = Set AccessRole -> Maybe (Set AccessRole) -> Set AccessRole
forall a. a -> Maybe a -> a
fromMaybe Set AccessRole
Data.defRole (NewConv -> Maybe (Set AccessRole)
newConvAccessRoles NewConv
b)

access :: NewConv -> [Access]
access :: NewConv -> [Access]
access NewConv
a = case Set Access -> [Access]
forall a. Set a -> [a]
Set.toList (NewConv -> Set Access
newConvAccess NewConv
a) of
  [] -> [Access]
Data.defRegularConvAccess
  (Access
x : [Access]
xs) -> Access
x Access -> [Access] -> [Access]
forall a. a -> [a] -> [a]
: [Access]
xs

newConvMembers :: Local x -> NewConv -> UserList UserId
newConvMembers :: forall x. Local x -> NewConv -> UserList UserId
newConvMembers Local x
loc NewConv
body =
  [UserId] -> [QualifiedWithTag 'QRemote UserId] -> UserList UserId
forall a. [a] -> [Remote a] -> UserList a
UserList (NewConv -> [UserId]
newConvUsers NewConv
body) []
    UserList UserId -> UserList UserId -> UserList UserId
forall a. Semigroup a => a -> a -> a
<> Local x -> [Qualified UserId] -> UserList UserId
forall (f :: * -> *) x a.
Foldable f =>
Local x -> f (Qualified a) -> UserList a
toUserList Local x
loc (NewConv -> [Qualified UserId]
newConvQualifiedUsers NewConv
body)

ensureOne :: (Member (Error InvalidInput) r) => [a] -> Sem r a
ensureOne :: forall (r :: EffectRow) a.
Member (Error InvalidInput) r =>
[a] -> Sem r a
ensureOne [a
x] = a -> Sem r a
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
ensureOne [a]
_ = InvalidInput -> Sem r a
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (LText -> InvalidInput
InvalidRange LText
"One-to-one conversations can only have a single invited member")