diff --git a/changelog.d/5-internal/polysemy-errors b/changelog.d/5-internal/polysemy-errors new file mode 100644 index 00000000000..b7b8060ebf0 --- /dev/null +++ b/changelog.d/5-internal/polysemy-errors @@ -0,0 +1 @@ +Introduce fine-grained error types and polysemy error effects in Galley. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 608fac4d389..cb2cfc2522f 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -127,6 +127,7 @@ data FederationError | FederationNotImplemented | FederationNotConfigured | FederationCallFailure FederationClientFailure + | FederationUnexpectedBody Text deriving (Show, Eq, Typeable) instance Exception FederationError diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs index 6aa875b608a..8b363936164 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs @@ -76,6 +76,7 @@ federationErrorToWai (FederationCallFailure failure) = addErrorData $ Wai.federrPath = T.decodeUtf8 (fedFailPath failure) } } +federationErrorToWai (FederationUnexpectedBody s) = federationUnexpectedBody s noFederationStatus :: Status noFederationStatus = status403 diff --git a/libs/wire-api/src/Wire/API/Conversation/Action.hs b/libs/wire-api/src/Wire/API/Conversation/Action.hs index a7bf22c23b2..9080c867328 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Action.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Action.hs @@ -34,8 +34,7 @@ import Wire.API.Conversation.Role import Wire.API.Event.Conversation import Wire.API.Util.Aeson (CustomEncoded (..)) --- | An update to a conversation, including addition and removal of members. --- Used to send notifications to users and to remote backends. +-- | A sum type consisting of all possible conversation actions. data ConversationAction = ConversationActionAddMembers (NonEmpty (Qualified UserId)) RoleName | ConversationActionRemoveMembers (NonEmpty (Qualified UserId)) diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 11f28240723..42363dc0e8c 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -226,10 +226,13 @@ noIdentity n = ErrorDescription (Text.pack (symbolVal (Proxy @desc)) <> " (code type OperationDenied = ErrorDescription 403 "operation-denied" "Insufficient permissions" -operationDenied :: Show perm => perm -> OperationDenied -operationDenied p = +operationDeniedSpecialized :: String -> OperationDenied +operationDeniedSpecialized p = ErrorDescription $ - "Insufficient permissions (missing " <> Text.pack (show p) <> ")" + "Insufficient permissions (missing " <> Text.pack p <> ")" + +operationDenied :: Show perm => perm -> OperationDenied +operationDenied = operationDeniedSpecialized . show type NotATeamMember = ErrorDescription 403 "no-team-member" "Requesting user is not a team member" diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 3efbf509124..7eeb2c3d6b9 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 7c30fbe05e0beac371abdaab802319d909686c98a1b133508c984e021b2999ba +-- hash: 6f378c75d7938aa5f221f136049c8ca98f63e7ae682e0035fb912f3917cfd1b1 name: galley version: 0.83.0 @@ -25,6 +25,7 @@ flag static library exposed-modules: Galley.API + Galley.API.Action Galley.API.Clients Galley.API.Create Galley.API.CustomBackend diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs new file mode 100644 index 00000000000..4f3e508b11e --- /dev/null +++ b/services/galley/src/Galley/API/Action.hs @@ -0,0 +1,519 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- 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 . + +module Galley.API.Action + ( -- * Conversation action class + IsConversationAction (..), + + -- * Conversation action types + ConversationDelete (..), + ConversationJoin (..), + ConversationLeave (..), + ConversationMemberUpdate (..), + + -- * Performing actions + updateLocalConversation, + + -- * Utilities + ensureConversationActionAllowed, + addMembersToLocalConversation, + notifyConversationAction, + ) +where + +import qualified Brig.Types.User as User +import Control.Lens +import Control.Monad.Trans.Maybe +import Data.Id +import Data.Kind +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Misc +import Data.Qualified +import qualified Data.Set as Set +import Data.Time.Clock +import Galley.API.Error +import Galley.API.Util +import Galley.App +import Galley.Data.Conversation +import Galley.Data.Services +import Galley.Data.Types +import Galley.Effects +import qualified Galley.Effects.BotAccess as E +import qualified Galley.Effects.BrigAccess as E +import qualified Galley.Effects.CodeStore as E +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.FederatorAccess as E +import qualified Galley.Effects.MemberStore as E +import qualified Galley.Effects.TeamStore as E +import Galley.Types.Conversations.Members +import Galley.Types.UserList +import Galley.Validation +import Imports +import Polysemy +import Polysemy.Error +import Wire.API.Conversation hiding (Conversation, Member) +import Wire.API.Conversation.Action +import Wire.API.Conversation.Role +import Wire.API.ErrorDescription +import Wire.API.Event.Conversation hiding (Conversation) +import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.Client +import Wire.API.Team.LegalHold +import Wire.API.Team.Member + +-- | An update to a conversation, including addition and removal of members. +-- Used to send notifications to users and to remote backends. +class IsConversationAction a where + type HasConversationActionEffects a (r :: EffectRow) :: Constraint + + conversationAction :: a -> ConversationAction + ensureAllowed :: + (IsConvMember mem, HasConversationActionEffects a r) => + Local x -> + a -> + Conversation -> + mem -> + Galley r () + ensureAllowed _ _ _ _ = pure () + conversationActionTag' :: Qualified UserId -> a -> Action + performAction :: + ( HasConversationActionEffects a r, + Members '[ConversationStore] r + ) => + Qualified UserId -> + Local ConvId -> + Conversation -> + a -> + MaybeT (Galley r) (BotsAndMembers, a) + +-- | The action of some users joining a conversation. +data ConversationJoin = ConversationJoin + { cjUsers :: NonEmpty (Qualified UserId), + cjRole :: RoleName + } + +-- | The action of some users leaving a conversation. +newtype ConversationLeave = ConversationLeave + {clUsers :: NonEmpty (Qualified UserId)} + +-- | The action of promoting/demoting a member of a conversation. +data ConversationMemberUpdate = ConversationMemberUpdate + { cmuTarget :: Qualified UserId, + cmuUpdate :: OtherMemberUpdate + } + +-- | The action of deleting a conversation. +data ConversationDelete = ConversationDelete + +instance IsConversationAction ConversationJoin where + type + HasConversationActionEffects ConversationJoin r = + Members + '[ BrigAccess, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r + + conversationAction cj = ConversationActionAddMembers (cjUsers cj) (cjRole cj) + ensureAllowed _ cj _ self = ensureConvRoleNotElevated self (cjRole cj) + conversationActionTag' _ _ = AddConversationMember + performAction qusr lcnv conv (ConversationJoin invited role) = do + let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited + + lift $ do + lusr <- liftSem $ ensureLocal lcnv qusr + ensureMemberLimit (toList (convLocalMembers conv)) newMembers + liftSem $ ensureAccess conv InviteAccess + checkLocals lusr (convTeam conv) (ulLocals newMembers) + checkRemotes lusr (ulRemotes newMembers) + checkLHPolicyConflictsLocal (ulLocals newMembers) + checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) + + addMembersToLocalConversation lcnv newMembers role + where + userIsMember u = (^. userId . to (== u)) + + checkLocals :: + Members + '[ BrigAccess, + Error ActionError, + Error ConversationError, + Error NotATeamMember, + TeamStore + ] + r => + Local UserId -> + Maybe TeamId -> + [UserId] -> + Galley r () + checkLocals lusr (Just tid) newUsers = do + tms <- liftSem $ E.selectTeamMembers tid newUsers + let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers + ensureAccessRole (convAccessRole conv) userMembershipMap + ensureConnectedOrSameTeam lusr newUsers + checkLocals lusr Nothing newUsers = do + ensureAccessRole (convAccessRole conv) (zip newUsers $ repeat Nothing) + ensureConnectedOrSameTeam lusr newUsers + + checkRemotes :: + Members '[BrigAccess, Error ActionError, Error FederationError, TeamStore] r => + Local UserId -> + [Remote UserId] -> + Galley r () + checkRemotes lusr remotes = do + -- if federator is not configured, we fail early, so we avoid adding + -- remote members to the database + unless (null remotes) $ do + endpoint <- federatorEndpoint + liftSem . when (isNothing endpoint) $ + throw FederationNotConfigured + ensureConnectedToRemotes lusr remotes + + checkLHPolicyConflictsLocal :: + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => + [UserId] -> + Galley r () + checkLHPolicyConflictsLocal newUsers = do + let convUsers = convLocalMembers conv + + allNewUsersGaveConsent <- allLegalholdConsentGiven newUsers + + whenM (anyLegalholdActivated (lmId <$> convUsers)) $ + unless allNewUsersGaveConsent $ + liftSem $ throw MissingLegalholdConsent + + whenM (anyLegalholdActivated newUsers) $ do + unless allNewUsersGaveConsent $ + liftSem $ throw MissingLegalholdConsent + + convUsersLHStatus <- do + uidsStatus <- getLHStatusForUsers (lmId <$> convUsers) + pure $ zipWith (\mem (_, status) -> (mem, status)) convUsers uidsStatus + + if any + ( \(mem, status) -> + lmConvRoleName mem == roleNameWireAdmin + && consentGiven status == ConsentGiven + ) + convUsersLHStatus + then do + for_ convUsersLHStatus $ \(mem, status) -> + when (consentGiven status == ConsentNotGiven) $ do + qvictim <- qUntagged <$> qualifyLocal (lmId mem) + void . runMaybeT $ + updateLocalConversation lcnv qvictim Nothing $ + ConversationLeave (pure qvictim) + else liftSem $ throw MissingLegalholdConsent + + checkLHPolicyConflictsRemote :: + FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> + Galley r () + checkLHPolicyConflictsRemote _remotes = pure () + +instance IsConversationAction ConversationLeave where + type + HasConversationActionEffects ConversationLeave r = + (Members '[MemberStore] r) + conversationAction cl = ConversationActionRemoveMembers (clUsers cl) + conversationActionTag' qusr a + | pure qusr == clUsers a = LeaveConversation + | otherwise = RemoveConversationMember + performAction _qusr lcnv conv action = do + let presentVictims = filter (isConvMember lcnv conv) (toList (clUsers action)) + guard . not . null $ presentVictims + lift . liftSem $ E.deleteMembers (convId conv) (toUserList lcnv presentVictims) + pure (mempty, action) -- FUTUREWORK: should we return the filtered action here? + +instance IsConversationAction ConversationMemberUpdate where + type + HasConversationActionEffects ConversationMemberUpdate r = + (Members '[MemberStore, Error ConversationError] r) + conversationAction cmu = ConversationActionMemberUpdate (cmuTarget cmu) (cmuUpdate cmu) + conversationActionTag' _ _ = ModifyOtherConversationMember + performAction _qusr lcnv conv action = lift . liftSem $ do + void $ ensureOtherMember lcnv (cmuTarget action) conv + E.setOtherMember lcnv (cmuTarget action) (cmuUpdate action) + pure (mempty, action) + +instance IsConversationAction ConversationDelete where + type + HasConversationActionEffects ConversationDelete r = + Members '[Error FederationError, Error NotATeamMember, CodeStore, TeamStore] r + conversationAction ConversationDelete = ConversationActionDelete + ensureAllowed loc ConversationDelete conv self = + liftSem . for_ (convTeam conv) $ \tid -> do + lusr <- ensureLocal loc (convMemberId loc self) + void $ E.getTeamMember tid (tUnqualified lusr) >>= noteED @NotATeamMember + conversationActionTag' _ _ = DeleteConversation + performAction _ lcnv conv action = lift . liftSem $ do + key <- E.makeKey (tUnqualified lcnv) + E.deleteCode key ReusableCode + case convTeam conv of + Nothing -> E.deleteConversation (tUnqualified lcnv) + Just tid -> E.deleteTeamConversation tid (tUnqualified lcnv) + pure (mempty, action) + +instance IsConversationAction ConversationRename where + type + HasConversationActionEffects ConversationRename r = + Members '[Error ActionError, Error InvalidInput] r + + conversationAction = ConversationActionRename + conversationActionTag' _ _ = ModifyConversationName + performAction _ lcnv _ action = lift . liftSem $ do + cn <- rangeChecked (cupName action) + E.setConversationName (tUnqualified lcnv) cn + pure (mempty, action) + +instance IsConversationAction ConversationMessageTimerUpdate where + type HasConversationActionEffects ConversationMessageTimerUpdate r = () + conversationAction = ConversationActionMessageTimerUpdate + conversationActionTag' _ _ = ModifyConversationMessageTimer + performAction _ lcnv conv action = do + guard $ convMessageTimer conv /= cupMessageTimer action + lift . liftSem $ E.setConversationMessageTimer (tUnqualified lcnv) (cupMessageTimer action) + pure (mempty, action) + +instance IsConversationAction ConversationReceiptModeUpdate where + type HasConversationActionEffects ConversationReceiptModeUpdate r = () + conversationAction = ConversationActionReceiptModeUpdate + conversationActionTag' _ _ = ModifyConversationReceiptMode + performAction _ lcnv conv action = do + guard $ convReceiptMode conv /= Just (cruReceiptMode action) + lift . liftSem $ E.setConversationReceiptMode (tUnqualified lcnv) (cruReceiptMode action) + pure (mempty, action) + +instance IsConversationAction ConversationAccessData where + type + HasConversationActionEffects ConversationAccessData r = + Members + '[ BotAccess, + BrigAccess, + CodeStore, + Error ActionError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r + conversationAction = ConversationActionAccessUpdate + ensureAllowed _ target conv self = do + -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and + -- so on; users are not supposed to be able to make other conversations + -- have 'PrivateAccessRole' + liftSem $ + when + ( PrivateAccess `elem` cupAccess target + || PrivateAccessRole == cupAccessRole target + ) + $ throw InvalidTargetAccess + -- Team conversations incur another round of checks + case convTeam conv of + Just _ -> do + -- Access mode change might result in members being removed from the + -- conversation, so the user must have the necessary permission flag + ensureActionAllowed RemoveConversationMember self + Nothing -> + liftSem $ + when (cupAccessRole target == TeamAccessRole) $ + throw InvalidTargetAccess + conversationActionTag' _ _ = ModifyConversationAccess + performAction qusr lcnv conv action = do + guard $ convAccessData conv /= action + -- Remove conversation codes if CodeAccess is revoked + when + ( CodeAccess `elem` convAccess conv + && CodeAccess `notElem` cupAccess action + ) + $ lift $ do + key <- mkKey (tUnqualified lcnv) + liftSem $ E.deleteCode key ReusableCode + + -- Determine bots and members to be removed + let filterBotsAndMembers = filterActivated >=> filterTeammates + let current = convBotsAndMembers conv -- initial bots and members + desired <- lift . liftSem $ filterBotsAndMembers current -- desired bots and members + let toRemove = bmDiff current desired -- bots and members to be removed + + -- Update Cassandra + lift . liftSem $ E.setConversationAccess (tUnqualified lcnv) action + lift . fireAndForget $ do + -- Remove bots + traverse_ (liftSem . E.deleteBot (tUnqualified lcnv) . botMemId) (bmBots toRemove) + + -- Update current bots and members + let current' = current {bmBots = bmBots desired} + + -- Remove users and notify everyone + void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do + let rAction = ConversationLeave usersToRemove + void . runMaybeT $ performAction qusr lcnv conv rAction + notifyConversationAction qusr Nothing lcnv current' (conversationAction rAction) + pure (mempty, action) + where + filterActivated :: Member BrigAccess r => BotsAndMembers -> Sem r BotsAndMembers + filterActivated bm + | convAccessRole conv > ActivatedAccessRole + && cupAccessRole action <= ActivatedAccessRole = do + activated <- map User.userId <$> E.lookupActivatedUsers (toList (bmLocals bm)) + -- FUTUREWORK: should we also remove non-activated remote users? + pure $ bm {bmLocals = Set.fromList activated} + | otherwise = pure bm + + filterTeammates :: Member TeamStore r => BotsAndMembers -> Sem r BotsAndMembers + filterTeammates bm = do + -- In a team-only conversation we also want to remove bots and guests + case (cupAccessRole action, convTeam conv) of + (TeamAccessRole, Just tid) -> do + onlyTeamUsers <- flip filterM (toList (bmLocals bm)) $ \user -> + isJust <$> E.getTeamMember tid user + pure $ + BotsAndMembers + { bmLocals = Set.fromList onlyTeamUsers, + bmBots = mempty, + bmRemotes = mempty + } + _ -> pure bm + +-- | Update a local conversation, and notify all local and remote members. +updateLocalConversation :: + ( IsConversationAction a, + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r, + HasConversationActionEffects a r + ) => + Local ConvId -> + Qualified UserId -> + Maybe ConnId -> + a -> + MaybeT (Galley r) Event +updateLocalConversation lcnv qusr con action = do + -- retrieve conversation + (conv, self) <- + lift $ + getConversationAndMemberWithError ConvNotFound qusr (tUnqualified lcnv) + + -- perform checks + lift $ ensureConversationActionAllowed lcnv action conv self + + -- perform action + (extraTargets, action') <- performAction qusr lcnv conv action + + -- send notifications to both local and remote users + lift $ + notifyConversationAction + qusr + con + lcnv + (convBotsAndMembers conv <> extraTargets) + (conversationAction action') + +-------------------------------------------------------------------------------- +-- Utilities + +ensureConversationActionAllowed :: + ( IsConvMember mem, + IsConversationAction a, + HasConversationActionEffects a r, + Members '[Error ActionError, Error InvalidInput] r + ) => + Local x -> + a -> + Conversation -> + mem -> + Galley r () +ensureConversationActionAllowed loc action conv self = do + let tag = conversationActionTag' (convMemberId loc self) action + -- general action check + ensureActionAllowed tag self + -- check if it is a group conversation (except for rename actions) + when (tag /= ModifyConversationName) $ + liftSem $ ensureGroupConversation conv + -- extra action-specific checks + ensureAllowed loc action conv self + +-- | Add users to a conversation without performing any checks. Return extra +-- notification targets and the action performed. +addMembersToLocalConversation :: + Members '[MemberStore] r => + Local ConvId -> + UserList UserId -> + RoleName -> + MaybeT (Galley r) (BotsAndMembers, ConversationJoin) +addMembersToLocalConversation lcnv users role = do + (lmems, rmems) <- lift . liftSem $ E.createMembers (tUnqualified lcnv) (fmap (,role) users) + neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users + let action = ConversationJoin neUsers role + pure (bmFromMembers lmems rmems, action) + +notifyConversationAction :: + Members '[FederatorAccess, ExternalAccess, GundeckAccess] r => + Qualified UserId -> + Maybe ConnId -> + Local ConvId -> + BotsAndMembers -> + ConversationAction -> + Galley r Event +notifyConversationAction quid con (qUntagged -> qcnv) targets action = do + localDomain <- viewFederationDomain + now <- liftIO getCurrentTime + let e = conversationActionToEvent now quid qcnv action + + -- notify remote participants + liftSem $ + E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> + F.onConversationUpdated F.clientRoutes localDomain $ + F.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action + + -- notify local participants and bots + pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index ee86e14933e..8c4b698bf38 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - module Galley.API.Create ( createGroupConversation, internalCreateManagedConversationH, @@ -25,7 +24,6 @@ module Galley.API.Create where import Control.Lens hiding ((??)) -import Control.Monad.Catch import Data.Id import Data.List1 (list1) import Data.Misc (FutureWork (FutureWork)) @@ -54,13 +52,15 @@ import Galley.Validation import Imports hiding ((\\)) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (setStatus) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, setStatus) +import Network.Wai.Utilities hiding (Error) +import Polysemy +import Polysemy.Error import Wire.API.Conversation hiding (Conversation, Member) import qualified Wire.API.Conversation as Public -import Wire.API.ErrorDescription (MissingLegalholdConsent) +import Wire.API.ErrorDescription import Wire.API.Event.Conversation hiding (Conversation) -import Wire.API.Federation.Error (federationNotImplemented) +import Wire.API.Federation.Client import Wire.API.Routes.Public.Galley (ConversationResponse) import Wire.API.Routes.Public.Util import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) @@ -75,6 +75,13 @@ createGroupConversation :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -96,6 +103,13 @@ internalCreateManagedConversationH :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -112,6 +126,13 @@ internalCreateManagedConversation :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -123,12 +144,11 @@ internalCreateManagedConversation :: NewConvManaged -> Galley r ConversationResponse internalCreateManagedConversation zusr zcon (NewConvManaged body) = do - case newConvTeam body of - Nothing -> throwM internalError - Just tinfo -> createTeamGroupConv zusr zcon tinfo body + tinfo <- liftSem $ note CannotCreateManagedConv (newConvTeam body) + createTeamGroupConv zusr zcon tinfo body ensureNoLegalholdConflicts :: - Members '[LegalHoldStore, TeamStore] r => + Members '[Error LegalHoldError, LegalHoldStore, TeamStore] r => [Remote UserId] -> [UserId] -> Galley r () @@ -136,7 +156,7 @@ ensureNoLegalholdConflicts remotes locals = do let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes whenM (anyLegalholdActivated locals) $ unlessM (allLegalholdConsentGiven locals) $ - throwErrorDescriptionType @MissingLegalholdConsent + liftSem $ throw MissingLegalholdConsent -- | A helper for creating a regular (non-team) group conversation. createRegularGroupConv :: @@ -144,6 +164,10 @@ createRegularGroupConv :: '[ ConversationStore, BrigAccess, FederatorAccess, + Error ActionError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, GundeckAccess, LegalHoldStore, TeamStore @@ -155,9 +179,10 @@ createRegularGroupConv :: Galley r ConversationResponse createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do lusr <- qualifyLocal zusr - name <- rangeCheckedMaybe (newConvName body) + name <- liftSem $ rangeCheckedMaybe (newConvName body) let allUsers = newConvMembers lusr body - checkedUsers <- checkedConvSize allUsers + o <- view options + checkedUsers <- liftSem $ checkedConvSize o allUsers ensureConnected lusr allUsers ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) c <- @@ -184,6 +209,13 @@ createTeamGroupConv :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -197,13 +229,14 @@ createTeamGroupConv :: Galley r ConversationResponse createTeamGroupConv zusr zcon tinfo body = do lusr <- qualifyLocal zusr - name <- rangeCheckedMaybe (newConvName body) + name <- liftSem $ rangeCheckedMaybe (newConvName body) let allUsers = newConvMembers lusr body convTeam = cnvTeamId tinfo zusrMembership <- liftSem $ E.getTeamMember convTeam zusr void $ permissionCheck CreateConversation zusrMembership - checkedUsers <- checkedConvSize allUsers + o <- view options + checkedUsers <- liftSem $ checkedConvSize o allUsers convLocalMemberships <- mapM (liftSem . E.getTeamMember convTeam) (ulLocals allUsers) ensureAccessRole (accessRole body) (zip (ulLocals allUsers) convLocalMemberships) -- In teams we don't have 1:1 conversations, only regular conversations. We want @@ -247,7 +280,7 @@ createTeamGroupConv zusr zcon tinfo body = do -- Other kinds of conversations createSelfConversation :: - Member ConversationStore r => + Members '[ConversationStore, Error InternalError] r => UserId -> Galley r ConversationResponse createSelfConversation zusr = do @@ -264,6 +297,13 @@ createOne2OneConversation :: Members '[ BrigAccess, ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InternalError, + Error InvalidInput, + Error NotATeamMember, + Error TeamError, FederatorAccess, GundeckAccess, TeamStore @@ -276,12 +316,12 @@ createOne2OneConversation :: createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do lusr <- qualifyLocal zusr let allUsers = newConvMembers lusr j - other <- ensureOne (ulAll lusr allUsers) - when (qUntagged lusr == other) $ - throwM (invalidOp "Cannot create a 1-1 with yourself") + other <- liftSem $ ensureOne (ulAll lusr allUsers) + liftSem . when (qUntagged lusr == other) $ + throw . InvalidOp $ One2OneConv mtid <- case newConvTeam j of Just ti - | cnvManaged ti -> throwM noManagedTeamConv + | cnvManaged ti -> liftSem $ throw NoManagedTeamConv | otherwise -> do foldQualified lusr @@ -289,7 +329,7 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do (const (pure Nothing)) other Nothing -> ensureConnected lusr allUsers $> Nothing - n <- rangeCheckedMaybe (newConvName j) + n <- liftSem $ rangeCheckedMaybe (newConvName j) foldQualified lusr (createLegacyOne2OneConversationUnchecked lusr zcon n mtid) @@ -299,8 +339,8 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do verifyMembership :: TeamId -> UserId -> Galley r () verifyMembership tid u = do membership <- liftSem $ E.getTeamMember tid u - when (isNothing membership) $ - throwM noBindingTeamMembers + liftSem . when (isNothing membership) $ + throw NoBindingTeamMembers checkBindingTeamPermissions :: Local UserId -> Local UserId -> @@ -314,11 +354,19 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do verifyMembership tid (tUnqualified lusr) verifyMembership tid (tUnqualified lother) pure (Just tid) - Just _ -> throwM nonBindingTeam - Nothing -> throwM teamNotFound + Just _ -> liftSem $ throw NotABindingTeamMember + Nothing -> liftSem $ throw TeamNotFound createLegacyOne2OneConversationUnchecked :: - Members '[ConversationStore, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + Error ActionError, + Error InternalError, + Error InvalidInput, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -337,7 +385,14 @@ createLegacyOne2OneConversationUnchecked self zcon name mtid other = do conversationCreated (tUnqualified self) c createOne2OneConversationUnchecked :: - Members '[ConversationStore, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + Error FederationError, + Error InternalError, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -353,7 +408,7 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId (qUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: - Members '[ConversationStore, FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, Error InternalError, FederatorAccess, GundeckAccess] r => Local ConvId -> Local UserId -> ConnId -> @@ -371,6 +426,7 @@ createOne2OneConversationLocally lcnv self zcon name mtid other = do conversationCreated (tUnqualified self) c createOne2OneConversationRemotely :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> @@ -379,10 +435,22 @@ createOne2OneConversationRemotely :: Qualified UserId -> Galley r ConversationResponse createOne2OneConversationRemotely _ _ _ _ _ _ = - throwM federationNotImplemented + liftSem $ + throw FederationNotImplemented createConnectConversation :: - Members '[ConversationStore, FederatorAccess, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InternalError, + Error InvalidInput, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> Maybe ConnId -> Connect -> @@ -396,15 +464,27 @@ createConnectConversation usr conn j = do (cRecipient j) createConnectConversationWithRemote :: + Member (Error FederationError) r => Local UserId -> Maybe ConnId -> Remote UserId -> Galley r ConversationResponse createConnectConversationWithRemote _ _ _ = - throwM federationNotImplemented + liftSem $ + throw FederationNotImplemented createLegacyConnectConversation :: - Members '[ConversationStore, FederatorAccess, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error InternalError, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => Local UserId -> Maybe ConnId -> Local UserId -> @@ -412,7 +492,7 @@ createLegacyConnectConversation :: Galley r ConversationResponse createLegacyConnectConversation lusr conn lrecipient j = do (x, y) <- toUUIDs (tUnqualified lusr) (tUnqualified lrecipient) - n <- rangeCheckedMaybe (cName j) + n <- liftSem $ rangeCheckedMaybe (cName j) conv <- liftSem $ E.getConversation (Data.localOne2OneConvId x y) maybe (create x y n) (update n) conv where @@ -474,10 +554,18 @@ createLegacyConnectConversation lusr conn lrecipient j = do ------------------------------------------------------------------------------- -- Helpers -conversationCreated :: UserId -> Data.Conversation -> Galley r ConversationResponse +conversationCreated :: + Member (Error InternalError) r => + UserId -> + Data.Conversation -> + Galley r ConversationResponse conversationCreated usr cnv = Created <$> conversationView usr cnv -conversationExisted :: UserId -> Data.Conversation -> Galley r ConversationResponse +conversationExisted :: + Member (Error InternalError) r => + UserId -> + Data.Conversation -> + Galley r ConversationResponse conversationExisted usr cnv = Existed <$> conversationView usr cnv handleConversationResponse :: ConversationResponse -> Response @@ -486,7 +574,7 @@ handleConversationResponse = \case Existed cnv -> json cnv & setStatus status200 . location (qUnqualified . cnvQualifiedId $ cnv) notifyCreatedConversation :: - Members '[FederatorAccess, GundeckAccess] r => + Members '[Error InternalError, FederatorAccess, GundeckAccess] r => Maybe UTCTime -> UserId -> Maybe ConnId -> @@ -517,15 +605,23 @@ notifyCreatedConversation dtime usr conn c = do & pushConn .~ conn & pushRoute .~ route -localOne2OneConvId :: Local UserId -> Local UserId -> Galley r (Local ConvId) +localOne2OneConvId :: + Member (Error InvalidInput) r => + Local UserId -> + Local UserId -> + Galley r (Local ConvId) localOne2OneConvId self other = do (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) pure . qualifyAs self $ Data.localOne2OneConvId x y -toUUIDs :: UserId -> UserId -> Galley r (U.UUID U.V4, U.UUID U.V4) +toUUIDs :: + Member (Error InvalidInput) r => + UserId -> + UserId -> + Galley r (U.UUID U.V4, U.UUID U.V4) toUUIDs a b = do - a' <- U.fromUUID (toUUID a) & ifNothing invalidUUID4 - b' <- U.fromUUID (toUUID b) & ifNothing invalidUUID4 + a' <- U.fromUUID (toUUID a) & note InvalidUUID4 & liftSem + b' <- U.fromUUID (toUUID b) & note InvalidUUID4 & liftSem return (a', b') accessRole :: NewConv -> AccessRole @@ -541,6 +637,6 @@ newConvMembers loc body = UserList (newConvUsers body) [] <> toUserList loc (newConvQualifiedUsers body) -ensureOne :: [a] -> Galley r a +ensureOne :: Member (Error InvalidInput) r => [a] -> Sem r a ensureOne [x] = pure x -ensureOne _ = throwM (invalidRange "One-to-one conversations can only have a single invited member") +ensureOne _ = throw (InvalidRange "One-to-one conversations can only have a single invited member") diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index 9630ca6b4cb..52cfd656b5d 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -22,7 +22,6 @@ module Galley.API.CustomBackend ) where -import Control.Monad.Catch import Data.Domain (Domain) import Galley.API.Error import Galley.API.Util @@ -32,27 +31,39 @@ import Galley.Types import Imports hiding ((\\)) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (setStatus) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, setStatus) +import Network.Wai.Utilities hiding (Error) import Polysemy +import Polysemy.Error import qualified Wire.API.CustomBackend as Public -- PUBLIC --------------------------------------------------------------------- -getCustomBackendByDomainH :: Member CustomBackendStore r => Domain ::: JSON -> Galley r Response +getCustomBackendByDomainH :: + Members + '[ CustomBackendStore, + Error CustomBackendError + ] + r => + Domain ::: JSON -> + Galley r Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain -getCustomBackendByDomain :: Member CustomBackendStore r => Domain -> Galley r Public.CustomBackend +getCustomBackendByDomain :: + Members '[CustomBackendStore, Error CustomBackendError] r => + Domain -> + Galley r Public.CustomBackend getCustomBackendByDomain domain = - liftSem (getCustomBackend domain) >>= \case - Nothing -> throwM (customBackendNotFound domain) - Just customBackend -> pure customBackend + liftSem $ + getCustomBackend domain >>= \case + Nothing -> throw (CustomBackendNotFound domain) + Just customBackend -> pure customBackend -- INTERNAL ------------------------------------------------------------------- internalPutCustomBackendByDomainH :: - Member CustomBackendStore r => + Members '[CustomBackendStore, Error InvalidInput] r => Domain ::: JsonRequest CustomBackend -> Galley r Response internalPutCustomBackendByDomainH (domain ::: req) = do diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 005b93f32f5..ab555dcff61 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -17,8 +17,8 @@ module Galley.API.Error where -import Control.Monad.Catch (MonadThrow (..)) import Data.Domain (Domain, domainText) +import Data.Id import Data.Proxy import Data.String.Conversions (cs) import Data.Text.Lazy as LT (pack) @@ -28,8 +28,249 @@ import Galley.Types.Teams (hardTruncationLimit) import Imports import Network.HTTP.Types.Status import Network.Wai.Utilities.Error +import Polysemy +import qualified Polysemy.Error as P +import Polysemy.Internal (Append) import Servant.API.Status (KnownStatus (..)) +import Wire.API.Conversation (ConvType (..)) +import Wire.API.Conversation.Role (Action) import Wire.API.ErrorDescription +import Wire.API.Federation.Client +import Wire.API.Federation.Error + +---------------------------------------------------------------------------- +-- Fine-grained API error types + +class APIError e where + toWai :: e -> Error + +data InternalError + = BadConvState ConvId + | BadMemberState + | NoPrekeyForUser + | CannotCreateManagedConv + | DeleteQueueFull + | InternalErrorWithDescription LText + +instance APIError InternalError where + toWai (BadConvState convId) = badConvState convId + toWai BadMemberState = mkError status500 "bad-state" "Bad internal member state." + toWai NoPrekeyForUser = internalError + toWai CannotCreateManagedConv = internalError + toWai DeleteQueueFull = deleteQueueFull + toWai (InternalErrorWithDescription t) = internalErrorWithDescription t + +data ActionError + = InvalidAction + | InvalidTargetAccess + | InvalidTargetUserOp + | ActionDenied Action + | AccessDenied + | InvalidOp ConvType + | OperationDenied String + | NotConnected + | NoAddToManaged + | BroadcastLimitExceeded + | InvalidTeamStatusUpdate + | InvalidPermissions + +instance APIError ActionError where + toWai InvalidAction = invalidActions + toWai InvalidTargetAccess = errorDescriptionTypeToWai @InvalidTargetAccess + toWai (ActionDenied action) = errorDescriptionToWai (actionDenied action) + toWai AccessDenied = accessDenied + toWai (InvalidOp RegularConv) = invalidOp "invalid operation" + toWai (InvalidOp SelfConv) = invalidSelfOp + toWai (InvalidOp One2OneConv) = invalidOne2OneOp + toWai (InvalidOp ConnectConv) = invalidConnectOp + toWai (OperationDenied p) = errorDescriptionToWai $ operationDeniedSpecialized p + toWai NotConnected = errorDescriptionTypeToWai @NotConnected + toWai InvalidTargetUserOp = invalidTargetUserOp + toWai NoAddToManaged = noAddToManaged + toWai BroadcastLimitExceeded = broadcastLimitExceeded + toWai InvalidTeamStatusUpdate = invalidTeamStatusUpdate + toWai InvalidPermissions = invalidPermissions + +data CustomBackendError = CustomBackendNotFound Domain + +instance APIError CustomBackendError where + toWai (CustomBackendNotFound d) = customBackendNotFound d + +data InvalidInput + = CustomRolesNotSupported + | InvalidRange LText + | InvalidUUID4 + | BulkGetMemberLimitExceeded + | InvalidPayload LText + +instance APIError InvalidInput where + toWai CustomRolesNotSupported = badRequest "Custom roles not supported" + toWai (InvalidRange t) = invalidRange t + toWai InvalidUUID4 = invalidUUID4 + toWai BulkGetMemberLimitExceeded = bulkGetMemberLimitExceeded + toWai (InvalidPayload t) = invalidPayload t + +data AuthenticationError + = ReAuthFailed + +instance APIError AuthenticationError where + toWai ReAuthFailed = reAuthFailed + +data ConversationError + = ConvAccessDenied + | ConvNotFound + | TooManyMembers + | ConvMemberNotFound + | NoBindingTeamMembers + | NoManagedTeamConv + +instance APIError ConversationError where + toWai ConvAccessDenied = errorDescriptionTypeToWai @ConvAccessDenied + toWai ConvNotFound = errorDescriptionTypeToWai @ConvNotFound + toWai TooManyMembers = tooManyMembers + toWai ConvMemberNotFound = errorDescriptionTypeToWai @ConvMemberNotFound + toWai NoBindingTeamMembers = noBindingTeamMembers + toWai NoManagedTeamConv = noManagedTeamConv + +data TeamError + = NoBindingTeam + | NoAddToBinding + | NotABindingTeamMember + | NotAOneMemberTeam + | TeamNotFound + | TeamMemberNotFound + | TeamSearchVisibilityNotEnabled + | UserBindingExists + | TooManyTeamMembers + | CannotEnableLegalHoldServiceLargeTeam + +instance APIError TeamError where + toWai NoBindingTeam = noBindingTeam + toWai NoAddToBinding = noAddToBinding + toWai NotABindingTeamMember = nonBindingTeam + toWai NotAOneMemberTeam = notAOneMemberTeam + toWai TeamNotFound = teamNotFound + toWai TeamMemberNotFound = teamMemberNotFound + toWai TeamSearchVisibilityNotEnabled = teamSearchVisibilityNotEnabled + toWai UserBindingExists = userBindingExists + toWai TooManyTeamMembers = tooManyTeamMembers + toWai CannotEnableLegalHoldServiceLargeTeam = cannotEnableLegalHoldServiceLargeTeam + +data TeamFeatureError + = AppLockinactivityTimeoutTooLow + | LegalHoldFeatureFlagNotEnabled + | LegalHoldWhitelistedOnly + | DisableSsoNotImplemented + +instance APIError TeamFeatureError where + toWai AppLockinactivityTimeoutTooLow = inactivityTimeoutTooLow + toWai LegalHoldFeatureFlagNotEnabled = legalHoldFeatureFlagNotEnabled + toWai LegalHoldWhitelistedOnly = legalHoldWhitelistedOnly + toWai DisableSsoNotImplemented = disableSsoNotImplemented + +data TeamNotificationError + = InvalidTeamNotificationId + +instance APIError TeamNotificationError where + toWai InvalidTeamNotificationId = invalidTeamNotificationId + +instance APIError FederationError where + toWai = federationErrorToWai + +data LegalHoldError + = MissingLegalholdConsent + | NoUserLegalHoldConsent + | LegalHoldNotEnabled + | LegalHoldDisableUnimplemented + | LegalHoldServiceInvalidKey + | LegalHoldServiceBadResponse + | UserLegalHoldAlreadyEnabled + | LegalHoldServiceNotRegistered + | LegalHoldCouldNotBlockConnections + | UserLegalHoldIllegalOperation + | TooManyTeamMembersOnTeamWithLegalhold + | NoLegalHoldDeviceAllocated + | UserLegalHoldNotPending + +instance APIError LegalHoldError where + toWai MissingLegalholdConsent = errorDescriptionTypeToWai @MissingLegalholdConsent + toWai NoUserLegalHoldConsent = userLegalHoldNoConsent + toWai LegalHoldNotEnabled = legalHoldNotEnabled + toWai LegalHoldDisableUnimplemented = legalHoldDisableUnimplemented + toWai LegalHoldServiceInvalidKey = legalHoldServiceInvalidKey + toWai LegalHoldServiceBadResponse = legalHoldServiceBadResponse + toWai UserLegalHoldAlreadyEnabled = userLegalHoldAlreadyEnabled + toWai LegalHoldServiceNotRegistered = legalHoldServiceNotRegistered + toWai LegalHoldCouldNotBlockConnections = legalHoldCouldNotBlockConnections + toWai UserLegalHoldIllegalOperation = userLegalHoldIllegalOperation + toWai TooManyTeamMembersOnTeamWithLegalhold = tooManyTeamMembersOnTeamWithLegalhold + toWai NoLegalHoldDeviceAllocated = noLegalHoldDeviceAllocated + toWai UserLegalHoldNotPending = userLegalHoldNotPending + +data CodeError = CodeNotFound + +instance APIError CodeError where + toWai CodeNotFound = errorDescriptionTypeToWai @CodeNotFound + +data ClientError = UnknownClient + +instance APIError ClientError where + toWai UnknownClient = errorDescriptionTypeToWai @UnknownClient + +throwED :: + ( e ~ ErrorDescription code label desc, + KnownSymbol desc, + Member (P.Error e) r + ) => + Sem r a +throwED = P.throw mkErrorDescription + +noteED :: + forall e code label desc r a. + ( e ~ ErrorDescription code label desc, + KnownSymbol desc, + Member (P.Error e) r + ) => + Maybe a -> + Sem r a +noteED = P.note (mkErrorDescription :: e) + +type AllErrorEffects = + '[ P.Error ActionError, + P.Error AuthenticationError, + P.Error ClientError, + P.Error CodeError, + P.Error ConversationError, + P.Error CustomBackendError, + P.Error FederationError, + P.Error InternalError, + P.Error InvalidInput, + P.Error LegalHoldError, + P.Error TeamError, + P.Error TeamFeatureError, + P.Error TeamNotificationError, + P.Error NotATeamMember + ] + +mapAllErrors :: Member (P.Error Error) r => Sem (Append AllErrorEffects r) a -> Sem r a +mapAllErrors = + P.mapError errorDescriptionToWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + +---------------------------------------------------------------------------- +-- Error description integration errorDescriptionToWai :: forall (code :: Nat) (lbl :: Symbol) (desc :: Symbol). @@ -49,22 +290,8 @@ errorDescriptionTypeToWai :: Error errorDescriptionTypeToWai = errorDescriptionToWai (mkErrorDescription :: e) -throwErrorDescription :: - (KnownStatus code, KnownSymbol lbl, MonadThrow m) => - ErrorDescription code lbl desc -> - m a -throwErrorDescription = throwM . errorDescriptionToWai - -throwErrorDescriptionType :: - forall e (code :: Nat) (lbl :: Symbol) (desc :: Symbol) m a. - ( KnownStatus code, - KnownSymbol lbl, - KnownSymbol desc, - MonadThrow m, - e ~ ErrorDescription code lbl desc - ) => - m a -throwErrorDescriptionType = throwErrorDescription (mkErrorDescription :: e) +---------------------------------------------------------------------------- +-- Other errors internalError :: Error internalError = internalErrorWithDescription "internal error" @@ -123,6 +350,12 @@ noBindingTeam = mkError status403 "no-binding-team" "Operation allowed only on b notAOneMemberTeam :: Error notAOneMemberTeam = mkError status403 "not-one-member-team" "Can only delete teams with a single member." +badConvState :: ConvId -> Error +badConvState cid = + mkError status500 "bad-state" $ + "Connect conversation with more than 2 members: " + <> LT.pack (show cid) + bulkGetMemberLimitExceeded :: Error bulkGetMemberLimitExceeded = mkError diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index a6ba85d5758..348bec3dec9 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -18,25 +18,23 @@ module Galley.API.Federation where import Brig.Types.Connection (Relation (Accepted)) import Control.Lens (itraversed, (<.>)) -import Control.Monad.Catch (throwM) import Control.Monad.Trans.Maybe (runMaybeT) import Data.ByteString.Conversion (toByteString') import Data.Containers.ListUtils (nubOrd) -import Data.Domain +import Data.Domain (Domain) import Data.Id (ConvId, UserId) import Data.Json.Util (Base64ByteString (..)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) import Data.Qualified -import Data.Range +import Data.Range (Range (fromRange)) import qualified Data.Set as Set import qualified Data.Text.Lazy as LT -import Galley.API.Error (invalidPayload) +import Galley.API.Action +import Galley.API.Error import qualified Galley.API.Mapping as Mapping -import Galley.API.Message (MessageMetadata (..), UserType (..), postQualifiedOtrMessage, sendLocalMessages) -import Galley.API.Update (notifyConversationMetadataUpdate) -import qualified Galley.API.Update as API +import Galley.API.Message import Galley.API.Util import Galley.App import qualified Galley.Data.Conversation as Data @@ -44,9 +42,10 @@ import Galley.Effects import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.MemberStore as E -import Galley.Types.Conversations.Members (LocalMember (..), defMemberStatus) -import Galley.Types.UserList +import Galley.Types.Conversations.Members +import Galley.Types.UserList (UserList (UserList)) import Imports +import Polysemy.Error (Error, throw) import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) @@ -56,52 +55,41 @@ import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember (..)) import qualified Wire.API.Conversation.Role as Public import Wire.API.Event.Conversation -import Wire.API.Federation.API.Common -import Wire.API.Federation.API.Galley - ( ConversationUpdate (..), - GetConversationsRequest (..), - GetConversationsResponse (..), - LeaveConversationRequest (..), - LeaveConversationResponse (..), - MessageSendRequest (..), - MessageSendResponse (..), - NewRemoteConversation (..), - RemoteMessage (..), - UserDeletedConversationsNotification, - ) -import qualified Wire.API.Federation.API.Galley as FederationAPIGalley +import Wire.API.Federation.API.Common (EmptyResponse (..)) +import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.Client import Wire.API.Routes.Internal.Brig.Connection -import Wire.API.Routes.Public.Galley.Responses (RemoveFromConversationError (..)) -import Wire.API.ServantProto (FromProto (..)) +import Wire.API.Routes.Public.Galley.Responses +import Wire.API.ServantProto import Wire.API.User.Client (userClientMap) -federationSitemap :: ServerT (ToServantApi FederationAPIGalley.Api) (Galley GalleyEffects) +federationSitemap :: ServerT (ToServantApi F.Api) (Galley GalleyEffects) federationSitemap = genericServerT $ - FederationAPIGalley.Api - { FederationAPIGalley.onConversationCreated = onConversationCreated, - FederationAPIGalley.getConversations = getConversations, - FederationAPIGalley.onConversationUpdated = onConversationUpdated, - FederationAPIGalley.leaveConversation = leaveConversation, - FederationAPIGalley.onMessageSent = onMessageSent, - FederationAPIGalley.sendMessage = sendMessage, - FederationAPIGalley.onUserDeleted = onUserDeleted + F.Api + { F.onConversationCreated = onConversationCreated, + F.getConversations = getConversations, + F.onConversationUpdated = onConversationUpdated, + F.leaveConversation = leaveConversation, + F.onMessageSent = onMessageSent, + F.sendMessage = sendMessage, + F.onUserDeleted = onUserDeleted } onConversationCreated :: Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> - NewRemoteConversation ConvId -> + F.NewRemoteConversation ConvId -> Galley r () onConversationCreated domain rc = do let qrc = fmap (toRemoteUnsafe domain) rc loc <- qualifyLocal () - let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (rcNonCreatorMembers rc))) + let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (F.rcNonCreatorMembers rc))) addedUserIds <- addLocalUsersToRemoteConv - (rcCnvId qrc) - (qUntagged (FederationAPIGalley.rcRemoteOrigUserId qrc)) + (F.rcCnvId qrc) + (qUntagged (F.rcRemoteOrigUserId qrc)) localUserIds let connectedMembers = @@ -112,30 +100,30 @@ onConversationCreated domain rc = do (const True) . omQualifiedId ) - (rcNonCreatorMembers rc) + (F.rcNonCreatorMembers rc) -- Make sure to notify only about local users connected to the adder - let qrcConnected = qrc {rcNonCreatorMembers = connectedMembers} + let qrcConnected = qrc {F.rcNonCreatorMembers = connectedMembers} forM_ (fromNewRemoteConversation loc qrcConnected) $ \(mem, c) -> do let event = Event ConvCreate - (qUntagged (rcCnvId qrcConnected)) - (qUntagged (FederationAPIGalley.rcRemoteOrigUserId qrcConnected)) - (rcTime qrcConnected) + (qUntagged (F.rcCnvId qrcConnected)) + (qUntagged (F.rcRemoteOrigUserId qrcConnected)) + (F.rcTime qrcConnected) (EdConversation c) pushConversationEvent Nothing event [qUnqualified . Public.memId $ mem] [] getConversations :: Member ConversationStore r => Domain -> - GetConversationsRequest -> - Galley r GetConversationsResponse -getConversations domain (GetConversationsRequest uid cids) = do + F.GetConversationsRequest -> + Galley r F.GetConversationsResponse +getConversations domain (F.GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid localDomain <- viewFederationDomain liftSem $ - GetConversationsResponse + F.GetConversationsResponse . mapMaybe (Mapping.conversationToRemote localDomain ruid) <$> E.getConversations cids @@ -147,12 +135,12 @@ getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomai onConversationUpdated :: Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> - ConversationUpdate -> + F.ConversationUpdate -> Galley r () onConversationUpdated requestingDomain cu = do localDomain <- viewFederationDomain loc <- qualifyLocal () - let rconvId = toRemoteUnsafe requestingDomain (cuConvId cu) + let rconvId = toRemoteUnsafe requestingDomain (F.cuConvId cu) qconvId = qUntagged rconvId -- Note: we generally do not send notifications to users that are not part of @@ -160,7 +148,7 @@ onConversationUpdated requestingDomain cu = do -- backend. See also the comment below. (presentUsers, allUsersArePresent) <- liftSem $ - E.selectRemoteMembers (cuAlreadyPresentUsers cu) rconvId + E.selectRemoteMembers (F.cuAlreadyPresentUsers cu) rconvId -- Perform action, and determine extra notification targets. -- @@ -170,10 +158,10 @@ onConversationUpdated requestingDomain cu = do -- are not in the conversations are being removed or have their membership state -- updated, we do **not** add them to the list of targets, because we have no -- way to make sure that they are actually supposed to receive that notification. - (mActualAction, extraTargets) <- case cuAction cu of + (mActualAction, extraTargets) <- case F.cuAction cu of ConversationActionAddMembers toAdd role -> do let (localUsers, remoteUsers) = partitionQualified loc toAdd - addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId (cuOrigUserId cu) localUsers + addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId (F.cuOrigUserId cu) localUsers let allAddedUsers = map (qUntagged . qualifyAs loc) addedLocalUsers <> map qUntagged remoteUsers case allAddedUsers of [] -> pure (Nothing, []) -- If no users get added, its like no action was performed. @@ -181,19 +169,19 @@ onConversationUpdated requestingDomain cu = do ConversationActionRemoveMembers toRemove -> liftSem $ do let localUsers = getLocalUsers localDomain toRemove E.deleteMembersInRemoteConversation rconvId localUsers - pure (Just $ cuAction cu, []) - ConversationActionRename _ -> pure (Just $ cuAction cu, []) - ConversationActionMessageTimerUpdate _ -> pure (Just $ cuAction cu, []) - ConversationActionMemberUpdate _ _ -> pure (Just $ cuAction cu, []) - ConversationActionReceiptModeUpdate _ -> pure (Just $ cuAction cu, []) - ConversationActionAccessUpdate _ -> pure (Just $ cuAction cu, []) + pure (Just $ F.cuAction cu, []) + ConversationActionRename _ -> pure (Just $ F.cuAction cu, []) + ConversationActionMessageTimerUpdate _ -> pure (Just $ F.cuAction cu, []) + ConversationActionMemberUpdate _ _ -> pure (Just $ F.cuAction cu, []) + ConversationActionReceiptModeUpdate _ -> pure (Just $ F.cuAction cu, []) + ConversationActionAccessUpdate _ -> pure (Just $ F.cuAction cu, []) ConversationActionDelete -> liftSem $ do E.deleteMembersInRemoteConversation rconvId presentUsers - pure (Just $ cuAction cu, []) + pure (Just $ F.cuAction cu, []) unless allUsersArePresent $ Log.warn $ - Log.field "conversation" (toByteString' (cuConvId cu)) + Log.field "conversation" (toByteString' (F.cuConvId cu)) . Log.field "domain" (toByteString' requestingDomain) . Log.msg ( "Attempt to send notification about conversation update \ @@ -203,7 +191,7 @@ onConversationUpdated requestingDomain cu = do -- Send notifications for_ mActualAction $ \action -> do - let event = conversationActionToEvent (cuTime cu) (cuOrigUserId cu) qconvId action + let event = conversationActionToEvent (F.cuTime cu) (F.cuOrigUserId cu) qconvId action targets = nubOrd $ presentUsers <> extraTargets -- FUTUREWORK: support bots? @@ -242,6 +230,11 @@ leaveConversation :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -252,19 +245,19 @@ leaveConversation :: ] r => Domain -> - LeaveConversationRequest -> - Galley r LeaveConversationResponse + F.LeaveConversationRequest -> + Galley r F.LeaveConversationResponse leaveConversation requestingDomain lc = do - let leaver = Qualified (lcLeaver lc) requestingDomain - lcnv <- qualifyLocal (lcConvId lc) + let leaver = Qualified (F.lcLeaver lc) requestingDomain + lcnv <- qualifyLocal (F.lcConvId lc) fmap - ( LeaveConversationResponse + ( F.LeaveConversationResponse . maybe (Left RemoveFromConversationErrorUnchanged) Right ) . runMaybeT . void - . API.updateLocalConversation lcnv leaver Nothing - . ConversationActionRemoveMembers + . updateLocalConversation lcnv leaver Nothing + . ConversationLeave . pure $ leaver @@ -273,23 +266,23 @@ leaveConversation requestingDomain lc = do onMessageSent :: Members '[BotAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> - RemoteMessage ConvId -> + F.RemoteMessage ConvId -> Galley r () onMessageSent domain rmUnqualified = do let rm = fmap (toRemoteUnsafe domain) rmUnqualified - convId = qUntagged $ rmConversation rm + convId = qUntagged $ F.rmConversation rm msgMetadata = MessageMetadata - { mmNativePush = rmPush rm, - mmTransient = rmTransient rm, - mmNativePriority = rmPriority rm, - mmData = rmData rm + { mmNativePush = F.rmPush rm, + mmTransient = F.rmTransient rm, + mmNativePriority = F.rmPriority rm, + mmData = F.rmData rm } - recipientMap = userClientMap $ rmRecipients rm + recipientMap = userClientMap $ F.rmRecipients rm msgs = toMapOf (itraversed <.> itraversed) recipientMap (members, allMembers) <- liftSem $ - E.selectRemoteMembers (Map.keys recipientMap) (rmConversation rm) + E.selectRemoteMembers (Map.keys recipientMap) (F.rmConversation rm) unless allMembers $ Log.warn $ Log.field "conversation" (toByteString' (qUnqualified convId)) @@ -300,7 +293,16 @@ onMessageSent domain rmUnqualified = do ByteString ) localMembers <- sequence $ Map.fromSet mkLocalMember (Set.fromList members) - void $ sendLocalMessages (rmTime rm) (rmSender rm) (rmSenderClient rm) Nothing convId localMembers msgMetadata msgs + void $ + sendLocalMessages + (F.rmTime rm) + (F.rmSender rm) + (F.rmSenderClient rm) + Nothing + convId + localMembers + msgMetadata + msgs where -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-875 mkLocalMember :: UserId -> Galley r LocalMember @@ -319,6 +321,7 @@ sendMessage :: BrigAccess, ClientStore, ConversationStore, + Error InvalidInput, FederatorAccess, GundeckAccess, ExternalAccess, @@ -327,14 +330,14 @@ sendMessage :: ] r => Domain -> - MessageSendRequest -> - Galley r MessageSendResponse + F.MessageSendRequest -> + Galley r F.MessageSendResponse sendMessage originDomain msr = do - let sender = Qualified (msrSender msr) originDomain - msg <- either err pure (fromProto (fromBase64ByteString (msrRawMessage msr))) - MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing (msrConvId msr) msg + let sender = Qualified (F.msrSender msr) originDomain + msg <- either err pure (fromProto (fromBase64ByteString (F.msrRawMessage msr))) + F.MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing (F.msrConvId msr) msg where - err = throwM . invalidPayload . LT.pack + err = liftSem . throw . InvalidPayload . LT.pack onUserDeleted :: Members @@ -347,12 +350,12 @@ onUserDeleted :: ] r => Domain -> - UserDeletedConversationsNotification -> + F.UserDeletedConversationsNotification -> Galley r EmptyResponse onUserDeleted origDomain udcn = do - let deletedUser = toRemoteUnsafe origDomain (FederationAPIGalley.udcnUser udcn) + let deletedUser = toRemoteUnsafe origDomain (F.udcnUser udcn) untaggedDeletedUser = qUntagged deletedUser - convIds = FederationAPIGalley.udcnConversations udcn + convIds = F.udcnConversations udcn spawnMany $ fromRange convIds <&> \c -> do @@ -374,5 +377,5 @@ onUserDeleted origDomain udcn = do let action = ConversationActionRemoveMembers (pure untaggedDeletedUser) botsAndMembers = convBotsAndMembers conv - void $ notifyConversationMetadataUpdate untaggedDeletedUser Nothing lc botsAndMembers action + void $ notifyConversationAction untaggedDeletedUser Nothing lc botsAndMembers action pure EmptyResponse diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index bb7ce82c268..3ca5ceaafb1 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -38,7 +38,7 @@ import GHC.TypeLits (AppendSymbol) import qualified Galley.API.Clients as Clients import qualified Galley.API.Create as Create import qualified Galley.API.CustomBackend as CustomBackend -import Galley.API.Error (throwErrorDescriptionType) +import Galley.API.Error import Galley.API.LegalHold (getTeamLegalholdWhitelistedH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) import qualified Galley.API.One2One as One2One @@ -73,11 +73,12 @@ import Galley.Types.UserList import Imports hiding (head) import Network.HTTP.Types (status200) import Network.Wai -import Network.Wai.Predicate hiding (err) +import Network.Wai.Predicate hiding (Error, err) import qualified Network.Wai.Predicate as P import Network.Wai.Routing hiding (route, toList) -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) import Network.Wai.Utilities.ZAuth +import Polysemy.Error import Servant.API hiding (JSON) import qualified Servant.API as Servant import Servant.API.Generic @@ -87,7 +88,7 @@ import System.Logger.Class hiding (Path, name) import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvIdsPage, pattern GetPaginatedConversationIds) import Wire.API.Conversation.Action (ConversationAction (ConversationActionRemoveMembers)) -import Wire.API.ErrorDescription (MissingLegalholdConsent) +import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley (ConversationUpdate (..), UserDeletedConversationsNotification (UserDeletedConversationsNotification)) import qualified Wire.API.Federation.API.Galley as FedGalley import Wire.API.Federation.Client (FederationError) @@ -303,7 +304,15 @@ servantSitemap = iGetTeamFeature :: forall a r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error NotATeamMember, + Error TeamError, + TeamStore + ] + r + ) => (Features.GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Galley r (Public.TeamFeatureStatus a) @@ -311,7 +320,15 @@ iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: forall a r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error NotATeamMember, + Error TeamError, + TeamStore + ] + r + ) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Public.TeamFeatureStatus a -> @@ -629,11 +646,17 @@ safeForever funName action = threadDelay 60000000 -- pause to keep worst-case noise in logs manageable guardLegalholdPolicyConflictsH :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error LegalHoldError, + Error InvalidInput, + TeamStore + ] + r => (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> Galley r Response guardLegalholdPolicyConflictsH (req ::: _) = do glh <- fromJsonBody req guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) - >>= either (const (throwErrorDescriptionType @MissingLegalholdConsent)) pure + >>= either (const (liftSem (throw MissingLegalholdConsent))) pure pure $ Network.Wai.Utilities.setStatus status200 empty diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 0a6015259e7..998ea8ed751 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -38,7 +38,6 @@ import Brig.Types.Provider import Brig.Types.Team.LegalHold hiding (userId) import Control.Exception (assert) import Control.Lens (view, (^.)) -import Control.Monad.Catch import Data.ByteString.Conversion (toByteString, toByteString') import Data.Id import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) @@ -69,20 +68,31 @@ import Imports import Network.HTTP.Types (status200, status404) import Network.HTTP.Types.Status (status201, status204) import Network.Wai -import Network.Wai.Predicate hiding (or, result, setStatus, _3) -import Network.Wai.Utilities as Wai +import Network.Wai.Predicate hiding (Error, or, result, setStatus, _3) +import Network.Wai.Utilities as Wai hiding (Error) +import Polysemy.Error import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) +import Wire.API.ErrorDescription +import Wire.API.Federation.Client import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Team.Feature as Public import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import qualified Wire.API.Team.LegalHold as Public -assertLegalHoldEnabledForTeam :: Members '[LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r () -assertLegalHoldEnabledForTeam tid = unlessM (isLegalHoldEnabledForTeam tid) $ throwM legalHoldNotEnabled +assertLegalHoldEnabledForTeam :: + Members '[Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamFeatureStore] r => + TeamId -> + Galley r () +assertLegalHoldEnabledForTeam tid = + unlessM (isLegalHoldEnabledForTeam tid) $ + liftSem $ throw LegalHoldNotEnabled -isLegalHoldEnabledForTeam :: Members '[LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r Bool +isLegalHoldEnabledForTeam :: + Members '[LegalHoldStore, TeamFeatureStore] r => + TeamId -> + Galley r Bool isLegalHoldEnabledForTeam tid = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> do @@ -99,7 +109,17 @@ isLegalHoldEnabledForTeam tid = do liftSem $ LegalHoldData.isTeamLegalholdWhitelisted tid createSettingsH :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley r Response createSettingsH (zusr ::: tid ::: req ::: _) = do @@ -107,7 +127,17 @@ createSettingsH (zusr ::: tid ::: req ::: _) = do setStatus status201 . json <$> createSettings zusr tid newService createSettings :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> TeamId -> Public.NewLegalHoldService -> @@ -122,21 +152,39 @@ createSettings zusr tid newService = do void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership (key :: ServiceKey, fpr :: Fingerprint Rsa) <- LHService.validateServiceKey (newLegalHoldServiceKey newService) - >>= maybe (throwM legalHoldServiceInvalidKey) pure + >>= liftSem . note LegalHoldServiceInvalidKey LHService.checkLegalHoldServiceStatus fpr (newLegalHoldServiceUrl newService) let service = legalHoldService tid fpr newService key liftSem $ LegalHoldData.createSettings service pure . viewLegalHoldService $ service getSettingsH :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId ::: TeamId ::: JSON -> Galley r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid getSettings :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> TeamId -> Galley r Public.ViewLegalHoldService @@ -156,6 +204,14 @@ removeSettingsH :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -183,6 +239,14 @@ removeSettings :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -212,13 +276,13 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do ensureReAuthorised zusr mPassword removeSettings' tid where - assertNotWhitelisting :: Galley r () + assertNotWhitelisting :: Member (Error LegalHoldError) r => Galley r () assertNotWhitelisting = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure () FeatureLegalHoldDisabledByDefault -> pure () FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do - throwM legalHoldDisableUnimplemented + liftSem $ throw LegalHoldDisableUnimplemented -- | Remove legal hold settings from team; also disabling for all users and removing LH devices removeSettings' :: @@ -230,6 +294,14 @@ removeSettings' :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -267,7 +339,7 @@ removeSettings' tid = -- | Learn whether a user has LH enabled and fetch pre-keys. -- Note that this is accessible to ANY authenticated user, even ones outside the team getUserStatusH :: - Members '[LegalHoldStore, TeamStore] r => + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do @@ -275,13 +347,12 @@ getUserStatusH (_zusr ::: tid ::: uid ::: _) = do getUserStatus :: forall r. - Members '[LegalHoldStore, TeamStore] r => + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => TeamId -> UserId -> Galley r Public.UserLegalHoldStatusResponse getUserStatus tid uid = do - mTeamMember <- liftSem $ getTeamMember tid uid - teamMember <- maybe (throwM teamMemberNotFound) pure mTeamMember + teamMember <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid let status = view legalHoldStatus teamMember (mlk, lcid) <- case status of UserLegalHoldNoConsent -> pure (Nothing, Nothing) @@ -299,7 +370,7 @@ getUserStatus tid uid = do "expected to find a prekey for user: " <> toByteString' uid <> " but none was found" - throwM internalError + liftSem $ throw NoPrekeyForUser Just lstKey -> pure lstKey let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey pure (Just lastKey, Just clientId) @@ -313,6 +384,13 @@ grantConsentH :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -340,6 +418,13 @@ grantConsent :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -356,15 +441,14 @@ grantConsent :: grantConsent zusr tid = do userLHStatus <- liftSem $ - fmap (view legalHoldStatus) <$> getTeamMember tid zusr + note TeamMemberNotFound + =<< fmap (view legalHoldStatus) <$> getTeamMember tid zusr case userLHStatus of - Nothing -> - throwM teamMemberNotFound - Just lhs@UserLegalHoldNoConsent -> + lhs@UserLegalHoldNoConsent -> changeLegalholdStatus tid zusr lhs UserLegalHoldDisabled $> GrantConsentSuccess - Just UserLegalHoldEnabled -> pure GrantConsentAlreadyGranted - Just UserLegalHoldPending -> pure GrantConsentAlreadyGranted - Just UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted + UserLegalHoldEnabled -> pure GrantConsentAlreadyGranted + UserLegalHoldPending -> pure GrantConsentAlreadyGranted + UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted -- | Request to provision a device on the legal hold service for a user requestDeviceH :: @@ -373,6 +457,13 @@ requestDeviceH :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -402,6 +493,13 @@ requestDevice :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -424,12 +522,12 @@ requestDevice zusr tid uid = do . Log.field "action" (Log.val "LegalHold.requestDevice") zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership - member <- maybe (throwM teamMemberNotFound) pure =<< liftSem (getTeamMember tid uid) + member <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid case member ^. legalHoldStatus of - UserLegalHoldEnabled -> throwM userLegalHoldAlreadyEnabled + UserLegalHoldEnabled -> liftSem $ throw UserLegalHoldAlreadyEnabled lhs@UserLegalHoldPending -> RequestDeviceAlreadyPending <$ provisionLHDevice lhs lhs@UserLegalHoldDisabled -> RequestDeviceSuccess <$ provisionLHDevice lhs - UserLegalHoldNoConsent -> throwM userLegalHoldNoConsent + UserLegalHoldNoConsent -> liftSem $ throw NoUserLegalHoldConsent where -- Wire's LH service that galley is usually calling here is idempotent in device creation, -- ie. it returns the existing device on multiple calls to `/init`, like here: @@ -464,6 +562,14 @@ approveDeviceH :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -488,6 +594,14 @@ approveDevice :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -510,7 +624,7 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo Log.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "LegalHold.approveDevice") - unless (zusr == uid) (throwM accessDenied) + liftSem . unless (zusr == uid) $ throw AccessDenied assertOnTeam uid tid ensureReAuthorised zusr mPassword userLHStatus <- @@ -521,7 +635,7 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo (prekeys, lastPrekey') <- case mPreKeys of Nothing -> do Log.info $ Log.msg @Text "No prekeys found" - throwM noLegalHoldDeviceAllocated + liftSem $ throw NoLegalHoldDeviceAllocated Just keys -> pure keys clientId <- liftSem $ addLegalHoldClientToUser uid connId prekeys lastPrekey' -- Note: teamId could be passed in the getLegalHoldAuthToken request instead of lookup up again @@ -535,13 +649,13 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) changeLegalholdStatus tid uid userLHStatus UserLegalHoldEnabled where - assertUserLHPending :: UserLegalHoldStatus -> Galley r () - assertUserLHPending userLHStatus = do + assertUserLHPending :: Member (Error LegalHoldError) r => UserLegalHoldStatus -> Galley r () + assertUserLHPending userLHStatus = liftSem $ do case userLHStatus of - UserLegalHoldEnabled -> throwM userLegalHoldAlreadyEnabled + UserLegalHoldEnabled -> throw UserLegalHoldAlreadyEnabled UserLegalHoldPending -> pure () - UserLegalHoldDisabled -> throwM userLegalHoldNotPending - UserLegalHoldNoConsent -> throwM userLegalHoldNotPending + UserLegalHoldDisabled -> throw UserLegalHoldNotPending + UserLegalHoldNoConsent -> throw UserLegalHoldNotPending disableForUserH :: Members @@ -549,6 +663,14 @@ disableForUserH :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -578,6 +700,14 @@ disableForUser :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -626,6 +756,13 @@ changeLegalholdStatus :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -673,12 +810,12 @@ changeLegalholdStatus tid uid old new = do blockNonConsentingConnections uid handleGroupConvPolicyConflicts uid new noop = pure () - illegal = throwM userLegalHoldIllegalOperation + illegal = liftSem $ throw UserLegalHoldIllegalOperation -- FUTUREWORK: make this async? blockNonConsentingConnections :: forall r. - Members '[BrigAccess, LegalHoldStore, TeamStore] r => + Members '[BrigAccess, Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamStore] r => UserId -> Galley r () blockNonConsentingConnections uid = do @@ -690,7 +827,7 @@ blockNonConsentingConnections uid = do [] -> pure () msgs@(_ : _) -> do Log.warn $ Log.msg @String msgs - throwM legalHoldCouldNotBlockConnections + liftSem $ throw LegalHoldCouldNotBlockConnections where findConflicts :: [ConnectionStatus] -> Galley r [[UserId]] findConflicts conns = do @@ -757,6 +894,11 @@ handleGroupConvPolicyConflicts :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index e7ce9a86671..3d193b2f6c8 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -26,27 +26,32 @@ module Galley.API.Mapping ) where -import Control.Monad.Catch import Data.Domain (Domain) import Data.Id (UserId, idToText) import Data.Qualified +import Galley.API.Error import Galley.API.Util (qualifyLocal) import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Data.Types (convId) import Galley.Types.Conversations.Members import Imports -import Network.HTTP.Types.Status -import Network.Wai.Utilities.Error +import Polysemy +import Polysemy.Error import qualified System.Logger.Class as Log import System.Logger.Message (msg, val, (+++)) -import Wire.API.Conversation +import Wire.API.Conversation hiding (Member (..)) +import qualified Wire.API.Conversation as Conversation import Wire.API.Federation.API.Galley -- | View for a given user of a stored conversation. -- -- Throws "bad-state" when the user is not part of the conversation. -conversationView :: UserId -> Data.Conversation -> Galley r Conversation +conversationView :: + Member (Error InternalError) r => + UserId -> + Data.Conversation -> + Galley r Conversation conversationView uid conv = do luid <- qualifyLocal uid let mbConv = conversationViewMaybe luid conv @@ -58,8 +63,7 @@ conversationView uid conv = do +++ idToText uid +++ val " is not a member of conv " +++ idToText (convId conv) - throwM badState - badState = mkError status500 "bad-state" "Bad internal member state." + liftSem $ throw BadMemberState -- | View for a given user of a stored conversation. -- @@ -131,9 +135,9 @@ conversationToRemote localDomain ruid conv = do -- | Convert a local conversation member (as stored in the DB) to a publicly -- facing 'Member' structure. -localMemberToSelf :: Local x -> LocalMember -> Member +localMemberToSelf :: Local x -> LocalMember -> Conversation.Member localMemberToSelf loc lm = - Member + Conversation.Member { memId = qUntagged . qualifyAs loc . lmId $ lm, memService = lmService lm, memOtrMutedStatus = msOtrMutedStatus st, diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index d395b1e4246..e8983fc1ff3 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -35,7 +35,6 @@ where import qualified Cassandra as C import Control.Lens (sequenceAOf) -import Control.Monad.Catch (throwM) import Control.Monad.Trans.Except import qualified Data.ByteString.Lazy as LBS import Data.Code @@ -63,37 +62,36 @@ import Galley.Types.Conversations.Roles import Imports import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (result, setStatus) -import Network.Wai.Utilities -import qualified Network.Wai.Utilities.Error as Wai +import Network.Wai.Predicate hiding (Error, result, setStatus) +import Network.Wai.Utilities hiding (Error) import Polysemy +import Polysemy.Error import qualified System.Logger.Class as Logger import UnliftIO (pooledForConcurrentlyN) import Wire.API.Conversation (ConversationCoverView (..)) import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Role as Public -import Wire.API.ErrorDescription (ConvNotFound) +import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley (gcresConvs) import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (FederationError, executeFederated) -import Wire.API.Federation.Error +import Wire.API.Federation.Client (FederationError (FederationUnexpectedBody), executeFederated) import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public getBotConversationH :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError] r => BotId ::: ConvId ::: JSON -> Galley r Response getBotConversationH (zbot ::: zcnv ::: _) = do json <$> getBotConversation zbot zcnv getBotConversation :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError] r => BotId -> ConvId -> Galley r Public.BotConvView getBotConversation zbot zcnv = do - (c, _) <- getConversationAndMemberWithError (errorDescriptionTypeToWai @ConvNotFound) (botUserId zbot) zcnv + (c, _) <- getConversationAndMemberWithError ConvNotFound (botUserId zbot) zcnv domain <- viewFederationDomain let cmems = mapMaybe (mkMember domain) (toList (Data.convLocalMembers c)) pure $ Public.botConvView zcnv (Data.convName c) cmems @@ -106,7 +104,7 @@ getBotConversation zbot zcnv = do Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) getUnqualifiedConversation :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError, Error InternalError] r => UserId -> ConvId -> Galley r Public.Conversation @@ -116,7 +114,13 @@ getUnqualifiedConversation zusr cnv = do getConversation :: forall r. - Member ConversationStore r => + Members + '[ ConversationStore, + Error ConversationError, + Error FederationError, + Error InternalError + ] + r => UserId -> Qualified ConvId -> Galley r Public.Conversation @@ -131,37 +135,40 @@ getConversation zusr cnv = do getRemoteConversation :: Remote ConvId -> Galley r Public.Conversation getRemoteConversation remoteConvId = do conversations <- getRemoteConversations zusr [remoteConvId] - case conversations of - [] -> throwErrorDescriptionType @ConvNotFound + liftSem $ case conversations of + [] -> throw ConvNotFound [conv] -> pure conv - _convs -> throwM (federationUnexpectedBody "expected one conversation, got multiple") + -- _convs -> throw (federationUnexpectedBody "expected one conversation, got multiple") + _convs -> throw $ FederationUnexpectedBody "expected one conversation, got multiple" getRemoteConversations :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError, Error FederationError] r => UserId -> [Remote ConvId] -> Galley r [Public.Conversation] getRemoteConversations zusr remoteConvs = getRemoteConversationsWithFailures zusr remoteConvs >>= \case -- throw first error - (failed : _, _) -> throwM (fgcError failed) + (failed : _, _) -> liftSem . throwFgcError $ failed ([], result) -> pure result data FailedGetConversationReason = FailedGetConversationLocally | FailedGetConversationRemotely FederationError -fgcrError :: FailedGetConversationReason -> Wai.Error -fgcrError FailedGetConversationLocally = errorDescriptionTypeToWai @ConvNotFound -fgcrError (FailedGetConversationRemotely e) = federationErrorToWai e +throwFgcrError :: + Members '[Error ConversationError, Error FederationError] r => FailedGetConversationReason -> Sem r a +throwFgcrError FailedGetConversationLocally = throw ConvNotFound +throwFgcrError (FailedGetConversationRemotely e) = throw e data FailedGetConversation = FailedGetConversation [Qualified ConvId] FailedGetConversationReason -fgcError :: FailedGetConversation -> Wai.Error -fgcError (FailedGetConversation _ r) = fgcrError r +throwFgcError :: + Members '[Error ConversationError, Error FederationError] r => FailedGetConversation -> Sem r a +throwFgcError (FailedGetConversation _ r) = throwFgcrError r failedGetConversationRemotely :: [Remote ConvId] -> FederationError -> FailedGetConversation @@ -231,7 +238,7 @@ getRemoteConversationsWithFailures zusr convs = do throwE e getConversationRoles :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError] r => UserId -> ConvId -> Galley r Public.ConversationRolesList @@ -299,7 +306,6 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do pure $ remotePage {Public.mtpResults = Public.mtpResults localPage <> Public.mtpResults remotePage} remotesOnly :: - Members '[ListItems p (Remote ConvId)] r => Maybe C.PagingState -> Range 1 1000 Int32 -> Sem r Public.ConvIdsPage @@ -317,7 +323,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do } getConversations :: - Members '[ListItems LegacyPaging ConvId, ConversationStore] r => + Members '[Error InternalError, ListItems LegacyPaging ConvId, ConversationStore] r => UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> @@ -369,7 +375,7 @@ getConversationsInternal user mids mstart msize = do | otherwise = pure True listConversations :: - Member ConversationStore r => + Members '[ConversationStore, Error InternalError] r => UserId -> Public.ListConversations -> Galley r Public.ConversationsResponse @@ -485,7 +491,18 @@ getConversationMeta cnv = liftSem $ do pure Nothing getConversationByReusableCode :: - Members '[CodeStore, ConversationStore, BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error CodeError, + Error ConversationError, + Error FederationError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> Key -> Value -> diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 0b58052ecc5..f73b5e2ebe2 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -60,7 +60,6 @@ where import Brig.Types.Intra (accountUser) import Brig.Types.Team (TeamSize (..)) import Control.Lens -import Control.Monad.Catch import Data.ByteString.Conversion (List, toByteString) import qualified Data.ByteString.Conversion import Data.ByteString.Lazy.Builder (lazyByteString) @@ -118,13 +117,15 @@ import Galley.Types.UserList import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (or, result, setStatus) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, or, result, setStatus) +import Network.Wai.Utilities hiding (Error) import Polysemy +import Polysemy.Error import qualified SAML2.WebSSO as SAML import qualified System.Logger.Class as Log import qualified Wire.API.Conversation.Role as Public -import Wire.API.ErrorDescription (ConvNotFound, NotATeamMember, operationDenied) +import Wire.API.ErrorDescription +import Wire.API.Federation.Client import qualified Wire.API.Notification as Public import qualified Wire.API.Team as Public import qualified Wire.API.Team.Conversation as Public @@ -138,17 +139,28 @@ import qualified Wire.API.User as U import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) -getTeamH :: Member TeamStore r => UserId ::: TeamId ::: JSON -> Galley r Response +getTeamH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + UserId ::: TeamId ::: JSON -> + Galley r Response getTeamH (zusr ::: tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< lookupTeam zusr tid + maybe (liftSem (throw TeamNotFound)) (pure . json) =<< lookupTeam zusr tid -getTeamInternalH :: Member TeamStore r => TeamId ::: JSON -> Galley r Response +getTeamInternalH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId ::: JSON -> + Galley r Response getTeamInternalH (tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< liftSem (E.getTeam tid) + liftSem . fmap json $ + E.getTeam tid >>= note TeamNotFound -getTeamNameInternalH :: Member TeamStore r => TeamId ::: JSON -> Galley r Response +getTeamNameInternalH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId ::: JSON -> + Galley r Response getTeamNameInternalH (tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< liftSem (getTeamNameInternal tid) + liftSem . fmap json $ + getTeamNameInternal tid >>= note TeamNotFound getTeamNameInternal :: Member TeamStore r => TeamId -> Sem r (Maybe TeamName) getTeamNameInternal = fmap (fmap TeamName) . E.getTeamName @@ -184,7 +196,16 @@ lookupTeam zusr tid = do else pure Nothing createNonBindingTeamH :: - Members '[GundeckAccess, BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> Galley r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do @@ -193,7 +214,15 @@ createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do pure (empty & setStatus status201 . location newTeamId) createNonBindingTeam :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> Public.NonBindingNewTeam -> @@ -223,7 +252,7 @@ createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do pure (team ^. teamId) createBindingTeamH :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members '[BrigAccess, Error InvalidInput, GundeckAccess, TeamStore] r => UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley r Response createBindingTeamH (zusr ::: tid ::: req ::: _) = do @@ -246,7 +275,15 @@ createBindingTeam zusr tid (BindingNewTeam body) = do pure tid updateTeamStatusH :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley r Response updateTeamStatusH (tid ::: req ::: _) = do @@ -254,9 +291,13 @@ updateTeamStatusH (tid ::: req ::: _) = do updateTeamStatus tid teamStatusUpdate return empty -updateTeamStatus :: Members '[BrigAccess, TeamStore] r => TeamId -> TeamStatusUpdate -> Galley r () +updateTeamStatus :: + Members '[BrigAccess, Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId -> + TeamStatusUpdate -> + Galley r () updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do - oldStatus <- tdStatus <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) + oldStatus <- tdStatus <$> liftSem (E.getTeam tid >>= note TeamNotFound) valid <- validateTransition (oldStatus, newStatus) when valid $ do journal newStatus cur @@ -274,18 +315,26 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do then 1 else possiblyStaleSize Journal.teamActivate tid size c teamCreationTime - journal _ _ = throwM invalidTeamStatusUpdate - validateTransition :: (TeamStatus, TeamStatus) -> Galley r Bool + journal _ _ = liftSem $ throw InvalidTeamStatusUpdate + validateTransition :: Member (Error ActionError) r => (TeamStatus, TeamStatus) -> Galley r Bool validateTransition = \case (PendingActive, Active) -> return True (Active, Active) -> return False (Active, Suspended) -> return True (Suspended, Active) -> return True (Suspended, Suspended) -> return False - (_, _) -> throwM invalidTeamStatusUpdate + (_, _) -> liftSem $ throw InvalidTeamStatusUpdate updateTeamH :: - Members '[GundeckAccess, TeamStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> Galley r Response updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -294,7 +343,14 @@ updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do pure empty updateTeam :: - Members '[GundeckAccess, TeamStore] r => + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -315,7 +371,17 @@ updateTeam zusr zcon tid updateData = do liftSem . E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon deleteTeamH :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error AuthenticationError, + Error InternalError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> Galley r Response deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -325,17 +391,26 @@ deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do -- | 'TeamDeleteData' is only required for binding teams deleteTeam :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error AuthenticationError, + Error InternalError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> Maybe Public.TeamDeleteData -> Galley r () deleteTeam zusr zcon tid mBody = do - team <- liftSem (E.getTeam tid) >>= ifNothing teamNotFound + team <- liftSem $ E.getTeam tid >>= note TeamNotFound case tdStatus team of - Deleted -> - throwM teamNotFound + Deleted -> liftSem $ throw TeamNotFound PendingDelete -> queueTeamDeletion tid zusr (Just zcon) _ -> do @@ -345,19 +420,22 @@ deleteTeam zusr zcon tid mBody = do checkPermissions team = do void $ permissionCheck DeleteTeam =<< liftSem (E.getTeamMember tid zusr) when ((tdTeam team) ^. teamBinding == Binding) $ do - body <- mBody & ifNothing (invalidPayload "missing request body") + body <- liftSem $ mBody & note (InvalidPayload "missing request body") ensureReAuthorised zusr (body ^. tdAuthPassword) -- This can be called by stern -internalDeleteBindingTeamWithOneMember :: Member TeamStore r => TeamId -> Galley r () +internalDeleteBindingTeamWithOneMember :: + Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId -> + Galley r () internalDeleteBindingTeamWithOneMember tid = do team <- liftSem (E.getTeam tid) - unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ - throwM noBindingTeam + liftSem . unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ + throw NoBindingTeam mems <- liftSem $ E.getTeamMembersWithLimit tid (unsafeRange 2) case mems ^. teamMembers of (mem : []) -> queueTeamDeletion tid (mem ^. userId) Nothing - _ -> throwM notAOneMemberTeam + _ -> liftSem $ throw NotAOneMemberTeam -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. uncheckedDeleteTeam :: @@ -446,21 +524,18 @@ uncheckedDeleteTeam zusr zcon tid = do pure (pp', ee' ++ ee) getTeamConversationRoles :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r Public.ConversationRolesList getTeamConversationRoles zusr tid = do - mem <- liftSem $ E.getTeamMember tid zusr - case mem of - Nothing -> throwErrorDescriptionType @NotATeamMember - Just _ -> do - -- NOTE: If/when custom roles are added, these roles should - -- be merged with the team roles (if they exist) - pure $ Public.ConversationRolesList wireConvRoles + liftSem . void $ E.getTeamMember tid zusr >>= noteED @NotATeamMember + -- NOTE: If/when custom roles are added, these roles should + -- be merged with the team roles (if they exist) + pure $ Public.ConversationRolesList wireConvRoles getTeamMembersH :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley r Response getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do @@ -468,27 +543,26 @@ getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do pure . json $ teamMemberListJson withPerms memberList getTeamMembers :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) -getTeamMembers zusr tid maxResults = do - liftSem (E.getTeamMember tid zusr) >>= \case - Nothing -> throwErrorDescriptionType @NotATeamMember - Just m -> do - mems <- liftSem $ E.getTeamMembersWithLimit tid maxResults - let withPerms = (m `canSeePermsOf`) - pure (mems, withPerms) +getTeamMembers zusr tid maxResults = liftSem $ do + m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember + mems <- E.getTeamMembersWithLimit tid maxResults + let withPerms = (m `canSeePermsOf`) + pure (mems, withPerms) getTeamMembersCSVH :: - (Members '[BrigAccess, TeamStore] r) => + (Members '[BrigAccess, Error ActionError, TeamStore] r) => UserId ::: TeamId ::: JSON -> Galley r Response getTeamMembersCSVH (zusr ::: tid ::: _) = do - liftSem (E.getTeamMember tid zusr) >>= \case - Nothing -> throwM accessDenied - Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throwM accessDenied + liftSem $ + E.getTeamMember tid zusr >>= \case + Nothing -> throw AccessDenied + Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throw AccessDenied env <- ask -- In case an exception is thrown inside the StreamingBody of responseStream @@ -598,7 +672,14 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do (UserScimExternalId _) -> Nothing bulkGetTeamMembersH :: - Member TeamStore r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley r Response bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do @@ -608,25 +689,23 @@ bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do -- | like 'getTeamMembers', but with an explicit list of users we are to return. bulkGetTeamMembers :: - Member TeamStore r => + Members '[Error ActionError, Error InvalidInput, Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> Galley r (TeamMemberList, TeamMember -> Bool) -bulkGetTeamMembers zusr tid maxResults uids = do +bulkGetTeamMembers zusr tid maxResults uids = liftSem $ do unless (length uids <= fromIntegral (fromRange maxResults)) $ - throwM bulkGetMemberLimitExceeded - liftSem (E.getTeamMember tid zusr) >>= \case - Nothing -> throwErrorDescriptionType @NotATeamMember - Just m -> liftSem $ do - mems <- E.selectTeamMembers tid uids - let withPerms = (m `canSeePermsOf`) - hasMore = ListComplete - pure (newTeamMemberList mems hasMore, withPerms) + throw BulkGetMemberLimitExceeded + m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember + mems <- E.selectTeamMembers tid uids + let withPerms = (m `canSeePermsOf`) + hasMore = ListComplete + pure (newTeamMemberList mems hasMore, withPerms) getTeamMemberH :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do @@ -634,23 +713,22 @@ getTeamMemberH (zusr ::: tid ::: uid ::: _) = do pure . json $ teamMemberJson withPerms member getTeamMember :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> UserId -> Galley r (Public.TeamMember, Public.TeamMember -> Bool) getTeamMember zusr tid uid = do - zusrMembership <- liftSem $ E.getTeamMember tid zusr - case zusrMembership of - Nothing -> throwErrorDescriptionType @NotATeamMember - Just m -> do - let withPerms = (m `canSeePermsOf`) - liftSem (E.getTeamMember tid uid) >>= \case - Nothing -> throwM teamMemberNotFound - Just member -> pure (member, withPerms) + m <- + liftSem $ + E.getTeamMember tid zusr + >>= noteED @NotATeamMember + let withPerms = (m `canSeePermsOf`) + member <- liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound + pure (member, withPerms) internalDeleteBindingTeamWithOneMemberH :: - Member TeamStore r => + Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> Galley r Response internalDeleteBindingTeamWithOneMemberH tid = do @@ -658,19 +736,19 @@ internalDeleteBindingTeamWithOneMemberH tid = do pure (empty & setStatus status202) uncheckedGetTeamMemberH :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId ::: UserId ::: JSON -> Galley r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid uncheckedGetTeamMember :: - Member TeamStore r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> UserId -> Galley r TeamMember -uncheckedGetTeamMember tid uid = do - liftSem (E.getTeamMember tid uid) >>= ifNothing teamMemberNotFound +uncheckedGetTeamMember tid uid = + liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound uncheckedGetTeamMembersH :: Member TeamStore r => @@ -690,6 +768,11 @@ addTeamMemberH :: Members '[ BrigAccess, GundeckAccess, + Error ActionError, + Error LegalHoldError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, LegalHoldStore, MemberStore, TeamFeatureStore, @@ -708,6 +791,10 @@ addTeamMember :: Members '[ BrigAccess, GundeckAccess, + Error ActionError, + Error LegalHoldError, + Error TeamError, + Error NotATeamMember, LegalHoldStore, MemberStore, TeamFeatureStore, @@ -743,9 +830,13 @@ addTeamMember zusr zcon tid nmem = do uncheckedAddTeamMemberH :: Members '[ BrigAccess, + Error LegalHoldError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, GundeckAccess, - MemberStore, LegalHoldStore, + MemberStore, TeamFeatureStore, TeamStore, TeamNotificationStore @@ -762,6 +853,9 @@ uncheckedAddTeamMember :: Members '[ BrigAccess, GundeckAccess, + Error LegalHoldError, + Error TeamError, + Error NotATeamMember, MemberStore, LegalHoldStore, TeamFeatureStore, @@ -781,7 +875,16 @@ uncheckedAddTeamMember tid nmem = do Journal.teamUpdate tid (sizeBeforeAdd + 1) billingUserIds updateTeamMemberH :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -792,7 +895,15 @@ updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do updateTeamMember :: forall r. - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -806,7 +917,7 @@ updateTeamMember zusr zcon tid targetMember = do . Log.field "action" (Log.val "Teams.updateTeamMember") -- get the team and verify permissions - team <- tdTeam <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) + team <- liftSem . fmap tdTeam $ E.getTeam tid >>= note TeamNotFound user <- liftSem (E.getTeamMember tid zusr) >>= permissionCheck SetMemberPermissions @@ -814,16 +925,13 @@ updateTeamMember zusr zcon tid targetMember = do -- user may not elevate permissions targetPermissions `ensureNotElevated` user previousMember <- - liftSem (E.getTeamMember tid targetId) >>= \case - Nothing -> - -- target user must be in same team - throwM teamMemberNotFound - Just previousMember -> pure previousMember - when - ( downgradesOwner previousMember targetPermissions - && not (canDowngradeOwner user previousMember) - ) - $ throwM accessDenied + liftSem $ E.getTeamMember tid targetId >>= note TeamMemberNotFound + liftSem + . when + ( downgradesOwner previousMember targetPermissions + && not (canDowngradeOwner user previousMember) + ) + $ throw AccessDenied -- update target in Cassandra liftSem $ E.setTeamMemberPermissions (previousMember ^. permissions) tid targetId targetPermissions @@ -864,6 +972,11 @@ deleteTeamMemberH :: Members '[ BrigAccess, ConversationStore, + Error ActionError, + Error AuthenticationError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -887,6 +1000,11 @@ deleteTeamMember :: Members '[ BrigAccess, ConversationStore, + Error ActionError, + Error AuthenticationError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -906,15 +1024,15 @@ deleteTeamMember zusr zcon tid remove mBody = do zusrMember <- liftSem $ E.getTeamMember tid zusr targetMember <- liftSem $ E.getTeamMember tid remove void $ permissionCheck RemoveTeamMember zusrMember - do - dm <- maybe (throwM teamMemberNotFound) pure zusrMember - tm <- maybe (throwM teamMemberNotFound) pure targetMember - unless (canDeleteMember dm tm) $ throwM accessDenied - team <- tdTeam <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) + liftSem $ do + dm <- note TeamMemberNotFound zusrMember + tm <- note TeamMemberNotFound targetMember + unless (canDeleteMember dm tm) $ throw AccessDenied + team <- tdTeam <$> liftSem (E.getTeam tid >>= note TeamNotFound) mems <- getTeamMembersForFanout tid if team ^. teamBinding == Binding && isJust targetMember then do - body <- mBody & ifNothing (invalidPayload "missing request body") + body <- liftSem $ mBody & note (InvalidPayload "missing request body") ensureReAuthorised zusr (body ^. tmdAuthPassword) (TeamSize sizeBeforeDelete) <- liftSem $ E.getSize tid -- TeamSize is 'Natural' and subtracting from 0 is an error @@ -993,32 +1111,39 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do liftSem $ E.deliverAsync (bots `zip` repeat y) getTeamConversations :: - Member TeamStore r => + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r Public.TeamConversationList -getTeamConversations zusr tid = do +getTeamConversations zusr tid = liftSem $ do tm <- - liftSem (E.getTeamMember tid zusr) - >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) + E.getTeamMember tid zusr + >>= noteED @NotATeamMember unless (tm `hasPermission` GetTeamConversations) $ - throwErrorDescription (operationDenied GetTeamConversations) - liftSem $ Public.newTeamConversationList <$> E.getTeamConversations tid + throw . OperationDenied . show $ GetTeamConversations + Public.newTeamConversationList <$> E.getTeamConversations tid getTeamConversation :: - Member TeamStore r => + Members + '[ Error ActionError, + Error ConversationError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> TeamId -> ConvId -> Galley r Public.TeamConversation -getTeamConversation zusr tid cid = do +getTeamConversation zusr tid cid = liftSem $ do tm <- - liftSem (E.getTeamMember tid zusr) - >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) + E.getTeamMember tid zusr + >>= noteED @NotATeamMember unless (tm `hasPermission` GetTeamConversations) $ - throwErrorDescription (operationDenied GetTeamConversations) - liftSem (E.getTeamConversation tid cid) - >>= maybe (throwErrorDescriptionType @ConvNotFound) pure + throw . OperationDenied . show $ GetTeamConversations + E.getTeamConversation tid cid + >>= note ConvNotFound deleteTeamConversation :: Members @@ -1026,6 +1151,12 @@ deleteTeamConversation :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, ExternalAccess, FederatorAccess, FireAndForget, @@ -1046,7 +1177,14 @@ deleteTeamConversation zusr zcon _tid cid = do void $ API.deleteLocalConversation lusr zcon lconv getSearchVisibilityH :: - Members '[SearchVisibilityStore, TeamStore] r => + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + SearchVisibilityStore, + TeamStore + ] + r => UserId ::: TeamId ::: JSON -> Galley r Response getSearchVisibilityH (uid ::: tid ::: _) = do @@ -1055,7 +1193,16 @@ getSearchVisibilityH (uid ::: tid ::: _) = do json <$> getSearchVisibilityInternal tid setSearchVisibilityH :: - Members '[SearchVisibilityStore, TeamStore, TeamFeatureStore] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + SearchVisibilityStore, + TeamStore, + TeamFeatureStore + ] + r => UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do @@ -1097,37 +1244,38 @@ withTeamIds usr range size k = case range of k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: Member TeamStore r => [UserId] -> Galley r () +ensureUnboundUsers :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => [UserId] -> Galley r () ensureUnboundUsers uids = do -- We check only 1 team because, by definition, users in binding teams -- can only be part of one team. teams <- liftSem $ Map.elems <$> E.getUsersTeams uids binds <- liftSem $ E.getTeamsBindings teams - when (any (== Binding) binds) $ - throwM userBindingExists + liftSem . when (any (== Binding) binds) $ + throw UserBindingExists -ensureNonBindingTeam :: Member TeamStore r => TeamId -> Galley r () +ensureNonBindingTeam :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> Galley r () ensureNonBindingTeam tid = do - team <- liftSem (E.getTeam tid) >>= ifNothing teamNotFound - when ((tdTeam team) ^. teamBinding == Binding) $ - throwM noAddToBinding + team <- liftSem $ note TeamNotFound =<< E.getTeam tid + liftSem . when ((tdTeam team) ^. teamBinding == Binding) $ + throw NoAddToBinding -- ensure that the permissions are not "greater" than the user's copy permissions -- this is used to ensure users cannot "elevate" permissions -ensureNotElevated :: Permissions -> TeamMember -> Galley r () +ensureNotElevated :: Member (Error ActionError) r => Permissions -> TeamMember -> Galley r () ensureNotElevated targetPermissions member = - unless - ( (targetPermissions ^. self) - `Set.isSubsetOf` (member ^. permissions . copy) - ) - $ throwM invalidPermissions - -ensureNotTooLarge :: Member BrigAccess r => TeamId -> Galley r TeamSize + liftSem + . unless + ( (targetPermissions ^. self) + `Set.isSubsetOf` (member ^. permissions . copy) + ) + $ throw InvalidPermissions + +ensureNotTooLarge :: Members '[BrigAccess, Error TeamError] r => TeamId -> Galley r TeamSize ensureNotTooLarge tid = do o <- view options (TeamSize size) <- liftSem $ E.getSize tid - unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ - throwM tooManyTeamMembers + liftSem . unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ + throw TooManyTeamMembers return $ TeamSize size -- | Ensure that a team doesn't exceed the member count limit for the LegalHold @@ -1140,20 +1288,23 @@ ensureNotTooLarge tid = do -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. ensureNotTooLargeForLegalHold :: - Members '[BrigAccess, LegalHoldStore, TeamFeatureStore] r => + Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => TeamId -> Int -> Galley r () -ensureNotTooLargeForLegalHold tid teamSize = do - whenM (isLegalHoldEnabledForTeam tid) $ do - unlessM (teamSizeBelowLimit teamSize) $ do - throwM tooManyTeamMembersOnTeamWithLegalhold +ensureNotTooLargeForLegalHold tid teamSize = + whenM (isLegalHoldEnabledForTeam tid) $ + unlessM (teamSizeBelowLimit teamSize) $ + liftSem $ throw TooManyTeamMembersOnTeamWithLegalhold -ensureNotTooLargeToActivateLegalHold :: Members '[BrigAccess] r => TeamId -> Galley r () +ensureNotTooLargeToActivateLegalHold :: + Members '[BrigAccess, Error TeamError] r => + TeamId -> + Galley r () ensureNotTooLargeToActivateLegalHold tid = do (TeamSize teamSize) <- liftSem $ E.getSize tid - unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ do - throwM cannotEnableLegalHoldServiceLargeTeam + unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ + liftSem $ throw CannotEnableLegalHoldServiceLargeTeam teamSizeBelowLimit :: Int -> Galley r Bool teamSizeBelowLimit teamSize = do @@ -1167,7 +1318,16 @@ teamSizeBelowLimit teamSize = do pure True addTeamMemberInternal :: - Members '[BrigAccess, GundeckAccess, MemberStore, TeamNotificationStore, TeamStore] r => + Members + '[ BrigAccess, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + MemberStore, + TeamNotificationStore, + TeamStore + ] + r => TeamId -> Maybe UserId -> Maybe ConnId -> @@ -1205,7 +1365,14 @@ addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memLi -- less warped. This is a work-around because we cannot send events to all of a large team. -- See haddocks of module "Galley.API.TeamNotifications" for details. getTeamNotificationsH :: - Members '[BrigAccess, TeamNotificationStore] r => + Members + '[ BrigAccess, + Error TeamError, + Error NotATeamMember, + Error TeamNotificationError, + TeamNotificationStore + ] + r => UserId ::: Maybe ByteString {- NotificationId -} ::: Range 1 10000 Int32 @@ -1216,13 +1383,13 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do json @Public.QueuedNotificationList <$> APITeamQueue.getTeamNotifications zusr since size where - parseSince :: Galley r (Maybe Public.NotificationId) + parseSince :: Member (Error TeamNotificationError) r => Galley r (Maybe Public.NotificationId) parseSince = maybe (pure Nothing) (fmap Just . parseUUID) sinceRaw - parseUUID :: ByteString -> Galley r Public.NotificationId + parseUUID :: Member (Error TeamNotificationError) r => ByteString -> Galley r Public.NotificationId parseUUID raw = maybe - (throwM invalidTeamNotificationId) + (liftSem (throw InvalidTeamNotificationId)) (pure . Id) ((UUID.fromASCIIBytes >=> isV1UUID) raw) @@ -1246,35 +1413,57 @@ finishCreateTeam team owner others zcon = do let r = membersToRecipients Nothing others liftSem . E.push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon -withBindingTeam :: Member TeamStore r => UserId -> (TeamId -> Galley r b) -> Galley r b +-- FUTUREWORK: Get rid of CPS +withBindingTeam :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + UserId -> + (TeamId -> Galley r b) -> + Galley r b withBindingTeam zusr callback = do - tid <- liftSem (E.getOneUserTeam zusr) >>= ifNothing teamNotFound - binding <- liftSem (E.getTeamBinding tid) >>= ifNothing teamNotFound + tid <- liftSem $ E.getOneUserTeam zusr >>= note TeamNotFound + binding <- liftSem $ E.getTeamBinding tid >>= note TeamNotFound case binding of Binding -> callback tid - NonBinding -> throwM nonBindingTeam + NonBinding -> liftSem $ throw NotABindingTeamMember -getBindingTeamIdH :: Member TeamStore r => UserId -> Galley r Response +getBindingTeamIdH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: Member TeamStore r => UserId -> Galley r TeamId +getBindingTeamId :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: Member TeamStore r => UserId -> Galley r Response +getBindingTeamMembersH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers -getBindingTeamMembers :: Member TeamStore r => UserId -> Galley r TeamMemberList +getBindingTeamMembers :: + Members + '[ Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => + UserId -> + Galley r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> getTeamMembersForFanout tid canUserJoinTeamH :: - Members '[BrigAccess, LegalHoldStore, TeamFeatureStore] r => + Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r Response canUserJoinTeamH tid = canUserJoinTeam tid >> pure empty -- This could be extended for more checks, for now we test only legalhold -canUserJoinTeam :: Members '[BrigAccess, LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r () +canUserJoinTeam :: + Members + '[ BrigAccess, + Error LegalHoldError, + LegalHoldStore, + TeamFeatureStore + ] + r => + TeamId -> + Galley r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do @@ -1314,7 +1503,14 @@ getSearchVisibilityInternal = . SearchVisibilityData.getSearchVisibility setSearchVisibilityInternalH :: - Members '[SearchVisibilityStore, TeamFeatureStore] r => + Members + '[ Error InvalidInput, + Error TeamError, + Error NotATeamMember, + SearchVisibilityStore, + TeamFeatureStore + ] + r => TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityInternalH (tid ::: req ::: _) = do @@ -1322,32 +1518,43 @@ setSearchVisibilityInternalH (tid ::: req ::: _) = do pure noContent setSearchVisibilityInternal :: - Members '[SearchVisibilityStore, TeamFeatureStore] r => + Members '[Error TeamError, Error NotATeamMember, SearchVisibilityStore, TeamFeatureStore] r => TeamId -> TeamSearchVisibilityView -> Galley r () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do status <- getTeamSearchVisibilityAvailableInternal tid - unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ - throwM teamSearchVisibilityNotEnabled + liftSem . unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ + throw TeamSearchVisibilityNotEnabled liftSem $ SearchVisibilityData.setSearchVisibility tid searchVisibility -userIsTeamOwnerH :: Member TeamStore r => TeamId ::: UserId ::: JSON -> Galley r Response +userIsTeamOwnerH :: + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId ::: UserId ::: JSON -> + Galley r Response userIsTeamOwnerH (tid ::: uid ::: _) = do userIsTeamOwner tid uid >>= \case True -> pure empty - False -> throwM accessDenied + False -> liftSem $ throw AccessDenied -userIsTeamOwner :: Member TeamStore r => TeamId -> UserId -> Galley r Bool +userIsTeamOwner :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId -> + UserId -> + Galley r Bool userIsTeamOwner tid uid = do let asking = uid isTeamOwner . fst <$> getTeamMember asking tid uid -- Queues a team for async deletion -queueTeamDeletion :: TeamId -> UserId -> Maybe ConnId -> Galley r () +queueTeamDeletion :: + Member (Error InternalError) r => + TeamId -> + UserId -> + Maybe ConnId -> + Galley r () queueTeamDeletion tid zusr zcon = do q <- view deleteQueue ok <- Q.tryPush q (TeamItem tid zusr zcon) - if ok - then pure () - else throwM deleteQueueFull + liftSem . unless ok $ + throw DeleteQueueFull diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index d4a2a076b72..4498865cf33 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -45,9 +45,7 @@ module Galley.API.Teams.Features ) where -import Bilge (MonadHttp) import Control.Lens -import Control.Monad.Catch import qualified Data.Aeson as Aeson import Data.ByteString.Conversion hiding (fromList) import qualified Data.HashMap.Strict as HashMap @@ -74,19 +72,16 @@ import Imports import Network.HTTP.Client (Manager) import Network.Wai import Network.Wai.Predicate hiding (Error, or, result, setStatus) -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) +import Polysemy.Error import Servant.API ((:<|>) ((:<|>))) import qualified Servant.Client as Client import qualified System.Logger.Class as Log import Util.Options (Endpoint, epHost, epPort) +import Wire.API.ErrorDescription import Wire.API.Event.FeatureConfig - ( EventData - ( EdFeatureApplockChanged, - EdFeatureSelfDeletingMessagesChanged, - EdFeatureWithoutConfigChanged - ), - ) import qualified Wire.API.Event.FeatureConfig as Event +import Wire.API.Federation.Client import qualified Wire.API.Routes.Internal.Brig as IAPI import Wire.API.Team.Feature (AllFeatureConfigs (..), FeatureHasNoConfig, KnownTeamFeatureName, TeamFeatureName) import qualified Wire.API.Team.Feature as Public @@ -97,7 +92,15 @@ data DoAuth = DoAuth UserId | DontDoAuth -- and a team id, but no uid of the member for which the feature config holds. getFeatureStatus :: forall (a :: Public.TeamFeatureName) r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r + ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -114,7 +117,15 @@ getFeatureStatus getter doauth tid = do -- | For team-settings, like 'getFeatureStatus'. setFeatureStatus :: forall (a :: Public.TeamFeatureName) r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r + ) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -132,7 +143,15 @@ setFeatureStatus setter doauth tid status = do -- | For individual users to get feature config for their account (personal or team). getFeatureConfig :: forall (a :: Public.TeamFeatureName) r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r + ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> UserId -> Galley r (Public.TeamFeatureStatus a) @@ -147,7 +166,16 @@ getFeatureConfig getter zusr = do getter (Right tid) getAllFeatureConfigs :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InternalError, + Error NotATeamMember, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> Galley r AllFeatureConfigs getAllFeatureConfigs zusr = do @@ -157,7 +185,7 @@ getAllFeatureConfigs zusr = do forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a), - Member TeamStore r + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> Galley r (Text, Aeson.Value) @@ -183,7 +211,16 @@ getAllFeatureConfigs zusr = do ] getAllFeaturesH :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InternalError, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId ::: TeamId ::: JSON -> Galley r Response getAllFeaturesH (uid ::: tid ::: _) = @@ -191,7 +228,16 @@ getAllFeaturesH (uid ::: tid ::: _) = getAllFeatures :: forall r. - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members + '[ Error ActionError, + Error InternalError, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> TeamId -> Galley r Aeson.Value @@ -224,8 +270,7 @@ getAllFeatures uid tid = do getFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) r. - ( Public.KnownTeamFeatureName a, - Public.FeatureHasNoConfig a, + ( Public.FeatureHasNoConfig a, HasStatusCol a, Member TeamFeatureStore r ) => @@ -274,12 +319,12 @@ getSSOStatusInternal = FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled setSSOStatusInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[Error TeamFeatureError, GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case - Public.TeamFeatureDisabled -> const (throwM disableSsoNotImplemented) + Public.TeamFeatureDisabled -> const (liftSem (throw DisableSsoNotImplemented)) Public.TeamFeatureEnabled -> const (pure ()) getTeamSearchVisibilityAvailableInternal :: @@ -366,6 +411,15 @@ setLegalholdStatusInternal :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error TeamError, + Error NotATeamMember, + Error TeamFeatureError, ExternalAccess, FederatorAccess, FireAndForget, @@ -388,13 +442,13 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do -- enabeling LH for teams is only allowed in normal operation; disabled-permanently and -- whitelist-teams have no or their own way to do that, resp. featureLegalHold <- view (options . optSettings . setFeatureFlags . flagLegalHold) - case featureLegalHold of + liftSem $ case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do pure () FeatureLegalHoldDisabledPermanently -> do - throwM legalHoldFeatureFlagNotEnabled + throw LegalHoldFeatureFlagNotEnabled FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do - throwM legalHoldWhitelistedOnly + throw LegalHoldWhitelistedOnly -- we're good to update the status now. case statusValue of @@ -445,13 +499,13 @@ getAppLockInternal mbtid = do pure $ fromMaybe defaultStatus status setAppLockInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, Error TeamFeatureError] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ - throwM inactivityTimeoutTooLow + liftSem $ throw AppLockinactivityTimeoutTooLow let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureAppLock (EdFeatureApplockChanged status) @@ -467,7 +521,7 @@ getClassifiedDomainsInternal _mbtid = do Public.TeamFeatureEnabled -> config getConferenceCallingInternal :: - Member TeamFeatureStore r => + Members '[Error InternalError, TeamFeatureStore] r => GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do @@ -528,7 +582,7 @@ pushFeatureConfigEvent tid event = do -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) getFeatureConfigViaAccount :: - (flag ~ 'Public.TeamFeatureConferenceCalling) => + (flag ~ 'Public.TeamFeatureConferenceCalling, Member (Error InternalError) r) => UserId -> Galley r (Public.TeamFeatureStatus flag) getFeatureConfigViaAccount uid = do @@ -537,13 +591,14 @@ getFeatureConfigViaAccount uid = do getAccountFeatureConfigClient brigep mgr uid >>= handleResp where handleResp :: + Member (Error InternalError) r => Either Client.ClientError Public.TeamFeatureStatusNoConfig -> Galley r Public.TeamFeatureStatusNoConfig handleResp (Right cfg) = pure cfg - handleResp (Left errmsg) = throwM . internalErrorWithDescription . cs . show $ errmsg + handleResp (Left errmsg) = liftSem . throw . InternalErrorWithDescription . cs . show $ errmsg getAccountFeatureConfigClient :: - (HasCallStack, MonadIO m, MonadHttp m) => + (HasCallStack, MonadIO m) => Endpoint -> Manager -> UserId -> @@ -559,7 +614,7 @@ getFeatureConfigViaAccount uid = do ) = Client.client (Proxy @IAPI.API) runHereClientM :: - (HasCallStack, MonadIO m, MonadHttp m) => + (HasCallStack, MonadIO m) => Endpoint -> Manager -> Client.ClientM a -> diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index 8b4b0117a15..0836369ee8a 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -58,19 +58,17 @@ import Galley.Types.Teams hiding (newTeam) import Gundeck.Types.Notification import Imports import Network.HTTP.Types -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) +import Polysemy.Error getTeamNotifications :: - Members '[BrigAccess, TeamNotificationStore] r => + Members '[BrigAccess, Error TeamError, TeamNotificationStore] r => UserId -> Maybe NotificationId -> Range 1 10000 Int32 -> Galley r QueuedNotificationList getTeamNotifications zusr since size = do - tid :: TeamId <- do - mtid <- liftSem $ (userTeam . accountUser =<<) <$> Intra.getUser zusr - let err = throwM teamNotFound - maybe err pure mtid + tid <- liftSem . (note TeamNotFound =<<) $ (userTeam . accountUser =<<) <$> Intra.getUser zusr page <- liftSem $ E.getTeamNotifications tid since size pure $ queuedNotificationList @@ -80,11 +78,11 @@ getTeamNotifications zusr since size = do pushTeamEvent :: Member TeamNotificationStore r => TeamId -> Event -> Galley r () pushTeamEvent tid evt = do - nid <- mkNotificationId + nid <- liftIO mkNotificationId liftSem $ E.createTeamNotification tid nid (List1.singleton $ toJSONObject evt) -- | 'Data.UUID.V1.nextUUID' is sometimes unsuccessful, so we try a few times. -mkNotificationId :: (MonadIO m, MonadThrow m) => m NotificationId +mkNotificationId :: IO NotificationId mkNotificationId = do ni <- fmap Id <$> retrying x10 fun (const (liftIO UUID.nextUUID)) maybe (throwM err) return ni diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 7708afa49eb..98344a35462 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -33,7 +33,6 @@ module Galley.API.Update updateLocalConversationMessageTimer, updateConversationMessageTimerUnqualified, updateConversationMessageTimer, - updateLocalConversation, updateConversationAccessUnqualified, updateConversationAccess, deleteLocalConversation, @@ -50,9 +49,6 @@ module Galley.API.Update removeMemberFromLocalConv, removeMemberFromRemoteConv, - -- * Notifications - notifyConversationMetadataUpdate, - -- * Talking postProteusMessage, postOtrMessageUnqualified, @@ -69,23 +65,20 @@ module Galley.API.Update ) where -import qualified Brig.Types.User as User import Control.Lens -import Control.Monad.Catch import Control.Monad.State import Control.Monad.Trans.Maybe import Data.Code import Data.Either.Extra (mapRight) import Data.Id import Data.Json.Util (fromBase64TextLenient, toUTCTimeMillis) -import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.List1 import qualified Data.Map.Strict as Map -import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range import qualified Data.Set as Set import Data.Time +import Galley.API.Action import Galley.API.Error import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) import Galley.API.Mapping @@ -96,7 +89,6 @@ import qualified Galley.Data.Conversation as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) import Galley.Effects -import qualified Galley.Effects.BotAccess as E import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ClientStore as E import qualified Galley.Effects.CodeStore as E @@ -114,103 +106,131 @@ import Galley.Types.Bot hiding (addBot) import Galley.Types.Clients (Clients) import qualified Galley.Types.Clients as Clients import Galley.Types.Conversations.Members (newMember) -import Galley.Types.Conversations.Roles (Action (..), RoleName, roleNameWireMember) +import Galley.Types.Conversations.Roles (Action (..), roleNameWireMember) import Galley.Types.Teams hiding (Event, EventData (..), EventType (..), self) import Galley.Types.UserList -import Galley.Validation import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (and, failure, setStatus, _1, _2) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, and, failure, setStatus, _1, _2) +import Network.Wai.Utilities hiding (Error) import Polysemy +import Polysemy.Error import qualified Wire.API.Conversation as Public -import Wire.API.Conversation.Action import qualified Wire.API.Conversation.Code as Public import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.ErrorDescription - ( CodeNotFound, - ConvNotFound, - MissingLegalholdConsent, - UnknownClient, - mkErrorDescription, - ) -import qualified Wire.API.ErrorDescription as Public import qualified Wire.API.Event.Conversation as Public import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (HasFederatorConfig (..)) -import Wire.API.Federation.Error (federationNotConfigured, federationNotImplemented) +import Wire.API.Federation.Client import qualified Wire.API.Message as Public import Wire.API.Routes.Public.Galley.Responses import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) -import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client acceptConvH :: - Members '[ConversationStore, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => UserId ::: Maybe ConnId ::: ConvId -> Galley r Response acceptConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> acceptConv usr conn cnv acceptConv :: - Members '[ConversationStore, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => UserId -> Maybe ConnId -> ConvId -> Galley r Conversation acceptConv usr conn cnv = do conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + liftSem $ E.getConversation cnv >>= note ConvNotFound conv' <- acceptOne2One usr conv conn conversationView usr conv' blockConvH :: - Members '[ConversationStore, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + MemberStore + ] + r => UserId ::: ConvId -> Galley r Response blockConvH (zusr ::: cnv) = empty <$ blockConv zusr cnv blockConv :: - Members '[ConversationStore, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + MemberStore + ] + r => UserId -> ConvId -> Galley r () blockConv zusr cnv = do - conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- liftSem $ E.getConversation cnv >>= note ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - throwM $ - invalidOp "block: invalid conversation type" + liftSem . throw . InvalidOp . Data.convType $ conv let mems = Data.convLocalMembers conv when (zusr `isMember` mems) . liftSem $ E.deleteMembers cnv (UserList [zusr] []) unblockConvH :: - Members '[ConversationStore, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => UserId ::: Maybe ConnId ::: ConvId -> Galley r Response unblockConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> unblockConv usr conn cnv unblockConv :: - Members '[ConversationStore, GundeckAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => UserId -> Maybe ConnId -> ConvId -> Galley r Conversation unblockConv usr conn cnv = do conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + liftSem $ E.getConversation cnv >>= note ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - throwM $ - invalidOp "unblock: invalid conversation type" + liftSem . throw . InvalidOp . Data.convType $ conv conv' <- acceptOne2One usr conv conn conversationView usr conv' @@ -222,7 +242,23 @@ handleUpdateResult = \case Unchanged -> empty & setStatus status204 updateConversationAccess :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -238,7 +274,22 @@ updateConversationAccess usr con qcnv update = do doUpdate qcnv lusr con update updateConversationAccessUnqualified :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -250,106 +301,52 @@ updateConversationAccessUnqualified usr zcon cnv update = do updateLocalConversationAccess lcnv lusr zcon update updateLocalConversationAccess :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => Local ConvId -> Local UserId -> ConnId -> Public.ConversationAccessData -> Galley r (UpdateResult Event) -updateLocalConversationAccess lcnv lusr con target = +updateLocalConversationAccess lcnv lusr con = getUpdateResult . updateLocalConversation lcnv (qUntagged lusr) (Just con) - . ConversationActionAccessUpdate - $ target updateRemoteConversationAccess :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Public.ConversationAccessData -> Galley r (UpdateResult Event) -updateRemoteConversationAccess _ _ _ _ = throwM federationNotImplemented +updateRemoteConversationAccess _ _ _ _ = liftSem $ throw FederationNotImplemented -performAccessUpdateAction :: - forall r. +updateConversationReceiptMode :: Members - '[ BrigAccess, - BotAccess, - CodeStore, - ConversationStore, + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, - FireAndForget, - GundeckAccess, - LegalHoldStore, - MemberStore, - TeamStore + GundeckAccess ] r => - Qualified UserId -> - Data.Conversation -> - ConversationAccessData -> - MaybeT (Galley r) () -performAccessUpdateAction qusr conv target = do - lcnv <- qualifyLocal (Data.convId conv) - guard $ Data.convAccessData conv /= target - -- Remove conversation codes if CodeAccess is revoked - when - ( CodeAccess `elem` Data.convAccess conv - && CodeAccess `notElem` cupAccess target - ) - $ lift $ do - key <- mkKey (tUnqualified lcnv) - liftSem $ E.deleteCode key ReusableCode - - -- Determine bots and members to be removed - let filterBotsAndMembers = filterActivated >=> filterTeammates - let current = convBotsAndMembers conv -- initial bots and members - desired <- lift . liftSem $ filterBotsAndMembers current -- desired bots and members - let toRemove = bmDiff current desired -- bots and members to be removed - - -- Update Cassandra - lift . liftSem $ E.setConversationAccess (tUnqualified lcnv) target - lift . fireAndForget $ do - -- Remove bots - traverse_ (liftSem . E.deleteBot (tUnqualified lcnv) . botMemId) (bmBots toRemove) - - -- Update current bots and members - let current' = current {bmBots = bmBots desired} - - -- Remove users and notify everyone - void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do - let action = ConversationActionRemoveMembers usersToRemove - void . runMaybeT $ performAction qusr conv action - notifyConversationMetadataUpdate qusr Nothing lcnv current' action - where - filterActivated :: BotsAndMembers -> Sem r BotsAndMembers - filterActivated bm - | ( Data.convAccessRole conv > ActivatedAccessRole - && cupAccessRole target <= ActivatedAccessRole - ) = do - activated <- map User.userId <$> E.lookupActivatedUsers (toList (bmLocals bm)) - -- FUTUREWORK: should we also remove non-activated remote users? - pure $ bm {bmLocals = Set.fromList activated} - | otherwise = pure bm - - filterTeammates :: BotsAndMembers -> Sem r BotsAndMembers - filterTeammates bm = do - -- In a team-only conversation we also want to remove bots and guests - case (cupAccessRole target, Data.convTeam conv) of - (TeamAccessRole, Just tid) -> do - onlyTeamUsers <- flip filterM (toList (bmLocals bm)) $ \user -> - isJust <$> E.getTeamMember tid user - pure $ - BotsAndMembers - { bmLocals = Set.fromList onlyTeamUsers, - bmBots = mempty, - bmRemotes = mempty - } - _ -> pure bm - -updateConversationReceiptMode :: - Members UpdateConversationActions r => + Members '[Error FederationError] r => UserId -> ConnId -> Qualified ConvId -> @@ -365,7 +362,16 @@ updateConversationReceiptMode usr zcon qcnv update = do doUpdate qcnv lusr zcon update updateConversationReceiptModeUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -377,7 +383,16 @@ updateConversationReceiptModeUnqualified usr zcon cnv update = do updateLocalConversationReceiptMode lcnv lusr zcon update updateLocalConversationReceiptMode :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local ConvId -> Local UserId -> ConnId -> @@ -385,19 +400,28 @@ updateLocalConversationReceiptMode :: Galley r (UpdateResult Event) updateLocalConversationReceiptMode lcnv lusr con update = getUpdateResult $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionReceiptModeUpdate update + updateLocalConversation lcnv (qUntagged lusr) (Just con) update updateRemoteConversationReceiptMode :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> Galley r (UpdateResult Event) -updateRemoteConversationReceiptMode _ _ _ _ = throwM federationNotImplemented +updateRemoteConversationReceiptMode _ _ _ _ = liftSem $ throw FederationNotImplemented updateConversationMessageTimerUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -409,7 +433,17 @@ updateConversationMessageTimerUnqualified usr zcon cnv update = do updateLocalConversationMessageTimer lusr zcon lcnv update updateConversationMessageTimer :: - (Member ConversationStore r, Members UpdateConversationActions r) => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -420,12 +454,21 @@ updateConversationMessageTimer usr zcon qcnv update = do foldQualified lusr (updateLocalConversationMessageTimer lusr zcon) - (\_ _ -> throwM federationNotImplemented) + (\_ _ -> liftSem (throw FederationNotImplemented)) qcnv update updateLocalConversationMessageTimer :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> @@ -433,115 +476,43 @@ updateLocalConversationMessageTimer :: Galley r (UpdateResult Event) updateLocalConversationMessageTimer lusr con lcnv update = getUpdateResult $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionMessageTimerUpdate update + updateLocalConversation lcnv (qUntagged lusr) (Just con) update deleteLocalConversation :: - Members UpdateConversationActions r => + Members + '[ CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + TeamStore + ] + r => Local UserId -> ConnId -> Local ConvId -> Galley r (UpdateResult Event) deleteLocalConversation lusr con lcnv = getUpdateResult $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationActionDelete - --- FUTUREWORK: split conversation actions into multiple types so that we can --- have more granular effect constraints -type UpdateConversationActions = - '[ BotAccess, - BrigAccess, - ExternalAccess, - FederatorAccess, - FireAndForget, - GundeckAccess, - CodeStore, - ConversationStore, - LegalHoldStore, - MemberStore, - TeamStore - ] - --- | Update a local conversation, and notify all local and remote members. -updateLocalConversation :: - Members UpdateConversationActions r => - Local ConvId -> - Qualified UserId -> - Maybe ConnId -> - ConversationAction -> - MaybeT (Galley r) Event -updateLocalConversation lcnv qusr con action = do - -- retrieve conversation - (conv, self) <- - lift $ - getConversationAndMemberWithError - (errorDescriptionTypeToWai @ConvNotFound) - qusr - (tUnqualified lcnv) - - -- perform checks - lift $ ensureConversationActionAllowed action conv self - - -- perform action - (extraTargets, action') <- performAction qusr conv action - - -- send notifications to both local and remote users - lift $ - notifyConversationMetadataUpdate - qusr - con - lcnv - (convBotsAndMembers conv <> extraTargets) - action' + updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationDelete getUpdateResult :: Functor m => MaybeT m a -> m (UpdateResult a) getUpdateResult = fmap (maybe Unchanged Updated) . runMaybeT --- | Perform a conversation action, and return extra notification targets and --- an updated action. -performAction :: - Members UpdateConversationActions r => - Qualified UserId -> - Data.Conversation -> - ConversationAction -> - MaybeT (Galley r) (BotsAndMembers, ConversationAction) -performAction qusr conv action = case action of - ConversationActionAddMembers members role -> - performAddMemberAction qusr conv members role - ConversationActionRemoveMembers members -> do - performRemoveMemberAction conv (toList members) - pure (mempty, action) - ConversationActionRename rename -> lift $ do - cn <- rangeChecked (cupName rename) - liftSem $ E.setConversationName (Data.convId conv) cn - pure (mempty, action) - ConversationActionMessageTimerUpdate update -> do - guard $ Data.convMessageTimer conv /= cupMessageTimer update - lift . liftSem $ E.setConversationMessageTimer (Data.convId conv) (cupMessageTimer update) - pure (mempty, action) - ConversationActionReceiptModeUpdate update -> do - guard $ Data.convReceiptMode conv /= Just (cruReceiptMode update) - lift . liftSem $ E.setConversationReceiptMode (Data.convId conv) (cruReceiptMode update) - pure (mempty, action) - ConversationActionMemberUpdate target update -> lift $ do - lcnv <- qualifyLocal (Data.convId conv) - void $ ensureOtherMember lcnv target conv - liftSem $ E.setOtherMember lcnv target update - pure (mempty, action) - ConversationActionAccessUpdate update -> do - performAccessUpdateAction qusr conv update - pure (mempty, action) - ConversationActionDelete -> lift $ do - let cid = Data.convId conv - key <- mkKey cid - liftSem $ E.deleteCode key ReusableCode - liftSem $ case Data.convTeam conv of - Nothing -> E.deleteConversation cid - Just tid -> E.deleteTeamConversation tid cid - pure (mempty, action) - addCodeH :: - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId ::: ConnId ::: ConvId -> Galley r Response addCodeH (usr ::: zcon ::: cnv) = @@ -555,7 +526,14 @@ data AddCodeResult addCode :: forall r. - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -564,11 +542,9 @@ addCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain qusr = Qualified usr localDomain - conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- liftSem $ E.getConversation cnv >>= note ConvNotFound ensureConvMember (Data.convLocalMembers conv) usr - ensureAccess conv CodeAccess + liftSem $ ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv key <- mkKey cnv mCode <- liftSem $ E.getCode key ReusableCode @@ -591,14 +567,28 @@ addCode usr zcon cnv = do return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix rmCodeH :: - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId ::: ConnId ::: ConvId -> Galley r Response rmCodeH (usr ::: zcon ::: cnv) = setStatus status200 . json <$> rmCode usr zcon cnv rmCode :: - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -608,10 +598,9 @@ rmCode usr zcon cnv = do let qcnv = Qualified cnv localDomain qusr = Qualified usr localDomain conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + liftSem $ E.getConversation cnv >>= note ConvNotFound ensureConvMember (Data.convLocalMembers conv) usr - ensureAccess conv CodeAccess + liftSem $ ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv key <- mkKey cnv liftSem $ E.deleteCode key ReusableCode @@ -621,27 +610,36 @@ rmCode usr zcon cnv = do pure event getCodeH :: - Members '[CodeStore, ConversationStore] r => + Members + '[ CodeStore, + ConversationStore, + Error CodeError, + Error ConversationError + ] + r => UserId ::: ConvId -> Galley r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv getCode :: - Members '[CodeStore, ConversationStore] r => + Members + '[ CodeStore, + ConversationStore, + Error CodeError, + Error ConversationError + ] + r => UserId -> ConvId -> Galley r Public.ConversationCode getCode usr cnv = do conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) - ensureAccess conv CodeAccess + liftSem $ E.getConversation cnv >>= note ConvNotFound + liftSem $ ensureAccess conv CodeAccess ensureConvMember (Data.convLocalMembers conv) usr key <- mkKey cnv - c <- - liftSem (E.getCode key ReusableCode) - >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) + c <- liftSem $ E.getCode key ReusableCode >>= note CodeNotFound returnCode c returnCode :: Code -> Galley r Public.ConversationCode @@ -649,13 +647,19 @@ returnCode c = do urlPrefix <- view $ options . optSettings . setConversationCodeURI pure $ Public.mkConversationCode (codeKey c) (codeValue c) urlPrefix -checkReusableCodeH :: Member CodeStore r => JsonRequest Public.ConversationCode -> Galley r Response +checkReusableCodeH :: + Members '[CodeStore, Error CodeError, Error InvalidInput] r => + JsonRequest Public.ConversationCode -> + Galley r Response checkReusableCodeH req = do convCode <- fromJsonBody req checkReusableCode convCode pure empty -checkReusableCode :: Member CodeStore r => Public.ConversationCode -> Galley r () +checkReusableCode :: + Members '[CodeStore, Error CodeError] r => + Public.ConversationCode -> + Galley r () checkReusableCode convCode = void $ verifyReusableCode convCode @@ -665,6 +669,12 @@ joinConversationByReusableCodeH :: CodeStore, ConversationStore, FederatorAccess, + Error ActionError, + Error CodeError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -682,6 +692,12 @@ joinConversationByReusableCode :: '[ BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error CodeError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, FederatorAccess, ExternalAccess, GundeckAccess, @@ -702,6 +718,11 @@ joinConversationByIdH :: '[ BrigAccess, ConversationStore, FederatorAccess, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -718,6 +739,11 @@ joinConversationById :: '[ BrigAccess, FederatorAccess, ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -736,6 +762,11 @@ joinConversation :: '[ BrigAccess, ConversationStore, FederatorAccess, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -751,7 +782,7 @@ joinConversation zusr zcon cnv access = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv conv <- ensureConversationAccess zusr cnv access - ensureGroupConvThrowing conv + liftSem . ensureGroupConversation $ conv -- FUTUREWORK: remote users? ensureMemberLimit (toList $ Data.convLocalMembers conv) [zusr] getUpdateResult $ do @@ -762,117 +793,31 @@ joinConversation zusr zcon cnv access = do (extraTargets, action) <- addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember lift $ - notifyConversationMetadataUpdate + notifyConversationAction (qUntagged lusr) (Just zcon) lcnv (convBotsAndMembers conv <> extraTargets) - action - --- | Add users to a conversation without performing any checks. Return extra --- notification targets and the action performed. -addMembersToLocalConversation :: - Members '[MemberStore] r => - Local ConvId -> - UserList UserId -> - RoleName -> - MaybeT (Galley r) (BotsAndMembers, ConversationAction) -addMembersToLocalConversation lcnv users role = do - (lmems, rmems) <- lift . liftSem $ E.createMembers (tUnqualified lcnv) (fmap (,role) users) - neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users - let action = ConversationActionAddMembers neUsers role - pure (bmFromMembers lmems rmems, action) - -performAddMemberAction :: - forall r. - Members UpdateConversationActions r => - Qualified UserId -> - Data.Conversation -> - NonEmpty (Qualified UserId) -> - RoleName -> - MaybeT (Galley r) (BotsAndMembers, ConversationAction) -performAddMemberAction qusr conv invited role = do - lcnv <- lift $ qualifyLocal (Data.convId conv) - let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited - lift $ do - ensureMemberLimit (toList (Data.convLocalMembers conv)) newMembers - ensureAccess conv InviteAccess - checkLocals lcnv (Data.convTeam conv) (ulLocals newMembers) - checkRemotes (ulRemotes newMembers) - checkLHPolicyConflictsLocal lcnv (ulLocals newMembers) - checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) - addMembersToLocalConversation lcnv newMembers role - where - userIsMember u = (^. userId . to (== u)) - - checkLocals :: Local ConvId -> Maybe TeamId -> [UserId] -> Galley r () - checkLocals lcnv (Just tid) newUsers = do - tms <- liftSem $ E.selectTeamMembers tid newUsers - let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers - ensureAccessRole (Data.convAccessRole conv) userMembershipMap - tcv <- liftSem $ E.getTeamConversation tid (tUnqualified lcnv) - when (maybe True (view managedConversation) tcv) $ - throwM noAddToManaged - ensureConnectedOrSameTeam qusr newUsers - checkLocals _ Nothing newUsers = do - ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) - ensureConnectedOrSameTeam qusr newUsers - - checkRemotes :: [Remote UserId] -> Galley r () - checkRemotes remotes = do - -- if federator is not configured, we fail early, so we avoid adding - -- remote members to the database - unless (null remotes) $ do - endpoint <- federatorEndpoint - when (isNothing endpoint) $ - throwM federationNotConfigured - - loc <- qualifyLocal () - foldQualified - loc - ensureConnectedToRemotes - (\_ _ -> throwM federationNotImplemented) - qusr - remotes - - checkLHPolicyConflictsLocal :: Local ConvId -> [UserId] -> Galley r () - checkLHPolicyConflictsLocal lcnv newUsers = do - let convUsers = Data.convLocalMembers conv - - allNewUsersGaveConsent <- allLegalholdConsentGiven newUsers - - whenM (anyLegalholdActivated (lmId <$> convUsers)) $ - unless allNewUsersGaveConsent $ - throwErrorDescriptionType @MissingLegalholdConsent - - whenM (anyLegalholdActivated newUsers) $ do - unless allNewUsersGaveConsent $ - throwErrorDescriptionType @MissingLegalholdConsent - - convUsersLHStatus <- do - uidsStatus <- getLHStatusForUsers (lmId <$> convUsers) - pure $ zipWith (\mem (_, status) -> (mem, status)) convUsers uidsStatus - - if any - ( \(mem, status) -> - lmConvRoleName mem == roleNameWireAdmin - && consentGiven status == ConsentGiven - ) - convUsersLHStatus - then do - for_ convUsersLHStatus $ \(mem, status) -> - when (consentGiven status == ConsentNotGiven) $ do - qvictim <- qUntagged <$> qualifyLocal (lmId mem) - void . runMaybeT $ - updateLocalConversation lcnv qvictim Nothing $ - ConversationActionRemoveMembers (pure qvictim) - else throwErrorDescriptionType @MissingLegalholdConsent - - checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley r () - checkLHPolicyConflictsRemote _remotes = pure () + (conversationAction action) addMembersUnqualified :: - Members UpdateConversationActions r => + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -883,7 +828,23 @@ addMembersUnqualified zusr zcon cnv (Public.Invite users role) = do addMembers zusr zcon cnv (Public.InviteQualified qusers role) addMembers :: - Members UpdateConversationActions r => + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -894,10 +855,17 @@ addMembers zusr zcon cnv (Public.InviteQualified users role) = do lcnv <- qualifyLocal cnv getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just zcon) $ - ConversationActionAddMembers users role + ConversationJoin users role updateSelfMember :: - Members '[ConversationStore, GundeckAccess, ExternalAccess, MemberStore] r => + Members + '[ ConversationStore, + Error ConversationError, + GundeckAccess, + ExternalAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -906,7 +874,7 @@ updateSelfMember :: updateSelfMember zusr zcon qcnv update = do lusr <- qualifyLocal zusr exists <- liftSem $ foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr - unless exists (throwErrorDescriptionType @ConvNotFound) + liftSem . unless exists . throw $ ConvNotFound liftSem $ E.setSelfMember qcnv lusr update now <- liftIO getCurrentTime let e = Event MemberStateUpdate qcnv (qUntagged lusr) now (EdMemberUpdate (updateData lusr)) @@ -941,7 +909,14 @@ updateSelfMember zusr zcon qcnv update = do } updateUnqualifiedSelfMember :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -952,7 +927,17 @@ updateUnqualifiedSelfMember zusr zcon cnv update = do updateSelfMember zusr zcon (qUntagged lcnv) update updateOtherMemberUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -966,7 +951,18 @@ updateOtherMemberUnqualified zusr zcon cnv victim update = do updateOtherMemberLocalConv lcnv lusr zcon (qUntagged lvictim) update updateOtherMember :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -979,7 +975,17 @@ updateOtherMember zusr zcon qcnv qvictim update = do doUpdate qcnv lusr zcon qvictim update updateOtherMemberLocalConv :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => Local ConvId -> Local UserId -> ConnId -> @@ -987,22 +993,33 @@ updateOtherMemberLocalConv :: Public.OtherMemberUpdate -> Galley r () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do - when (qUntagged lusr == qvictim) $ - throwM invalidTargetUserOp + lift . liftSem . when (qUntagged lusr == qvictim) $ + throw InvalidTargetUserOp updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionMemberUpdate qvictim update + ConversationMemberUpdate qvictim update updateOtherMemberRemoteConv :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> Galley r () -updateOtherMemberRemoteConv _ _ _ _ _ = throwM federationNotImplemented +updateOtherMemberRemoteConv _ _ _ _ _ = liftSem $ throw FederationNotImplemented removeMemberUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -1014,7 +1031,17 @@ removeMemberUnqualified zusr con cnv victim = do removeMemberQualified zusr con (qUntagged lcnv) (qUntagged lvictim) removeMemberQualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -1025,7 +1052,7 @@ removeMemberQualified zusr con qcnv victim = do foldQualified lusr removeMemberFromLocalConv removeMemberFromRemoteConv qcnv lusr (Just con) victim removeMemberFromRemoteConv :: - Member FederatorAccess r => + Members '[FederatorAccess] r => Remote ConvId -> Local UserId -> Maybe ConnId -> @@ -1049,20 +1076,19 @@ removeMemberFromRemoteConv cnv lusr _ victim <$> E.runFederated cnv rpc | otherwise = pure . Left $ RemoveFromConversationErrorRemovalNotAllowed -performRemoveMemberAction :: - Member MemberStore r => - Data.Conversation -> - [Qualified UserId] -> - MaybeT (Galley r) () -performRemoveMemberAction conv victims = do - loc <- qualifyLocal () - let presentVictims = filter (isConvMember loc conv) victims - guard . not . null $ presentVictims - lift . liftSem $ E.deleteMembers (Data.convId conv) (toUserList loc presentVictims) - -- | Remove a member from a local conversation. removeMemberFromLocalConv :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => Local ConvId -> Local UserId -> Maybe ConnId -> @@ -1073,7 +1099,7 @@ removeMemberFromLocalConv lcnv lusr con victim = fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) . runMaybeT . updateLocalConversation lcnv (qUntagged lusr) con - . ConversationActionRemoveMembers + . ConversationLeave . pure $ victim @@ -1082,15 +1108,23 @@ removeMemberFromLocalConv lcnv lusr con victim = data OtrResult = OtrSent !Public.ClientMismatch | OtrMissingRecipients !Public.ClientMismatch - | OtrUnknownClient !Public.UnknownClient - | OtrConversationNotFound !Public.ConvNotFound + | OtrUnknownClient !UnknownClient + | OtrConversationNotFound !ConvNotFound -handleOtrResult :: OtrResult -> Galley r Response -handleOtrResult = \case - OtrSent m -> pure $ json m & setStatus status201 - OtrMissingRecipients m -> pure $ json m & setStatus status412 - OtrUnknownClient _ -> throwErrorDescriptionType @UnknownClient - OtrConversationNotFound _ -> throwErrorDescriptionType @ConvNotFound +handleOtrResult :: + Members + '[ Error ClientError, + Error ConversationError + ] + r => + OtrResult -> + Galley r Response +handleOtrResult = + liftSem . \case + OtrSent m -> pure $ json m & setStatus status201 + OtrMissingRecipients m -> pure $ json m & setStatus status412 + OtrUnknownClient _ -> throw UnknownClient + OtrConversationNotFound _ -> throw ConvNotFound postBotMessageH :: Members @@ -1098,6 +1132,10 @@ postBotMessageH :: BrigAccess, ClientStore, ConversationStore, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, FederatorAccess, GundeckAccess, ExternalAccess, @@ -1118,9 +1156,10 @@ postBotMessage :: BrigAccess, ClientStore, ConversationStore, + Error LegalHoldError, + ExternalAccess, FederatorAccess, GundeckAccess, - ExternalAccess, MemberStore, TeamStore ] @@ -1130,8 +1169,7 @@ postBotMessage :: Public.OtrFilterMissing -> Public.NewOtrMessage -> Galley r OtrResult -postBotMessage zbot zcnv val message = - postNewOtrMessage Bot (botUserId zbot) Nothing zcnv val message +postBotMessage zbot = postNewOtrMessage Bot (botUserId zbot) Nothing postProteusMessage :: Members @@ -1206,7 +1244,20 @@ postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do <$> postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage postProtoOtrBroadcastH :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> Galley r Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do @@ -1215,7 +1266,20 @@ postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcastH :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> Galley r Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do @@ -1224,7 +1288,17 @@ postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcast :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> Public.OtrFilterMissing -> @@ -1244,7 +1318,17 @@ allowOtrFilterMissingInBody val (NewOtrMessage _ _ _ _ _ _ mrepmiss) = case mrep -- | bots are not supported on broadcast postNewOtrBroadcast :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId -> Maybe ConnId -> OtrFilterMissing -> @@ -1266,6 +1350,7 @@ postNewOtrMessage :: BrigAccess, ClientStore, ConversationStore, + Error LegalHoldError, ExternalAccess, GundeckAccess, MemberStore, @@ -1327,7 +1412,17 @@ newMessage qusr con qcnv msg now (m, c, t) ~(toBots, toUsers) = in (toBots, p : toUsers) updateConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -1338,12 +1433,21 @@ updateConversationName zusr zcon qcnv convRename = do foldQualified lusr (updateLocalConversationName lusr zcon) - (\_ _ -> throwM federationNotImplemented) + (\_ _ -> liftSem (throw FederationNotImplemented)) qcnv convRename updateUnqualifiedConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -1355,7 +1459,16 @@ updateUnqualifiedConversationName zusr zcon cnv rename = do updateLocalConversationName lusr zcon lcnv rename updateLocalConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> @@ -1368,7 +1481,16 @@ updateLocalConversationName lusr zcon lcnv convRename = do else liftSem $ Nothing <$ E.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> @@ -1376,33 +1498,16 @@ updateLiveLocalConversationName :: Galley r (Maybe Public.Event) updateLiveLocalConversationName lusr con lcnv rename = runMaybeT $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionRename rename - -notifyConversationMetadataUpdate :: - Members '[FederatorAccess, ExternalAccess, GundeckAccess] r => - Qualified UserId -> - Maybe ConnId -> - Local ConvId -> - BotsAndMembers -> - ConversationAction -> - Galley r Event -notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = do - localDomain <- viewFederationDomain - now <- liftIO getCurrentTime - let e = conversationActionToEvent now quid qcnv action - - -- notify remote participants - liftSem $ - E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> - FederatedGalley.onConversationUpdated FederatedGalley.clientRoutes localDomain $ - FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action - - -- notify local participants and bots - pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e + updateLocalConversation lcnv (qUntagged lusr) (Just con) rename isTypingH :: - Members '[GundeckAccess, MemberStore] r => + Members + '[ Error ConversationError, + Error InvalidInput, + GundeckAccess, + MemberStore + ] + r => UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> Galley r Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do @@ -1411,7 +1516,7 @@ isTypingH (zusr ::: zcon ::: cnv ::: req) = do pure empty isTyping :: - Members '[GundeckAccess, MemberStore] r => + Members '[Error ConversationError, GundeckAccess, MemberStore] r => UserId -> ConnId -> ConvId -> @@ -1422,8 +1527,7 @@ isTyping zusr zcon cnv typingData = do let qcnv = Qualified cnv localDomain qusr = Qualified zusr localDomain mm <- liftSem $ E.getLocalMembers cnv - unless (zusr `isMember` mm) $ - throwErrorDescriptionType @ConvNotFound + liftSem . unless (zusr `isMember` mm) . throw $ ConvNotFound now <- liftIO getCurrentTime let e = Event Typing qcnv qusr now (EdTyping typingData) for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> mm)) $ \p -> @@ -1433,12 +1537,22 @@ isTyping zusr zcon cnv typingData = do & pushRoute .~ RouteDirect & pushTransient .~ True -addServiceH :: Member ServiceStore r => JsonRequest Service -> Galley r Response +addServiceH :: + Members + '[ Error InvalidInput, + ServiceStore + ] + r => + JsonRequest Service -> + Galley r Response addServiceH req = do liftSem . E.createService =<< fromJsonBody req return empty -rmServiceH :: Member ServiceStore r => JsonRequest ServiceRef -> Galley r Response +rmServiceH :: + Members '[Error InvalidInput, ServiceStore] r => + JsonRequest ServiceRef -> + Galley r Response rmServiceH req = do liftSem . E.deleteService =<< fromJsonBody req return empty @@ -1447,6 +1561,9 @@ addBotH :: Members '[ ClientStore, ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, ExternalAccess, GundeckAccess, MemberStore, @@ -1464,6 +1581,9 @@ addBot :: Members '[ ClientStore, ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, ExternalAccess, GundeckAccess, MemberStore, @@ -1477,8 +1597,7 @@ addBot :: addBot zusr zcon b = do lusr <- qualifyLocal zusr c <- - liftSem (E.getConversation (b ^. addBotConv)) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + liftSem $ E.getConversation (b ^. addBotConv) >>= note ConvNotFound -- Check some preconditions on adding bots to a conversation for_ (Data.convTeam c) $ teamConvChecks (b ^. addBotConv) (bots, users) <- regularConvChecks lusr c @@ -1506,10 +1625,10 @@ addBot zusr zcon b = do where regularConvChecks lusr c = do let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) - unless (zusr `isMember` users) $ - throwErrorDescriptionType @ConvNotFound - ensureGroupConvThrowing c - ensureActionAllowed AddConversationMember =<< getSelfMemberFromLocalsLegacy zusr users + liftSem . unless (zusr `isMember` users) . throw $ ConvNotFound + liftSem $ ensureGroupConversation c + self <- getSelfMemberFromLocals zusr users + ensureActionAllowed AddConversationMember self unless (any ((== b ^. addBotId) . botMemId) bots) $ do let botId = qualifyAs lusr (botUserId (b ^. addBotId)) ensureMemberLimit (toList $ Data.convLocalMembers c) [qUntagged botId] @@ -1517,11 +1636,21 @@ addBot zusr zcon b = do teamConvChecks :: ConvId -> TeamId -> Galley r () teamConvChecks cid tid = do tcv <- liftSem $ E.getTeamConversation tid cid - when (maybe True (view managedConversation) tcv) $ - throwM noAddToManaged + liftSem $ + when (maybe True (view managedConversation) tcv) $ + throw NoAddToManaged rmBotH :: - Members '[ClientStore, ConversationStore, ExternalAccess, GundeckAccess, MemberStore] r => + Members + '[ ClientStore, + ConversationStore, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley r Response rmBotH (zusr ::: zcon ::: req) = do @@ -1529,20 +1658,27 @@ rmBotH (zusr ::: zcon ::: req) = do handleUpdateResult <$> rmBot zusr zcon bot rmBot :: - Members '[ClientStore, ConversationStore, ExternalAccess, GundeckAccess, MemberStore] r => + Members + '[ ClientStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> Maybe ConnId -> RemoveBot -> Galley r (UpdateResult Event) rmBot zusr zcon b = do c <- - liftSem (E.getConversation (b ^. rmBotConv)) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + liftSem $ E.getConversation (b ^. rmBotConv) >>= note ConvNotFound localDomain <- viewFederationDomain let qcnv = Qualified (Data.convId c) localDomain qusr = Qualified zusr localDomain - unless (zusr `isMember` Data.convLocalMembers c) $ - throwErrorDescriptionType @ConvNotFound + liftSem . unless (zusr `isMember` Data.convLocalMembers c) $ + throw ConvNotFound let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) if not (any ((== b ^. rmBotId) . botMemId) bots) then pure Unchanged @@ -1561,17 +1697,10 @@ rmBot zusr zcon b = do ------------------------------------------------------------------------------- -- Helpers -ensureMemberLimit :: Foldable f => [LocalMember] -> f a -> Galley r () -ensureMemberLimit old new = do - o <- view options - let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) - when (length old + length new > maxSize) $ - throwM tooManyMembers - -ensureConvMember :: [LocalMember] -> UserId -> Galley r () +ensureConvMember :: Member (Error ConversationError) r => [LocalMember] -> UserId -> Galley r () ensureConvMember users usr = - unless (usr `isMember` users) $ - throwErrorDescriptionType @ConvNotFound + liftSem $ + unless (usr `isMember` users) $ throw ConvNotFound ------------------------------------------------------------------------------- -- OtrRecipients Validation @@ -1589,7 +1718,17 @@ data CheckedOtrRecipients -- | bots are not supported on broadcast withValidOtrBroadcastRecipients :: - Members '[BrigAccess, ClientStore, TeamStore] r => + forall r. + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + TeamStore + ] + r => UserId -> ClientId -> OtrRecipients -> @@ -1600,8 +1739,8 @@ withValidOtrBroadcastRecipients :: withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ \tid -> do limit <- fromIntegral . fromRange <$> fanoutLimit -- If we are going to fan this out to more than limit, we want to fail early - unless (Map.size (userClientMap (otrRecipientsMap rcps)) <= limit) $ - throwM broadcastLimitExceeded + liftSem . unless (Map.size (userClientMap (otrRecipientsMap rcps)) <= limit) $ + throw BroadcastLimitExceeded -- In large teams, we may still use the broadcast endpoint but only if `report_missing` -- is used and length `report_missing` < limit since we cannot fetch larger teams than -- that. @@ -1625,17 +1764,26 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ let localUserIdsInFilter = toList uListInFilter let localUserIdsInRcps = Map.keys $ userClientMap (otrRecipientsMap rcps) let localUserIdsToLookup = Set.toList $ Set.union (Set.fromList localUserIdsInFilter) (Set.fromList localUserIdsInRcps) - unless (length localUserIdsToLookup <= limit) $ - throwM broadcastLimitExceeded + liftSem . unless (length localUserIdsToLookup <= limit) $ + throw BroadcastLimitExceeded liftSem $ E.selectTeamMembers tid localUserIdsToLookup + maybeFetchAllMembersInTeam :: TeamId -> Galley r [TeamMember] maybeFetchAllMembersInTeam tid = do mems <- getTeamMembersForFanout tid - when (mems ^. teamMemberListType == ListTruncated) $ - throwM broadcastLimitExceeded + liftSem . when (mems ^. teamMemberListType == ListTruncated) $ + throw BroadcastLimitExceeded pure (mems ^. teamMembers) withValidOtrRecipients :: - Members '[BrigAccess, ClientStore, ConversationStore, MemberStore, TeamStore] r => + Members + '[ BrigAccess, + ClientStore, + ConversationStore, + Error LegalHoldError, + MemberStore, + TeamStore + ] + r => UserType -> UserId -> ClientId -> @@ -1663,7 +1811,7 @@ withValidOtrRecipients utype usr clt cnv rcps val now go = do handleOtrResponse utype usr clt rcps localMembers clts val now go handleOtrResponse :: - Members '[BrigAccess, TeamStore] r => + Members '[BrigAccess, Error LegalHoldError, TeamStore] r => -- | Type of proposed sender (user / bot) UserType -> -- | Proposed sender (user) @@ -1687,7 +1835,7 @@ handleOtrResponse utype usr clt rcps membs clts val now go = case checkOtrRecipi ValidOtrRecipients m r -> go r >> pure (OtrSent m) MissingOtrRecipients m -> do guardLegalholdPolicyConflicts (userToProtectee utype usr) (missingClients m) - >>= either (const (throwErrorDescriptionType @MissingLegalholdConsent)) pure + >>= either (const (liftSem . throw $ MissingLegalholdConsent)) pure pure (OtrMissingRecipients m) InvalidOtrSenderUser -> pure $ OtrConversationNotFound mkErrorDescription InvalidOtrSenderClient -> pure $ OtrUnknownClient mkErrorDescription @@ -1775,10 +1923,18 @@ checkOtrRecipients usr sid prs vms vcs val now OtrIgnoreMissing us -> Clients.filter (`Set.notMember` us) miss -- Copied from 'Galley.API.Team' to break import cycles -withBindingTeam :: Member TeamStore r => UserId -> (TeamId -> Galley r b) -> Galley r b +withBindingTeam :: + Members + '[ Error TeamError, + TeamStore + ] + r => + UserId -> + (TeamId -> Galley r b) -> + Galley r b withBindingTeam zusr callback = do - tid <- liftSem (E.getOneUserTeam zusr) >>= ifNothing teamNotFound - binding <- liftSem (E.getTeamBinding tid) >>= ifNothing teamNotFound + tid <- liftSem $ E.getOneUserTeam zusr >>= note TeamNotFound + binding <- liftSem $ E.getTeamBinding tid >>= note TeamNotFound case binding of Binding -> callback tid - NonBinding -> throwM nonBindingTeam + NonBinding -> liftSem $ throw NotABindingTeamMember diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 5f434712e39..f76e4ff748b 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -23,11 +23,8 @@ module Galley.API.Util where import Brig.Types (Relation (..)) import Brig.Types.Intra (ReAuthUser (..)) import Control.Arrow (Arrow (second), second) -import Control.Error (ExceptT, hoistEither, note) import Control.Lens (set, view, (.~), (^.)) -import Control.Monad.Catch -import Control.Monad.Except (runExceptT) -import Control.Monad.Extra (allM, anyM, eitherM) +import Control.Monad.Extra (allM, anyM) import Data.ByteString.Conversion import Data.Domain (Domain) import Data.Id as Id @@ -37,7 +34,6 @@ import qualified Data.Map as Map import Data.Misc (PlainTextPassword (..)) import Data.Qualified import qualified Data.Set as Set -import qualified Data.Text.Lazy as LT import Data.Time import Galley.API.Error import Galley.App @@ -55,7 +51,7 @@ import Galley.Effects.LegalHoldStore import Galley.Effects.MemberStore import Galley.Effects.TeamStore import Galley.Intra.Push -import Galley.Options (optSettings, setFeatureFlags, setFederationDomain) +import Galley.Options import Galley.Types import Galley.Types.Conversations.Members (localMemberToOther, remoteMemberToOther) import Galley.Types.Conversations.Roles @@ -65,25 +61,30 @@ import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error) -import Network.Wai.Utilities +import qualified Network.Wai.Utilities as Wai +import Polysemy +import Polysemy.Error import qualified Wire.API.Conversation as Public -import Wire.API.Conversation.Action (ConversationAction (..), conversationActionTag) import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Error (federationNotImplemented) +import Wire.API.Federation.Client type JSON = Media "application" "json" -ensureAccessRole :: Member BrigAccess r => AccessRole -> [(UserId, Maybe TeamMember)] -> Galley r () -ensureAccessRole role users = case role of - PrivateAccessRole -> throwErrorDescriptionType @ConvAccessDenied +ensureAccessRole :: + Members '[BrigAccess, Error NotATeamMember, Error ConversationError] r => + AccessRole -> + [(UserId, Maybe TeamMember)] -> + Galley r () +ensureAccessRole role users = liftSem $ case role of + PrivateAccessRole -> throw ConvAccessDenied TeamAccessRole -> when (any (isNothing . snd) users) $ - throwErrorDescriptionType @NotATeamMember + throwED @NotATeamMember ActivatedAccessRole -> do - activated <- liftSem $ lookupActivatedUsers $ map fst users + activated <- lookupActivatedUsers $ map fst users when (length activated /= length users) $ - throwErrorDescriptionType @ConvAccessDenied + throw ConvAccessDenied NonActivatedAccessRole -> return () -- | Check that the given user is either part of the same team(s) as the other @@ -92,170 +93,148 @@ ensureAccessRole role users = case role of -- Team members are always considered connected, so we only check 'ensureConnected' -- for non-team-members of the _given_ user ensureConnectedOrSameTeam :: - Members '[BrigAccess, TeamStore] r => - Qualified UserId -> + Members '[BrigAccess, TeamStore, Error ActionError] r => + Local UserId -> [UserId] -> Galley r () ensureConnectedOrSameTeam _ [] = pure () -ensureConnectedOrSameTeam (Qualified u domain) uids = do - -- FUTUREWORK(federation, #1262): handle remote users (can't be part of the same team, just check connections) - localDomain <- viewFederationDomain - when (localDomain == domain) $ do - uTeams <- liftSem $ getUserTeams u - -- We collect all the relevant uids from same teams as the origin user - sameTeamUids <- liftSem . forM uTeams $ \team -> - fmap (view userId) <$> selectTeamMembers team uids - -- Do not check connections for users that are on the same team - ensureConnectedToLocals u (uids \\ join sameTeamUids) +ensureConnectedOrSameTeam (tUnqualified -> u) uids = do + uTeams <- liftSem $ getUserTeams u + -- We collect all the relevant uids from same teams as the origin user + sameTeamUids <- liftSem . forM uTeams $ \team -> + fmap (view userId) <$> selectTeamMembers team uids + -- Do not check connections for users that are on the same team + ensureConnectedToLocals u (uids \\ join sameTeamUids) -- | Check that the user is connected to everybody else. -- -- The connection has to be bidirectional (e.g. if A connects to B and later -- B blocks A, the status of A-to-B is still 'Accepted' but it doesn't mean -- that they are connected). -ensureConnected :: Member BrigAccess r => Local UserId -> UserList UserId -> Galley r () +ensureConnected :: + Members '[BrigAccess, Error ActionError] r => + Local UserId -> + UserList UserId -> + Galley r () ensureConnected self others = do ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToRemotes self (ulRemotes others) -ensureConnectedToLocals :: Member BrigAccess r => UserId -> [UserId] -> Galley r () +ensureConnectedToLocals :: + Members '[BrigAccess, Error ActionError] r => + UserId -> + [UserId] -> + Galley r () ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = do +ensureConnectedToLocals u uids = liftSem $ do (connsFrom, connsTo) <- - liftSem $ - getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) + getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) unless (length connsFrom == length uids && length connsTo == length uids) $ - throwErrorDescriptionType @NotConnected + throw NotConnected -ensureConnectedToRemotes :: Member BrigAccess r => Local UserId -> [Remote UserId] -> Galley r () +ensureConnectedToRemotes :: + Members '[BrigAccess, Error ActionError] r => + Local UserId -> + [Remote UserId] -> + Galley r () ensureConnectedToRemotes _ [] = pure () -ensureConnectedToRemotes u remotes = do - acceptedConns <- - liftSem $ - getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) +ensureConnectedToRemotes u remotes = liftSem $ do + acceptedConns <- getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) when (length acceptedConns /= length remotes) $ - throwErrorDescriptionType @NotConnected - -ensureReAuthorised :: Member BrigAccess r => UserId -> Maybe PlainTextPassword -> Galley r () -ensureReAuthorised u secret = do - reAuthed <- liftSem $ reauthUser u (ReAuthUser secret) + throw NotConnected + +ensureReAuthorised :: + Members + '[ BrigAccess, + Error AuthenticationError + ] + r => + UserId -> + Maybe PlainTextPassword -> + Galley r () +ensureReAuthorised u secret = liftSem $ do + reAuthed <- reauthUser u (ReAuthUser secret) unless reAuthed $ - throwM reAuthFailed + throw ReAuthFailed -- | Given a member in a conversation, check if the given action -- is permitted. If the user does not have the given permission, throw -- 'operationDenied'. -ensureActionAllowed :: IsConvMember mem => Action -> mem -> Galley r () -ensureActionAllowed action self = case isActionAllowed action (convMemberRole self) of +ensureActionAllowed :: + (IsConvMember mem, Members '[Error ActionError, Error InvalidInput] r) => + Action -> + mem -> + Galley r () +ensureActionAllowed action self = liftSem $ case isActionAllowed action (convMemberRole self) of Just True -> pure () - Just False -> throwErrorDescription (actionDenied action) + Just False -> throw (ActionDenied action) -- Actually, this will "never" happen due to the -- fact that there can be no custom roles at the moment - Nothing -> throwM (badRequest "Custom roles not supported") + Nothing -> throw CustomRolesNotSupported --- | Comprehensive permission check, taking action-specific logic into account. -ensureConversationActionAllowed :: - (IsConvMember mem, Member TeamStore r) => - ConversationAction -> - Data.Conversation -> - mem -> - Galley r () -ensureConversationActionAllowed action conv self = do - loc <- qualifyLocal () - let tag = conversationActionTag (convMemberId loc self) action - -- general action check - ensureActionAllowed tag self - -- check if it is a group conversation (except for rename actions) - when (tag /= ModifyConversationName) $ - ensureGroupConvThrowing conv - -- extra action-specific checks - case action of - ConversationActionAddMembers _ role -> ensureConvRoleNotElevated self role - ConversationActionDelete -> do - case Data.convTeam conv of - Just tid -> do - foldQualified - loc - ( \lusr -> do - void $ - liftSem (getTeamMember tid (tUnqualified lusr)) - >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) - ) - (\_ -> throwM federationNotImplemented) - (convMemberId loc self) - Nothing -> pure () - ConversationActionAccessUpdate target -> do - -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and - -- so on; users are not supposed to be able to make other conversations - -- have 'PrivateAccessRole' - when - ( PrivateAccess `elem` Public.cupAccess target - || PrivateAccessRole == Public.cupAccessRole target - ) - $ throwErrorDescriptionType @InvalidTargetAccess - -- Team conversations incur another round of checks - case Data.convTeam conv of - Just tid -> do - -- Access mode change for managed conversation is not allowed - tcv <- liftSem $ getTeamConversation tid (Data.convId conv) - when (maybe False (view managedConversation) tcv) $ - throwM invalidManagedConvOp - -- Access mode change might result in members being removed from the - -- conversation, so the user must have the necessary permission flag - ensureActionAllowed RemoveConversationMember self - Nothing -> - when (Public.cupAccessRole target == TeamAccessRole) $ - throwErrorDescriptionType @InvalidTargetAccess - _ -> pure () - -ensureGroupConvThrowing :: Data.Conversation -> Galley r () -ensureGroupConvThrowing conv = case Data.convType conv of - SelfConv -> throwM invalidSelfOp - One2OneConv -> throwM invalidOne2OneOp - ConnectConv -> throwM invalidConnectOp - _ -> pure () +ensureGroupConversation :: Member (Error ActionError) r => Data.Conversation -> Sem r () +ensureGroupConversation conv = do + let ty = Data.convType conv + when (ty /= RegularConv) $ throw (InvalidOp ty) -- | Ensure that the set of actions provided are not "greater" than the user's -- own. This is used to ensure users cannot "elevate" allowed actions -- This function needs to be review when custom roles are introduced since only -- custom roles can cause `roleNameToActions` to return a Nothing -ensureConvRoleNotElevated :: IsConvMember mem => mem -> RoleName -> Galley r () -ensureConvRoleNotElevated origMember targetRole = do +ensureConvRoleNotElevated :: + (IsConvMember mem, Members '[Error InvalidInput, Error ActionError] r) => + mem -> + RoleName -> + Galley r () +ensureConvRoleNotElevated origMember targetRole = liftSem $ do case (roleNameToActions targetRole, roleNameToActions (convMemberRole origMember)) of (Just targetActions, Just memberActions) -> unless (Set.isSubsetOf targetActions memberActions) $ - throwM invalidActions + throw InvalidAction (_, _) -> - throwM (badRequest "Custom roles not supported") + throw CustomRolesNotSupported -- | If a team member is not given throw 'notATeamMember'; if the given team -- member does not have the given permission, throw 'operationDenied'. -- Otherwise, return the team member. -permissionCheck :: (IsPerm perm, Show perm) => perm -> Maybe TeamMember -> Galley r TeamMember -permissionCheck p = \case - Just m -> do - if m `hasPermission` p - then pure m - else throwErrorDescription (operationDenied p) - Nothing -> throwErrorDescriptionType @NotATeamMember - -assertTeamExists :: Members '[TeamStore] r => TeamId -> Galley r () -assertTeamExists tid = do - teamExists <- liftSem $ isJust <$> getTeam tid +permissionCheck :: + (IsPerm perm, Show perm, Members '[Error ActionError, Error NotATeamMember] r) => + perm -> + Maybe TeamMember -> + Galley r TeamMember +permissionCheck p = + liftSem . \case + Just m -> do + if m `hasPermission` p + then pure m + else throw (OperationDenied (show p)) + Nothing -> throwED @NotATeamMember + +assertTeamExists :: Members '[Error TeamError, TeamStore] r => TeamId -> Galley r () +assertTeamExists tid = liftSem $ do + teamExists <- isJust <$> getTeam tid if teamExists then pure () - else throwM teamNotFound + else throw TeamNotFound -assertOnTeam :: Members '[TeamStore] r => UserId -> TeamId -> Galley r () -assertOnTeam uid tid = do - liftSem (getTeamMember tid uid) >>= \case - Nothing -> throwErrorDescriptionType @NotATeamMember - Just _ -> return () +assertOnTeam :: Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r () +assertOnTeam uid tid = + liftSem $ + getTeamMember tid uid >>= \case + Nothing -> throwED @NotATeamMember + Just _ -> return () -- | If the conversation is in a team, throw iff zusr is a team member and does not have named -- permission. If the conversation is not in a team, do nothing (no error). permissionCheckTeamConv :: - Members '[ConversationStore, TeamStore] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> ConvId -> Perm -> @@ -265,11 +244,19 @@ permissionCheckTeamConv zusr cnv perm = Just cnv' -> case Data.convTeam cnv' of Just tid -> void $ permissionCheck perm =<< liftSem (getTeamMember tid zusr) Nothing -> pure () - Nothing -> throwErrorDescriptionType @ConvNotFound + Nothing -> liftSem $ throw ConvNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: - Members '[ConversationStore, MemberStore, GundeckAccess] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + MemberStore, + GundeckAccess + ] + r => UserId -> Data.Conversation -> Maybe ConnId -> @@ -286,10 +273,10 @@ acceptOne2One usr conv conn = do return $ conv {Data.convLocalMembers = mems <> toList mm} ConnectConv -> case mems of [_, _] | usr `isMember` mems -> liftSem promote - [_, _] -> throwErrorDescriptionType @ConvNotFound + [_, _] -> liftSem $ throw ConvNotFound _ -> do when (length mems > 2) $ - throwM badConvState + liftSem . throw . BadConvState $ cid now <- liftIO getCurrentTime mm <- liftSem $ createMember lcid lusr let e = memberJoinEvent lusr (qUntagged lcid) now mm [] @@ -298,17 +285,13 @@ acceptOne2One usr conv conn = do for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> mems')) $ \p -> liftSem $ push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect return $ conv' {Data.convLocalMembers = mems'} - _ -> throwM $ invalidOp "accept: invalid conversation type" + x -> liftSem . throw . InvalidOp $ x where cid = Data.convId conv mems = Data.convLocalMembers conv promote = do acceptConnectConversation cid return $ conv {Data.convType = One2OneConv} - badConvState = - mkError status500 "bad-state" $ - "Connect conversation with more than 2 members: " - <> LT.pack (show cid) memberJoinEvent :: Local UserId -> @@ -449,7 +432,7 @@ localBotsAndUsers = foldMap botOrUser Nothing -> ([], [m]) location :: ToByteString a => a -> Response -> Response -location = addHeader hLocation . toByteString' +location = Wai.addHeader hLocation . toByteString' nonTeamMembers :: [LocalMember] -> [TeamMember] -> [LocalMember] nonTeamMembers cm tm = filter (not . isMemberOfTeam . lmId) cm @@ -468,40 +451,42 @@ membersToRecipients :: Maybe UserId -> [TeamMember] -> [Recipient] membersToRecipients Nothing = map (userRecipient . view userId) membersToRecipients (Just u) = map userRecipient . filter (/= u) . map (view userId) --- | A legacy version of 'getSelfMemberFromLocals' that runs in the Galley r monad. -getSelfMemberFromLocalsLegacy :: - Foldable t => +getSelfMemberFromLocals :: + (Foldable t, Member (Error ConversationError) r) => UserId -> t LocalMember -> Galley r LocalMember -getSelfMemberFromLocalsLegacy usr lmems = - eitherM throwErrorDescription pure . runExceptT $ - getMember lmId (mkErrorDescription :: ConvNotFound) usr lmems +getSelfMemberFromLocals usr lmems = + liftSem $ getMember lmId ConvNotFound usr lmems -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). ensureOtherMember :: + Member (Error ConversationError) r => Local a -> Qualified UserId -> Data.Conversation -> - Galley r (Either LocalMember RemoteMember) + Sem r (Either LocalMember RemoteMember) ensureOtherMember loc quid conv = - maybe (throwErrorDescriptionType @ConvMemberNotFound) pure $ - (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) - <|> (Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv)) - -getSelfMemberFromRemotesLegacy :: Foldable t => Remote UserId -> t RemoteMember -> Galley r RemoteMember -getSelfMemberFromRemotesLegacy usr rmems = - eitherM throwErrorDescription pure . runExceptT $ - getMember rmId (mkErrorDescription :: ConvNotFound) usr rmems + note ConvMemberNotFound $ + Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv) + <|> Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv) + +getSelfMemberFromRemotes :: + (Foldable t, Member (Error ConversationError) r) => + Remote UserId -> + t RemoteMember -> + Galley r RemoteMember +getSelfMemberFromRemotes usr rmems = + liftSem $ getMember rmId ConvNotFound usr rmems getQualifiedMember :: - Monad m => + Member (Error e) r => Local x -> e -> Qualified UserId -> Data.Conversation -> - ExceptT e m (Either LocalMember RemoteMember) + Sem r (Either LocalMember RemoteMember) getQualifiedMember loc e qusr conv = foldQualified loc @@ -510,7 +495,7 @@ getQualifiedMember loc e qusr conv = qusr getMember :: - (Foldable t, Eq userId, Monad m) => + (Foldable t, Eq userId, Member (Error e) r) => -- | A projection from a member type to its user ID (mem -> userId) -> -- | An error to throw in case the user is not in the list @@ -519,39 +504,35 @@ getMember :: userId -> -- | A list of members to search t mem -> - ExceptT e m mem -getMember p ex u = hoistEither . note ex . find ((u ==) . p) + Sem r mem +getMember p ex u = note ex . find ((u ==) . p) getConversationAndCheckMembership :: - Member ConversationStore r => + Members '[ConversationStore, Error ConversationError] r => UserId -> ConvId -> Galley r Data.Conversation getConversationAndCheckMembership uid cnv = do (conv, _) <- getConversationAndMemberWithError - (errorDescriptionTypeToWai @ConvAccessDenied) + ConvAccessDenied uid cnv pure conv getConversationAndMemberWithError :: - (Member ConversationStore r, IsConvMemberId uid mem) => - Error -> + (Members '[ConversationStore, Error ConversationError] r, IsConvMemberId uid mem) => + ConversationError -> uid -> ConvId -> Galley r (Data.Conversation, mem) getConversationAndMemberWithError ex usr convId = do - c <- - liftSem (getConversation convId) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) - when (DataTypes.isConvDeleted c) $ do - liftSem $ deleteConversation convId - throwErrorDescriptionType @ConvNotFound + c <- liftSem $ getConversation convId >>= note ConvNotFound + liftSem . when (DataTypes.isConvDeleted c) $ do + deleteConversation convId + throw ConvNotFound loc <- qualifyLocal () - member <- - either throwM pure . note ex $ - getConvMember loc c usr + member <- liftSem . note ex $ getConvMember loc c usr pure (c, member) -- | Deletion requires a permission check, but also a 'Role' comparison: @@ -586,38 +567,55 @@ pushConversationEvent conn e users bots = do liftSem $ deliverAsync (toList bots `zip` repeat e) verifyReusableCode :: - Member CodeStore r => + Members '[CodeStore, Error CodeError] r => ConversationCode -> Galley r DataTypes.Code verifyReusableCode convCode = do c <- - liftSem (getCode (conversationKey convCode) DataTypes.ReusableCode) - >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) + liftSem $ + getCode (conversationKey convCode) DataTypes.ReusableCode + >>= note CodeNotFound unless (DataTypes.codeValue c == conversationCode convCode) $ - throwM (errorDescriptionTypeToWai @CodeNotFound) + liftSem $ throw CodeNotFound return c ensureConversationAccess :: - Members '[BrigAccess, ConversationStore, TeamStore] r => + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> ConvId -> Access -> Galley r Data.Conversation ensureConversationAccess zusr cnv access = do conv <- - liftSem (getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) - ensureAccess conv access + liftSem $ + getConversation cnv >>= note ConvNotFound + liftSem $ ensureAccess conv access zusrMembership <- liftSem $ maybe (pure Nothing) (`getTeamMember` zusr) (Data.convTeam conv) ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] pure conv -ensureAccess :: Data.Conversation -> Access -> Galley r () +ensureAccess :: + Member (Error ConversationError) r => + Data.Conversation -> + Access -> + Sem r () ensureAccess conv access = unless (access `elem` Data.convAccess conv) $ - throwErrorDescriptionType @ConvAccessDenied + throw ConvAccessDenied + +ensureLocal :: Member (Error FederationError) r => Local x -> Qualified a -> Sem r (Local a) +ensureLocal loc = foldQualified loc pure (\_ -> throw FederationNotImplemented) -------------------------------------------------------------------------------- -- Federation @@ -833,3 +831,10 @@ getTeamMembersForFanout :: Member TeamStore r => TeamId -> Galley r TeamMemberLi getTeamMembersForFanout tid = do lim <- fanoutLimit liftSem $ getTeamMembersWithLimit tid lim + +ensureMemberLimit :: (Foldable f, Member (Error ConversationError) r) => [LocalMember] -> f a -> Galley r () +ensureMemberLimit old new = do + o <- view options + let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) + liftSem . when (length old + length new > maxSize) $ + throw TooManyMembers diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index bdb74e49923..5d512b05f92 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -46,18 +46,18 @@ module Galley.App toServantHandler, -- * Utilities - ifNothing, fromJsonBody, fromOptionalJsonBody, fromProtoBody, fanoutLimit, currentFanoutLimit, - -- * MonadUnliftIO / Sem compatibility + -- * Temporary compatibility functions fireAndForget, spawnMany, liftGalley0, liftSem, + unGalley, interpretGalleyToGalley0, ) where @@ -116,11 +116,12 @@ import Network.HTTP.Types (hContentType) import Network.HTTP.Types.Status (statusCode, statusMessage) import Network.Wai import Network.Wai.Utilities hiding (Error) -import qualified Network.Wai.Utilities as WaiError +import qualified Network.Wai.Utilities as Wai import qualified Network.Wai.Utilities.Server as Server import OpenSSL.Session as Ssl import qualified OpenSSL.X509.SystemStore as Ssl import Polysemy +import Polysemy.Error import Polysemy.Internal (Append) import qualified Polysemy.Reader as P import qualified Polysemy.TinyLog as P @@ -156,9 +157,6 @@ instance Monad (Galley r) where instance MonadIO (Galley r) where liftIO action = Galley (liftIO action) -instance MonadThrow (Galley r) where - throwM e = Galley (embed @IO (throwM e)) - instance MonadReader Env (Galley r) where ask = Galley $ P.ask @Env local f m = Galley $ P.local f (unGalley m) @@ -278,24 +276,25 @@ evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders -fromJsonBody :: FromJSON a => JsonRequest a -> Galley r a -fromJsonBody r = exceptT (throwM . invalidPayload) return (parseBody r) +fromJsonBody :: (Member (Error InvalidInput) r, FromJSON a) => JsonRequest a -> Galley r a +fromJsonBody r = exceptT (liftSem . throw . InvalidPayload) return (parseBody r) {-# INLINE fromJsonBody #-} -fromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> Galley r (Maybe a) -fromOptionalJsonBody r = exceptT (throwM . invalidPayload) return (parseOptionalBody r) +fromOptionalJsonBody :: + ( Member (Error InvalidInput) r, + FromJSON a + ) => + OptionalJsonRequest a -> + Galley r (Maybe a) +fromOptionalJsonBody r = exceptT (liftSem . throw . InvalidPayload) return (parseOptionalBody r) {-# INLINE fromOptionalJsonBody #-} -fromProtoBody :: Proto.Decode a => Request -> Galley r a +fromProtoBody :: (Member (Error InvalidInput) r, Proto.Decode a) => Request -> Galley r a fromProtoBody r = do b <- readBody r - either (throwM . invalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) + either (liftSem . throw . InvalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) {-# INLINE fromProtoBody #-} -ifNothing :: WaiError.Error -> Maybe a -> Galley r a -ifNothing e = maybe (throwM e) return -{-# INLINE ifNothing #-} - toServantHandler :: Env -> Galley GalleyEffects a -> Servant.Handler a toServantHandler env galley = do eith <- liftIO $ Control.Exception.try (evalGalley env galley) @@ -304,14 +303,14 @@ toServantHandler env galley = do handleWaiErrors (view applog env) (unRequestId (view reqId env)) werr Right result -> pure result where - handleWaiErrors :: Logger -> ByteString -> WaiError.Error -> Servant.Handler a + handleWaiErrors :: Logger -> ByteString -> Wai.Error -> Servant.Handler a handleWaiErrors logger reqId' werr = do Server.logError' logger (Just reqId') werr Servant.throwError $ Servant.ServerError (mkCode werr) (mkPhrase werr) (Aeson.encode werr) [(hContentType, renderHeader (Servant.contentType (Proxy @Servant.JSON)))] - mkCode = statusCode . WaiError.code - mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . WaiError.code + mkCode = statusCode . Wai.code + mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . Wai.code withLH :: Member (P.Reader Env) r => @@ -322,9 +321,17 @@ withLH f action = do lh <- P.asks (view (options . optSettings . setFeatureFlags . Teams.flagLegalHold)) f lh action +interpretErrorToException :: + (Exception e, Member (Embed IO) r) => + Sem (Error e ': r) a -> + Sem r a +interpretErrorToException = (either (embed @IO . UnliftIO.throwIO) pure =<<) . runError + interpretGalleyToGalley0 :: Galley GalleyEffects a -> Galley0 a interpretGalleyToGalley0 = Galley + . interpretErrorToException + . mapAllErrors . interpretInternalTeamListToCassandra . interpretTeamListToCassandra . interpretLegacyConversationListToCassandra @@ -376,6 +383,9 @@ instance MonadMask Galley0 where (\resource exitCase -> evalGalley0 env (unGalley (release resource exitCase))) (\resource -> evalGalley0 env (unGalley (useB resource))) +instance MonadThrow Galley0 where + throwM e = Galley (embed @IO (throwM e)) + instance MonadCatch Galley0 where catch = UnliftIO.catch diff --git a/services/galley/src/Galley/Cassandra/Code.hs b/services/galley/src/Galley/Cassandra/Code.hs index ac9d03525a3..539c2aaa4ec 100644 --- a/services/galley/src/Galley/Cassandra/Code.hs +++ b/services/galley/src/Galley/Cassandra/Code.hs @@ -25,6 +25,7 @@ import Cassandra import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Store import Galley.Data.Types +import qualified Galley.Data.Types as Code import Galley.Effects.CodeStore (CodeStore (..)) import Imports import Polysemy @@ -38,6 +39,8 @@ interpretCodeStoreToCassandra = interpret $ \case GetCode k s -> embedClient $ lookupCode k s CreateCode code -> embedClient $ insertCode code DeleteCode k s -> embedClient $ deleteCode k s + MakeKey cid -> Code.mkKey cid + GenerateCode cid s t -> Code.generate cid s t -- | Insert a conversation code insertCode :: Code -> Client () diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index e2f26dea92f..f56cde0885b 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -57,6 +57,7 @@ where import Data.Id import Data.Qualified +import Galley.API.Error import Galley.Cassandra.Paging import Galley.Effects.BotAccess import Galley.Effects.BrigAccess @@ -78,10 +79,12 @@ import Galley.Effects.TeamFeatureStore import Galley.Effects.TeamMemberStore import Galley.Effects.TeamNotificationStore import Galley.Effects.TeamStore +import qualified Network.Wai.Utilities as Wai import Polysemy +import Polysemy.Error +import Polysemy.Internal --- All the possible high-level effects. -type GalleyEffects1 = +type NonErrorGalleyEffects1 = '[ BrigAccess, GundeckAccess, SparAccess, @@ -107,3 +110,9 @@ type GalleyEffects1 = ListItems LegacyPaging TeamId, ListItems InternalPaging TeamId ] + +-- All the possible high-level effects. +type GalleyEffects1 = + Append + NonErrorGalleyEffects1 + (Append AllErrorEffects '[Error Wai.Error]) diff --git a/services/galley/src/Galley/Effects/CodeStore.hs b/services/galley/src/Galley/Effects/CodeStore.hs index 246210c230f..d06105ce5f4 100644 --- a/services/galley/src/Galley/Effects/CodeStore.hs +++ b/services/galley/src/Galley/Effects/CodeStore.hs @@ -22,15 +22,20 @@ module Galley.Effects.CodeStore -- * Create code createCode, - -- * Read code, + -- * Read code getCode, - -- * Delete code, + -- * Delete code deleteCode, + + -- * Code generation + makeKey, + generateCode, ) where import Brig.Types.Code +import Data.Id import Galley.Data.Types import Imports import Polysemy @@ -39,5 +44,7 @@ data CodeStore m a where CreateCode :: Code -> CodeStore m () GetCode :: Key -> Scope -> CodeStore m (Maybe Code) DeleteCode :: Key -> Scope -> CodeStore m () + MakeKey :: ConvId -> CodeStore m Key + GenerateCode :: ConvId -> Scope -> Timeout -> CodeStore m Code makeSem ''CodeStore diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index 1c4a3038ecb..affafacf2ee 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -56,6 +56,7 @@ import qualified OpenSSL.PEM as SSL import qualified OpenSSL.RSA as SSL import qualified OpenSSL.Session as SSL import Polysemy +import Polysemy.Error import Ssl.Util import qualified Ssl.Util as SSL import qualified System.Logger.Class as Log @@ -65,14 +66,18 @@ import URI.ByteString (uriPath) -- api -- | Get /status from legal hold service; throw 'Wai.Error' if things go wrong. -checkLegalHoldServiceStatus :: Fingerprint Rsa -> HttpsUrl -> Galley r () +checkLegalHoldServiceStatus :: + Member (Error LegalHoldError) r => + Fingerprint Rsa -> + HttpsUrl -> + Galley r () checkLegalHoldServiceStatus fpr url = do resp <- makeVerifiedRequestFreshManager fpr url reqBuilder if | Bilge.statusCode resp < 400 -> pure () | otherwise -> do Log.info . Log.msg $ showResponse resp - throwM legalHoldServiceBadResponse + liftSem $ throw LegalHoldServiceBadResponse where reqBuilder :: Http.Request -> Http.Request reqBuilder = @@ -82,7 +87,7 @@ checkLegalHoldServiceStatus fpr url = do -- | @POST /initiate@. requestNewDevice :: - Member LegalHoldStore r => + Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> UserId -> Galley r NewLegalHoldClient @@ -91,7 +96,7 @@ requestNewDevice tid uid = do case eitherDecode (responseBody resp) of Left e -> do Log.info . Log.msg $ "Error decoding NewLegalHoldClient: " <> e - throwM legalHoldServiceBadResponse + liftSem $ throw LegalHoldServiceBadResponse Right client -> pure client where reqParams = @@ -104,7 +109,7 @@ requestNewDevice tid uid = do -- | @POST /confirm@ -- Confirm that a device has been linked to a user and provide an authorization token confirmLegalHold :: - Member LegalHoldStore r => + Members '[Error LegalHoldError, LegalHoldStore] r => ClientId -> TeamId -> UserId -> @@ -124,7 +129,7 @@ confirmLegalHold clientId tid uid legalHoldAuthToken = do -- | @POST /remove@ -- Inform the LegalHold Service that a user's legalhold has been disabled. removeLegalHold :: - Member LegalHoldStore r => + Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> UserId -> Galley r () @@ -145,14 +150,14 @@ removeLegalHold tid uid = do -- the TSL fingerprint via 'makeVerifiedRequest' and passes the token so the service can -- authenticate the request. makeLegalHoldServiceRequest :: - Member LegalHoldStore r => + Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) makeLegalHoldServiceRequest tid reqBuilder = do maybeLHSettings <- liftSem $ LegalHoldData.getSettings tid lhSettings <- case maybeLHSettings of - Nothing -> throwM legalHoldServiceNotRegistered + Nothing -> liftSem $ throw LegalHoldServiceNotRegistered Just lhSettings -> pure lhSettings let LegalHoldService { legalHoldServiceUrl = baseUrl, diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index 13471a96218..b3aad0e32df 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -25,21 +25,21 @@ module Galley.Validation where import Control.Lens -import Control.Monad.Catch import Data.Range import Galley.API.Error -import Galley.Env import Galley.Options import Imports +import Polysemy +import Polysemy.Error -rangeChecked :: (MonadThrow galley, Within a n m) => a -> galley (Range n m a) +rangeChecked :: (Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) rangeChecked = either throwErr return . checkedEither {-# INLINE rangeChecked #-} rangeCheckedMaybe :: - (MonadThrow galley, Within a n m) => + (Member (Error InvalidInput) r, Within a n m) => Maybe a -> - galley (Maybe (Range n m a)) + Sem r (Maybe (Range n m a)) rangeCheckedMaybe Nothing = return Nothing rangeCheckedMaybe (Just a) = Just <$> rangeChecked a {-# INLINE rangeCheckedMaybe #-} @@ -49,16 +49,16 @@ newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} deriving (Functor, Foldable, Traversable) checkedConvSize :: - (MonadReader Env galley, MonadThrow galley, Foldable f) => + (Member (Error InvalidInput) r, Foldable f) => + Opts -> f a -> - galley (ConvSizeChecked f a) -checkedConvSize x = do - o <- view options + Sem r (ConvSizeChecked f a) +checkedConvSize o x = do let minV :: Integer = 0 limit = o ^. optSettings . setMaxConvSize - 1 if length x <= fromIntegral limit then return (ConvSizeChecked x) else throwErr (errorMsg minV limit "") -throwErr :: MonadThrow galley => String -> galley a -throwErr = throwM . invalidRange . fromString +throwErr :: Member (Error InvalidInput) r => String -> Sem r a +throwErr = throw . InvalidRange . fromString