From 6a8e3c37fb0c879508a424fe34a80db9891d92b7 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 3 Nov 2021 13:07:20 +0100 Subject: [PATCH 01/10] Remove MonadThrow instance of Galley Most instance of throwing in the IO monad have now been replaced by the use of an explicit `Error` effect. Note, however, that some interpretation code is still throwing exceptions. --- services/galley/src/Galley/API/Create.hs | 109 ++++-- .../galley/src/Galley/API/CustomBackend.hs | 18 +- services/galley/src/Galley/API/Error.hs | 18 - services/galley/src/Galley/API/Federation.hs | 10 +- services/galley/src/Galley/API/Internal.hs | 7 +- services/galley/src/Galley/API/LegalHold.hs | 117 +++--- services/galley/src/Galley/API/Mapping.hs | 18 +- services/galley/src/Galley/API/Query.hs | 24 +- services/galley/src/Galley/API/Teams.hs | 348 ++++++++++-------- .../galley/src/Galley/API/Teams/Features.hs | 42 ++- .../src/Galley/API/Teams/Notifications.hs | 12 +- services/galley/src/Galley/API/Update.hs | 186 ++++++---- services/galley/src/Galley/API/Util.hs | 132 ++++--- services/galley/src/Galley/App.hs | 63 +++- services/galley/src/Galley/Effects.hs | 5 +- .../src/Galley/External/LegalHoldService.hs | 17 +- services/galley/src/Galley/Validation.hs | 23 +- 17 files changed, 663 insertions(+), 486 deletions(-) diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index ee86e14933e..b388d5c1d6a 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -25,7 +25,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)) @@ -56,6 +55,8 @@ import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities +import Polysemy +import Polysemy.Error import Wire.API.Conversation hiding (Conversation, Member) import qualified Wire.API.Conversation as Public import Wire.API.ErrorDescription (MissingLegalholdConsent) @@ -78,7 +79,8 @@ createGroupConversation :: FederatorAccess, GundeckAccess, LegalHoldStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -99,7 +101,8 @@ internalCreateManagedConversationH :: FederatorAccess, GundeckAccess, LegalHoldStore, - TeamStore + TeamStore, + WaiError ] r => UserId ::: ConnId ::: JsonRequest NewConvManaged -> @@ -115,7 +118,8 @@ internalCreateManagedConversation :: FederatorAccess, GundeckAccess, LegalHoldStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -123,12 +127,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 internalError (newConvTeam body) + createTeamGroupConv zusr zcon tinfo body ensureNoLegalholdConflicts :: - Members '[LegalHoldStore, TeamStore] r => + Members '[LegalHoldStore, TeamStore, WaiError] r => [Remote UserId] -> [UserId] -> Galley r () @@ -146,7 +149,8 @@ createRegularGroupConv :: FederatorAccess, GundeckAccess, LegalHoldStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -155,9 +159,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 <- @@ -187,7 +192,8 @@ createTeamGroupConv :: FederatorAccess, GundeckAccess, LegalHoldStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -197,13 +203,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 +254,7 @@ createTeamGroupConv zusr zcon tinfo body = do -- Other kinds of conversations createSelfConversation :: - Member ConversationStore r => + Members '[ConversationStore, WaiError] r => UserId -> Galley r ConversationResponse createSelfConversation zusr = do @@ -266,7 +273,8 @@ createOne2OneConversation :: ConversationStore, FederatorAccess, GundeckAccess, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -276,12 +284,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 "Cannot create a 1-1 with yourself") mtid <- case newConvTeam j of Just ti - | cnvManaged ti -> throwM noManagedTeamConv + | cnvManaged ti -> liftSem $ throw noManagedTeamConv | otherwise -> do foldQualified lusr @@ -289,7 +297,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,9 +307,10 @@ 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 :: + Member WaiError r => Local UserId -> Local UserId -> TeamId -> @@ -314,11 +323,11 @@ 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 nonBindingTeam + Nothing -> liftSem $ throw teamNotFound createLegacyOne2OneConversationUnchecked :: - Members '[ConversationStore, FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, FederatorAccess, GundeckAccess, WaiError] r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -337,7 +346,7 @@ createLegacyOne2OneConversationUnchecked self zcon name mtid other = do conversationCreated (tUnqualified self) c createOne2OneConversationUnchecked :: - Members '[ConversationStore, FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, FederatorAccess, GundeckAccess, WaiError] r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -353,7 +362,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, FederatorAccess, GundeckAccess, WaiError] r => Local ConvId -> Local UserId -> ConnId -> @@ -371,6 +380,7 @@ createOne2OneConversationLocally lcnv self zcon name mtid other = do conversationCreated (tUnqualified self) c createOne2OneConversationRemotely :: + Member WaiError r => Remote ConvId -> Local UserId -> ConnId -> @@ -379,10 +389,11 @@ createOne2OneConversationRemotely :: Qualified UserId -> Galley r ConversationResponse createOne2OneConversationRemotely _ _ _ _ _ _ = - throwM federationNotImplemented + liftSem $ + throw federationNotImplemented createConnectConversation :: - Members '[ConversationStore, FederatorAccess, GundeckAccess, MemberStore] r => + Members '[ConversationStore, FederatorAccess, GundeckAccess, MemberStore, WaiError] r => UserId -> Maybe ConnId -> Connect -> @@ -396,15 +407,17 @@ createConnectConversation usr conn j = do (cRecipient j) createConnectConversationWithRemote :: + Member WaiError 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, FederatorAccess, GundeckAccess, MemberStore, WaiError] r => Local UserId -> Maybe ConnId -> Local UserId -> @@ -412,7 +425,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 +487,18 @@ createLegacyConnectConversation lusr conn lrecipient j = do ------------------------------------------------------------------------------- -- Helpers -conversationCreated :: UserId -> Data.Conversation -> Galley r ConversationResponse +conversationCreated :: + Member WaiError r => + UserId -> + Data.Conversation -> + Galley r ConversationResponse conversationCreated usr cnv = Created <$> conversationView usr cnv -conversationExisted :: UserId -> Data.Conversation -> Galley r ConversationResponse +conversationExisted :: + Member WaiError r => + UserId -> + Data.Conversation -> + Galley r ConversationResponse conversationExisted usr cnv = Existed <$> conversationView usr cnv handleConversationResponse :: ConversationResponse -> Response @@ -486,7 +507,7 @@ handleConversationResponse = \case Existed cnv -> json cnv & setStatus status200 . location (qUnqualified . cnvQualifiedId $ cnv) notifyCreatedConversation :: - Members '[FederatorAccess, GundeckAccess] r => + Members '[FederatorAccess, GundeckAccess, WaiError] r => Maybe UTCTime -> UserId -> Maybe ConnId -> @@ -517,12 +538,20 @@ notifyCreatedConversation dtime usr conn c = do & pushConn .~ conn & pushRoute .~ route -localOne2OneConvId :: Local UserId -> Local UserId -> Galley r (Local ConvId) +localOne2OneConvId :: + Member WaiError 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 WaiError 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 @@ -541,6 +570,6 @@ newConvMembers loc body = UserList (newConvUsers body) [] <> toUserList loc (newConvQualifiedUsers body) -ensureOne :: [a] -> Galley r a +ensureOne :: Member WaiError 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..1d2ee80e1ab 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 @@ -35,24 +34,29 @@ import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities 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, WaiError] r => Domain ::: JSON -> Galley r Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain -getCustomBackendByDomain :: Member CustomBackendStore r => Domain -> Galley r Public.CustomBackend +getCustomBackendByDomain :: + Members '[CustomBackendStore, WaiError] 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, WaiError] 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..8e3c32a3029 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -17,7 +17,6 @@ module Galley.API.Error where -import Control.Monad.Catch (MonadThrow (..)) import Data.Domain (Domain, domainText) import Data.Proxy import Data.String.Conversions (cs) @@ -49,23 +48,6 @@ 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) - internalError :: Error internalError = internalErrorWithDescription "internal error" diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index a6ba85d5758..665128fcd22 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -18,7 +18,6 @@ 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) @@ -47,6 +46,7 @@ import qualified Galley.Effects.MemberStore as E import Galley.Types.Conversations.Members (LocalMember (..), defMemberStatus) import Galley.Types.UserList import Imports +import Polysemy.Error import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) @@ -248,7 +248,8 @@ leaveConversation :: GundeckAccess, LegalHoldStore, MemberStore, - TeamStore + TeamStore, + WaiError ] r => Domain -> @@ -323,7 +324,8 @@ sendMessage :: GundeckAccess, ExternalAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => Domain -> @@ -334,7 +336,7 @@ sendMessage originDomain msr = do msg <- either err pure (fromProto (fromBase64ByteString (msrRawMessage msr))) MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing (msrConvId msr) msg where - err = throwM . invalidPayload . LT.pack + err = liftSem . throw . invalidPayload . LT.pack onUserDeleted :: Members diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index bb7ce82c268..bbc74cb720c 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -38,7 +38,6 @@ 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.LegalHold (getTeamLegalholdWhitelistedH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) import qualified Galley.API.One2One as One2One @@ -303,7 +302,7 @@ servantSitemap = iGetTeamFeature :: forall a r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + (Public.KnownTeamFeatureName a, Members '[TeamStore, WaiError] r) => (Features.GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Galley r (Public.TeamFeatureStatus a) @@ -311,7 +310,7 @@ iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: forall a r. - (Public.KnownTeamFeatureName a, Member TeamStore r) => + (Public.KnownTeamFeatureName a, Members '[TeamStore, WaiError] r) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Public.TeamFeatureStatus a -> @@ -629,7 +628,7 @@ safeForever funName action = threadDelay 60000000 -- pause to keep worst-case noise in logs manageable guardLegalholdPolicyConflictsH :: - Members '[BrigAccess, TeamStore] r => + Members '[BrigAccess, TeamStore, WaiError] r => (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> Galley r Response guardLegalholdPolicyConflictsH (req ::: _) = do diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 0a6015259e7..9ea36e33a31 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) @@ -71,6 +70,7 @@ 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 Polysemy.Error import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) @@ -79,10 +79,18 @@ 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 '[LegalHoldStore, TeamFeatureStore, WaiError] 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, WaiError] r => + TeamId -> + Galley r Bool isLegalHoldEnabledForTeam tid = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> do @@ -99,7 +107,7 @@ isLegalHoldEnabledForTeam tid = do liftSem $ LegalHoldData.isTeamLegalholdWhitelisted tid createSettingsH :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley r Response createSettingsH (zusr ::: tid ::: req ::: _) = do @@ -107,7 +115,7 @@ createSettingsH (zusr ::: tid ::: req ::: _) = do setStatus status201 . json <$> createSettings zusr tid newService createSettings :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => UserId -> TeamId -> Public.NewLegalHoldService -> @@ -122,21 +130,21 @@ 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 '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => UserId ::: TeamId ::: JSON -> Galley r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid getSettings :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => UserId -> TeamId -> Galley r Public.ViewLegalHoldService @@ -165,7 +173,8 @@ removeSettingsH :: MemberStore, TeamStore, TeamFeatureStore, - TeamMemberStore InternalPaging + TeamMemberStore InternalPaging, + WaiError ] r => UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> @@ -192,7 +201,8 @@ removeSettings :: MemberStore, TeamFeatureStore, TeamStore, - TeamMemberStore p + TeamMemberStore p, + WaiError ] r ) => @@ -212,13 +222,13 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do ensureReAuthorised zusr mPassword removeSettings' tid where - assertNotWhitelisting :: Galley r () + assertNotWhitelisting :: Member WaiError 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' :: @@ -238,7 +248,8 @@ removeSettings' :: ListItems LegacyPaging ConvId, MemberStore, TeamStore, - TeamMemberStore p + TeamMemberStore p, + WaiError ] r ) => @@ -267,7 +278,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 '[LegalHoldStore, TeamStore, WaiError] r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do @@ -275,13 +286,12 @@ getUserStatusH (_zusr ::: tid ::: uid ::: _) = do getUserStatus :: forall r. - Members '[LegalHoldStore, TeamStore] r => + Members '[LegalHoldStore, TeamStore, WaiError] 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 +309,7 @@ getUserStatus tid uid = do "expected to find a prekey for user: " <> toByteString' uid <> " but none was found" - throwM internalError + liftSem $ throw internalError Just lstKey -> pure lstKey let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey pure (Just lastKey, Just clientId) @@ -320,7 +330,8 @@ grantConsentH :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId ::: TeamId ::: JSON -> @@ -347,7 +358,8 @@ grantConsent :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -356,15 +368,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 :: @@ -381,7 +392,8 @@ requestDeviceH :: ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + WaiError ] r => UserId ::: TeamId ::: UserId ::: JSON -> @@ -410,7 +422,8 @@ requestDevice :: ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -424,12 +437,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 userLegalHoldNoConsent 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: @@ -472,7 +485,8 @@ approveDeviceH :: ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + WaiError ] r => UserId ::: TeamId ::: UserId ::: ConnId ::: JsonRequest Public.ApproveLegalHoldForUserRequest ::: JSON -> @@ -496,7 +510,8 @@ approveDevice :: ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -510,7 +525,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 +536,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 +550,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 WaiError 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 @@ -556,7 +571,8 @@ disableForUserH :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId ::: TeamId ::: UserId ::: JsonRequest Public.DisableLegalHoldForUserRequest ::: JSON -> @@ -585,7 +601,8 @@ disableForUser :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -633,7 +650,8 @@ changeLegalholdStatus :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + WaiError ] r => TeamId -> @@ -673,12 +691,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, LegalHoldStore, TeamStore, WaiError] r => UserId -> Galley r () blockNonConsentingConnections uid = do @@ -690,7 +708,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 @@ -764,7 +782,8 @@ handleGroupConvPolicyConflicts :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index e7ce9a86671..f1c0c1da887 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -26,7 +26,6 @@ module Galley.API.Mapping ) where -import Control.Monad.Catch import Data.Domain (Domain) import Data.Id (UserId, idToText) import Data.Qualified @@ -38,15 +37,22 @@ 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 :: + Members '[WaiError] r => + UserId -> + Data.Conversation -> + Galley r Conversation conversationView uid conv = do luid <- qualifyLocal uid let mbConv = conversationViewMaybe luid conv @@ -58,7 +64,7 @@ conversationView uid conv = do +++ idToText uid +++ val " is not a member of conv " +++ idToText (convId conv) - throwM badState + liftSem $ throw badState badState = mkError status500 "bad-state" "Bad internal member state." -- | View for a given user of a stored conversation. @@ -131,9 +137,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..b8916bcf4db 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 @@ -67,6 +66,7 @@ import Network.Wai.Predicate hiding (result, setStatus) import Network.Wai.Utilities import qualified Network.Wai.Utilities.Error as Wai import Polysemy +import Polysemy.Error import qualified System.Logger.Class as Logger import UnliftIO (pooledForConcurrentlyN) import Wire.API.Conversation (ConversationCoverView (..)) @@ -81,14 +81,14 @@ import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public getBotConversationH :: - Member ConversationStore r => + Members '[ConversationStore, WaiError] r => BotId ::: ConvId ::: JSON -> Galley r Response getBotConversationH (zbot ::: zcnv ::: _) = do json <$> getBotConversation zbot zcnv getBotConversation :: - Member ConversationStore r => + Members '[ConversationStore, WaiError] r => BotId -> ConvId -> Galley r Public.BotConvView @@ -106,7 +106,7 @@ getBotConversation zbot zcnv = do Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) getUnqualifiedConversation :: - Member ConversationStore r => + Members '[ConversationStore, WaiError] r => UserId -> ConvId -> Galley r Public.Conversation @@ -116,7 +116,7 @@ getUnqualifiedConversation zusr cnv = do getConversation :: forall r. - Member ConversationStore r => + Members '[ConversationStore, WaiError] r => UserId -> Qualified ConvId -> Galley r Public.Conversation @@ -134,17 +134,17 @@ getConversation zusr cnv = do case conversations of [] -> throwErrorDescriptionType @ConvNotFound [conv] -> pure conv - _convs -> throwM (federationUnexpectedBody "expected one conversation, got multiple") + _convs -> liftSem $ throw (federationUnexpectedBody "expected one conversation, got multiple") getRemoteConversations :: - Member ConversationStore r => + Members '[ConversationStore, WaiError] r => UserId -> [Remote ConvId] -> Galley r [Public.Conversation] getRemoteConversations zusr remoteConvs = getRemoteConversationsWithFailures zusr remoteConvs >>= \case -- throw first error - (failed : _, _) -> throwM (fgcError failed) + (failed : _, _) -> liftSem $ throw (fgcError failed) ([], result) -> pure result data FailedGetConversationReason @@ -231,7 +231,7 @@ getRemoteConversationsWithFailures zusr convs = do throwE e getConversationRoles :: - Member ConversationStore r => + Members '[ConversationStore, WaiError] r => UserId -> ConvId -> Galley r Public.ConversationRolesList @@ -317,7 +317,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do } getConversations :: - Members '[ListItems LegacyPaging ConvId, ConversationStore] r => + Members '[ListItems LegacyPaging ConvId, ConversationStore, WaiError] r => UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> @@ -369,7 +369,7 @@ getConversationsInternal user mids mstart msize = do | otherwise = pure True listConversations :: - Member ConversationStore r => + Members '[ConversationStore, WaiError] r => UserId -> Public.ListConversations -> Galley r Public.ConversationsResponse @@ -485,7 +485,7 @@ getConversationMeta cnv = liftSem $ do pure Nothing getConversationByReusableCode :: - Members '[CodeStore, ConversationStore, BrigAccess, TeamStore] r => + Members '[CodeStore, ConversationStore, BrigAccess, TeamStore, WaiError] r => UserId -> Key -> Value -> diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 0b58052ecc5..112d5779066 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) @@ -121,6 +120,7 @@ import Network.Wai import Network.Wai.Predicate hiding (or, result, setStatus) import Network.Wai.Utilities 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 @@ -138,17 +138,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 '[TeamStore, WaiError] 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 '[TeamStore, WaiError] 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 '[TeamStore, WaiError] 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 +195,7 @@ lookupTeam zusr tid = do else pure Nothing createNonBindingTeamH :: - Members '[GundeckAccess, BrigAccess, TeamStore] r => + Members '[GundeckAccess, BrigAccess, TeamStore, WaiError] r => UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> Galley r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do @@ -193,7 +204,7 @@ createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do pure (empty & setStatus status201 . location newTeamId) createNonBindingTeam :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members '[BrigAccess, GundeckAccess, TeamStore, WaiError] r => UserId -> ConnId -> Public.NonBindingNewTeam -> @@ -223,7 +234,7 @@ createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do pure (team ^. teamId) createBindingTeamH :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members '[BrigAccess, GundeckAccess, TeamStore, WaiError] r => UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley r Response createBindingTeamH (zusr ::: tid ::: req ::: _) = do @@ -232,7 +243,7 @@ createBindingTeamH (zusr ::: tid ::: req ::: _) = do pure (empty & setStatus status201 . location newTeamId) createBindingTeam :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members '[BrigAccess, GundeckAccess, TeamStore, WaiError] r => UserId -> TeamId -> BindingNewTeam -> @@ -246,7 +257,7 @@ createBindingTeam zusr tid (BindingNewTeam body) = do pure tid updateTeamStatusH :: - Members '[BrigAccess, TeamStore] r => + Members '[BrigAccess, TeamStore, WaiError] r => TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley r Response updateTeamStatusH (tid ::: req ::: _) = do @@ -254,7 +265,11 @@ updateTeamStatusH (tid ::: req ::: _) = do updateTeamStatus tid teamStatusUpdate return empty -updateTeamStatus :: Members '[BrigAccess, TeamStore] r => TeamId -> TeamStatusUpdate -> Galley r () +updateTeamStatus :: + Members '[BrigAccess, TeamStore, WaiError] r => + TeamId -> + TeamStatusUpdate -> + Galley r () updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do oldStatus <- tdStatus <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) valid <- validateTransition (oldStatus, newStatus) @@ -274,18 +289,18 @@ 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 WaiError 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 '[GundeckAccess, TeamStore, WaiError] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> Galley r Response updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -294,7 +309,7 @@ updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do pure empty updateTeam :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, TeamStore, WaiError] r => UserId -> ConnId -> TeamId -> @@ -315,7 +330,7 @@ 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, TeamStore, WaiError] r => UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> Galley r Response deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -325,17 +340,16 @@ deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do -- | 'TeamDeleteData' is only required for binding teams deleteTeam :: - Members '[BrigAccess, TeamStore] r => + Members '[BrigAccess, TeamStore, WaiError] 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 @@ -349,15 +363,18 @@ deleteTeam zusr zcon tid mBody = do ensureReAuthorised zusr (body ^. tdAuthPassword) -- This can be called by stern -internalDeleteBindingTeamWithOneMember :: Member TeamStore r => TeamId -> Galley r () +internalDeleteBindingTeamWithOneMember :: + Members '[TeamStore, WaiError] 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 +463,18 @@ uncheckedDeleteTeam zusr zcon tid = do pure (pp', ee' ++ ee) getTeamConversationRoles :: - Member TeamStore r => + Members '[TeamStore, WaiError] 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 >>= note (errorDescriptionTypeToWai @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 '[TeamStore, WaiError] r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley r Response getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do @@ -468,27 +482,26 @@ getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do pure . json $ teamMemberListJson withPerms memberList getTeamMembers :: - Member TeamStore r => + Members '[TeamStore, WaiError] 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 >>= note (errorDescriptionTypeToWai @NotATeamMember) + mems <- E.getTeamMembersWithLimit tid maxResults + let withPerms = (m `canSeePermsOf`) + pure (mems, withPerms) getTeamMembersCSVH :: - (Members '[BrigAccess, TeamStore] r) => + (Members '[BrigAccess, TeamStore, WaiError] 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 +611,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do (UserScimExternalId _) -> Nothing bulkGetTeamMembersH :: - Member TeamStore r => + Members '[TeamStore, WaiError] r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley r Response bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do @@ -608,25 +621,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 '[TeamStore, WaiError] 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 >>= note (errorDescriptionTypeToWai @NotATeamMember) + mems <- E.selectTeamMembers tid uids + let withPerms = (m `canSeePermsOf`) + hasMore = ListComplete + pure (newTeamMemberList mems hasMore, withPerms) getTeamMemberH :: - Member TeamStore r => + Members '[TeamStore, WaiError] r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do @@ -634,23 +645,22 @@ getTeamMemberH (zusr ::: tid ::: uid ::: _) = do pure . json $ teamMemberJson withPerms member getTeamMember :: - Member TeamStore r => + Members '[TeamStore, WaiError] 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 + >>= note (errorDescriptionTypeToWai @NotATeamMember) + let withPerms = (m `canSeePermsOf`) + member <- liftSem $ E.getTeamMember tid uid >>= note teamMemberNotFound + pure (member, withPerms) internalDeleteBindingTeamWithOneMemberH :: - Member TeamStore r => + Members '[TeamStore, WaiError] r => TeamId -> Galley r Response internalDeleteBindingTeamWithOneMemberH tid = do @@ -658,18 +668,18 @@ internalDeleteBindingTeamWithOneMemberH tid = do pure (empty & setStatus status202) uncheckedGetTeamMemberH :: - Member TeamStore r => + Members '[TeamStore, WaiError] r => TeamId ::: UserId ::: JSON -> Galley r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid uncheckedGetTeamMember :: - Member TeamStore r => + Members '[TeamStore, WaiError] r => TeamId -> UserId -> Galley r TeamMember -uncheckedGetTeamMember tid uid = do +uncheckedGetTeamMember tid uid = liftSem (E.getTeamMember tid uid) >>= ifNothing teamMemberNotFound uncheckedGetTeamMembersH :: @@ -694,7 +704,8 @@ addTeamMemberH :: MemberStore, TeamFeatureStore, TeamNotificationStore, - TeamStore + TeamStore, + WaiError ] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> @@ -712,7 +723,8 @@ addTeamMember :: MemberStore, TeamFeatureStore, TeamNotificationStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -748,7 +760,8 @@ uncheckedAddTeamMemberH :: LegalHoldStore, TeamFeatureStore, TeamStore, - TeamNotificationStore + TeamNotificationStore, + WaiError ] r => TeamId ::: JsonRequest NewTeamMember ::: JSON -> @@ -766,7 +779,8 @@ uncheckedAddTeamMember :: LegalHoldStore, TeamFeatureStore, TeamStore, - TeamNotificationStore + TeamNotificationStore, + WaiError ] r => TeamId -> @@ -781,7 +795,7 @@ uncheckedAddTeamMember tid nmem = do Journal.teamUpdate tid (sizeBeforeAdd + 1) billingUserIds updateTeamMemberH :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members '[BrigAccess, GundeckAccess, TeamStore, WaiError] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -792,7 +806,7 @@ updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do updateTeamMember :: forall r. - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members '[BrigAccess, GundeckAccess, TeamStore, WaiError] r => UserId -> ConnId -> TeamId -> @@ -806,7 +820,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 +828,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 @@ -867,7 +878,8 @@ deleteTeamMemberH :: ExternalAccess, GundeckAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> @@ -890,7 +902,8 @@ deleteTeamMember :: ExternalAccess, GundeckAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -906,10 +919,10 @@ 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 + liftSem $ do + dm <- note teamMemberNotFound zusrMember + tm <- note teamMemberNotFound targetMember + unless (canDeleteMember dm tm) $ throw accessDenied team <- tdTeam <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) mems <- getTeamMembersForFanout tid if team ^. teamBinding == Binding && isJust targetMember @@ -993,7 +1006,7 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do liftSem $ E.deliverAsync (bots `zip` repeat y) getTeamConversations :: - Member TeamStore r => + Members '[TeamStore, WaiError] r => UserId -> TeamId -> Galley r Public.TeamConversationList @@ -1006,7 +1019,7 @@ getTeamConversations zusr tid = do liftSem $ Public.newTeamConversationList <$> E.getTeamConversations tid getTeamConversation :: - Member TeamStore r => + Members '[TeamStore, WaiError] r => UserId -> TeamId -> ConvId -> @@ -1032,7 +1045,8 @@ deleteTeamConversation :: GundeckAccess, LegalHoldStore, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -1046,7 +1060,7 @@ deleteTeamConversation zusr zcon _tid cid = do void $ API.deleteLocalConversation lusr zcon lconv getSearchVisibilityH :: - Members '[SearchVisibilityStore, TeamStore] r => + Members '[SearchVisibilityStore, TeamStore, WaiError] r => UserId ::: TeamId ::: JSON -> Galley r Response getSearchVisibilityH (uid ::: tid ::: _) = do @@ -1055,7 +1069,7 @@ getSearchVisibilityH (uid ::: tid ::: _) = do json <$> getSearchVisibilityInternal tid setSearchVisibilityH :: - Members '[SearchVisibilityStore, TeamStore, TeamFeatureStore] r => + Members '[SearchVisibilityStore, TeamStore, TeamFeatureStore, WaiError] r => UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do @@ -1097,37 +1111,38 @@ withTeamIds usr range size k = case range of k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: Member TeamStore r => [UserId] -> Galley r () +ensureUnboundUsers :: Members '[TeamStore, WaiError] 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 '[TeamStore, WaiError] 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 WaiError 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, WaiError] 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 +1155,23 @@ ensureNotTooLarge tid = do -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. ensureNotTooLargeForLegalHold :: - Members '[BrigAccess, LegalHoldStore, TeamFeatureStore] r => + Members '[BrigAccess, LegalHoldStore, TeamFeatureStore, WaiError] 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, WaiError] 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 +1185,15 @@ teamSizeBelowLimit teamSize = do pure True addTeamMemberInternal :: - Members '[BrigAccess, GundeckAccess, MemberStore, TeamNotificationStore, TeamStore] r => + Members + '[ BrigAccess, + GundeckAccess, + MemberStore, + TeamNotificationStore, + TeamStore, + WaiError + ] + r => TeamId -> Maybe UserId -> Maybe ConnId -> @@ -1205,7 +1231,7 @@ 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, TeamNotificationStore, WaiError] r => UserId ::: Maybe ByteString {- NotificationId -} ::: Range 1 10000 Int32 @@ -1216,13 +1242,13 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do json @Public.QueuedNotificationList <$> APITeamQueue.getTeamNotifications zusr since size where - parseSince :: Galley r (Maybe Public.NotificationId) + parseSince :: Member WaiError r => Galley r (Maybe Public.NotificationId) parseSince = maybe (pure Nothing) (fmap Just . parseUUID) sinceRaw - parseUUID :: ByteString -> Galley r Public.NotificationId + parseUUID :: Member WaiError r => ByteString -> Galley r Public.NotificationId parseUUID raw = maybe - (throwM invalidTeamNotificationId) + (liftSem (throw invalidTeamNotificationId)) (pure . Id) ((UUID.fromASCIIBytes >=> isV1UUID) raw) @@ -1230,7 +1256,7 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do isV1UUID u = if UUID.version u == 1 then Just u else Nothing finishCreateTeam :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, TeamStore, WaiError] r => Team -> TeamMember -> [TeamMember] -> @@ -1246,35 +1272,40 @@ 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 '[TeamStore, WaiError] 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 nonBindingTeam -getBindingTeamIdH :: Member TeamStore r => UserId -> Galley r Response +getBindingTeamIdH :: Members '[TeamStore, WaiError] r => UserId -> Galley r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: Member TeamStore r => UserId -> Galley r TeamId +getBindingTeamId :: Members '[TeamStore, WaiError] r => UserId -> Galley r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: Member TeamStore r => UserId -> Galley r Response +getBindingTeamMembersH :: Members '[TeamStore, WaiError] r => UserId -> Galley r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers -getBindingTeamMembers :: Member TeamStore r => UserId -> Galley r TeamMemberList +getBindingTeamMembers :: Members '[TeamStore, WaiError] r => UserId -> Galley r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> getTeamMembersForFanout tid canUserJoinTeamH :: - Members '[BrigAccess, LegalHoldStore, TeamFeatureStore] r => + Members '[BrigAccess, LegalHoldStore, TeamFeatureStore, WaiError] 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, LegalHoldStore, TeamFeatureStore, WaiError] r => TeamId -> Galley r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do @@ -1314,7 +1345,7 @@ getSearchVisibilityInternal = . SearchVisibilityData.getSearchVisibility setSearchVisibilityInternalH :: - Members '[SearchVisibilityStore, TeamFeatureStore] r => + Members '[SearchVisibilityStore, TeamFeatureStore, WaiError] r => TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityInternalH (tid ::: req ::: _) = do @@ -1322,32 +1353,43 @@ setSearchVisibilityInternalH (tid ::: req ::: _) = do pure noContent setSearchVisibilityInternal :: - Members '[SearchVisibilityStore, TeamFeatureStore] r => + Members '[SearchVisibilityStore, TeamFeatureStore, WaiError] 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 '[TeamStore, WaiError] 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 '[TeamStore, WaiError] 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 WaiError 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..848bdc788be 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -47,7 +47,6 @@ 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 @@ -75,6 +74,7 @@ import Network.HTTP.Client (Manager) import Network.Wai import Network.Wai.Predicate hiding (Error, or, result, setStatus) import Network.Wai.Utilities +import Polysemy.Error import Servant.API ((:<|>) ((:<|>))) import qualified Servant.Client as Client import qualified System.Logger.Class as Log @@ -97,7 +97,7 @@ 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 '[TeamStore, WaiError] r) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -114,7 +114,7 @@ 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 '[TeamStore, WaiError] r) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -132,7 +132,7 @@ 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 '[TeamStore, WaiError] r) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> UserId -> Galley r (Public.TeamFeatureStatus a) @@ -147,7 +147,7 @@ getFeatureConfig getter zusr = do getter (Right tid) getAllFeatureConfigs :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => UserId -> Galley r AllFeatureConfigs getAllFeatureConfigs zusr = do @@ -157,7 +157,7 @@ getAllFeatureConfigs zusr = do forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a), - Member TeamStore r + Members '[TeamStore, WaiError] r ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> Galley r (Text, Aeson.Value) @@ -183,7 +183,7 @@ getAllFeatureConfigs zusr = do ] getAllFeaturesH :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => UserId ::: TeamId ::: JSON -> Galley r Response getAllFeaturesH (uid ::: tid ::: _) = @@ -191,7 +191,7 @@ getAllFeaturesH (uid ::: tid ::: _) = getAllFeatures :: forall r. - Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => UserId -> TeamId -> Galley r Aeson.Value @@ -274,12 +274,12 @@ getSSOStatusInternal = FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled setSSOStatusInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, WaiError] 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 :: @@ -348,7 +348,7 @@ setDigitalSignaturesInternal :: setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () getLegalholdStatusInternal :: - Members '[LegalHoldStore, TeamFeatureStore] r => + Members '[LegalHoldStore, TeamFeatureStore, WaiError] r => GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = @@ -375,7 +375,8 @@ setLegalholdStatusInternal :: MemberStore, TeamFeatureStore, TeamStore, - TeamMemberStore p + TeamMemberStore p, + WaiError ] r ) => @@ -388,13 +389,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 +446,13 @@ getAppLockInternal mbtid = do pure $ fromMaybe defaultStatus status setAppLockInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, WaiError] 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 inactivityTimeoutTooLow let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureAppLock (EdFeatureApplockChanged status) @@ -467,7 +468,7 @@ getClassifiedDomainsInternal _mbtid = do Public.TeamFeatureEnabled -> config getConferenceCallingInternal :: - Member TeamFeatureStore r => + Members '[TeamFeatureStore, WaiError] r => GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do @@ -528,7 +529,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 WaiError r) => UserId -> Galley r (Public.TeamFeatureStatus flag) getFeatureConfigViaAccount uid = do @@ -537,10 +538,11 @@ getFeatureConfigViaAccount uid = do getAccountFeatureConfigClient brigep mgr uid >>= handleResp where handleResp :: + Member WaiError 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) => diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index 8b4b0117a15..7d858c8e264 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -59,18 +59,16 @@ import Gundeck.Types.Notification import Imports import Network.HTTP.Types import Network.Wai.Utilities +import Polysemy.Error getTeamNotifications :: - Members '[BrigAccess, TeamNotificationStore] r => + Members '[BrigAccess, TeamNotificationStore, WaiError] 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..a3a853374ea 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -71,7 +71,6 @@ 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 @@ -125,6 +124,7 @@ import Network.Wai import Network.Wai.Predicate hiding (and, failure, setStatus, _1, _2) import Network.Wai.Utilities 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 @@ -149,14 +149,14 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client acceptConvH :: - Members '[ConversationStore, GundeckAccess, MemberStore] r => + Members '[ConversationStore, GundeckAccess, MemberStore, WaiError] 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, GundeckAccess, MemberStore, WaiError] r => UserId -> Maybe ConnId -> ConvId -> @@ -169,14 +169,14 @@ acceptConv usr conn cnv = do conversationView usr conv' blockConvH :: - Members '[ConversationStore, MemberStore] r => + Members '[ConversationStore, MemberStore, WaiError] r => UserId ::: ConvId -> Galley r Response blockConvH (zusr ::: cnv) = empty <$ blockConv zusr cnv blockConv :: - Members '[ConversationStore, MemberStore] r => + Members '[ConversationStore, MemberStore, WaiError] r => UserId -> ConvId -> Galley r () @@ -185,21 +185,21 @@ blockConv zusr cnv = do liftSem (E.getConversation cnv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - throwM $ + liftSem . throw $ invalidOp "block: invalid conversation type" let mems = Data.convLocalMembers conv when (zusr `isMember` mems) . liftSem $ E.deleteMembers cnv (UserList [zusr] []) unblockConvH :: - Members '[ConversationStore, GundeckAccess, MemberStore] r => + Members '[ConversationStore, GundeckAccess, MemberStore, WaiError] 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, GundeckAccess, MemberStore, WaiError] r => UserId -> Maybe ConnId -> ConvId -> @@ -209,7 +209,7 @@ unblockConv usr conn cnv = do liftSem (E.getConversation cnv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - throwM $ + liftSem . throw $ invalidOp "unblock: invalid conversation type" conv' <- acceptOne2One usr conv conn conversationView usr conv' @@ -263,12 +263,13 @@ updateLocalConversationAccess lcnv lusr con target = $ target updateRemoteConversationAccess :: + Member WaiError r => Remote ConvId -> Local UserId -> ConnId -> Public.ConversationAccessData -> Galley r (UpdateResult Event) -updateRemoteConversationAccess _ _ _ _ = throwM federationNotImplemented +updateRemoteConversationAccess _ _ _ _ = liftSem $ throw federationNotImplemented performAccessUpdateAction :: forall r. @@ -283,7 +284,8 @@ performAccessUpdateAction :: GundeckAccess, LegalHoldStore, MemberStore, - TeamStore + TeamStore, + WaiError ] r => Qualified UserId -> @@ -389,12 +391,13 @@ updateLocalConversationReceiptMode lcnv lusr con update = ConversationActionReceiptModeUpdate update updateRemoteConversationReceiptMode :: + Member WaiError r => Remote ConvId -> Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> Galley r (UpdateResult Event) -updateRemoteConversationReceiptMode _ _ _ _ = throwM federationNotImplemented +updateRemoteConversationReceiptMode _ _ _ _ = liftSem $ throw federationNotImplemented updateConversationMessageTimerUnqualified :: Members UpdateConversationActions r => @@ -409,7 +412,7 @@ updateConversationMessageTimerUnqualified usr zcon cnv update = do updateLocalConversationMessageTimer lusr zcon lcnv update updateConversationMessageTimer :: - (Member ConversationStore r, Members UpdateConversationActions r) => + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> @@ -420,7 +423,7 @@ updateConversationMessageTimer usr zcon qcnv update = do foldQualified lusr (updateLocalConversationMessageTimer lusr zcon) - (\_ _ -> throwM federationNotImplemented) + (\_ _ -> liftSem (throw federationNotImplemented)) qcnv update @@ -459,7 +462,8 @@ type UpdateConversationActions = ConversationStore, LegalHoldStore, MemberStore, - TeamStore + TeamStore, + WaiError ] -- | Update a local conversation, and notify all local and remote members. @@ -511,9 +515,9 @@ performAction qusr conv action = case action of ConversationActionRemoveMembers members -> do performRemoveMemberAction conv (toList members) pure (mempty, action) - ConversationActionRename rename -> lift $ do + ConversationActionRename rename -> lift . liftSem $ do cn <- rangeChecked (cupName rename) - liftSem $ E.setConversationName (Data.convId conv) cn + E.setConversationName (Data.convId conv) cn pure (mempty, action) ConversationActionMessageTimerUpdate update -> do guard $ Data.convMessageTimer conv /= cupMessageTimer update @@ -541,7 +545,7 @@ performAction qusr conv action = case action of pure (mempty, action) addCodeH :: - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => + Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess, WaiError] r => UserId ::: ConnId ::: ConvId -> Galley r Response addCodeH (usr ::: zcon ::: cnv) = @@ -555,7 +559,7 @@ data AddCodeResult addCode :: forall r. - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => + Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess, WaiError] r => UserId -> ConnId -> ConvId -> @@ -591,14 +595,14 @@ addCode usr zcon cnv = do return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix rmCodeH :: - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess] r => + Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess, WaiError] 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, ExternalAccess, GundeckAccess, WaiError] r => UserId -> ConnId -> ConvId -> @@ -621,14 +625,14 @@ rmCode usr zcon cnv = do pure event getCodeH :: - Members '[CodeStore, ConversationStore] r => + Members '[CodeStore, ConversationStore, WaiError] r => UserId ::: ConvId -> Galley r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv getCode :: - Members '[CodeStore, ConversationStore] r => + Members '[CodeStore, ConversationStore, WaiError] r => UserId -> ConvId -> Galley r Public.ConversationCode @@ -649,13 +653,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, WaiError] 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, WaiError] r => + Public.ConversationCode -> + Galley r () checkReusableCode convCode = void $ verifyReusableCode convCode @@ -668,7 +678,8 @@ joinConversationByReusableCodeH :: ExternalAccess, GundeckAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> @@ -686,7 +697,8 @@ joinConversationByReusableCode :: ExternalAccess, GundeckAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -705,7 +717,8 @@ joinConversationByIdH :: ExternalAccess, GundeckAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId ::: ConnId ::: ConvId ::: JSON -> @@ -721,7 +734,8 @@ joinConversationById :: ExternalAccess, GundeckAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -739,7 +753,8 @@ joinConversation :: ExternalAccess, GundeckAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -811,8 +826,8 @@ performAddMemberAction qusr conv invited role = do 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 + liftSem . when (maybe True (view managedConversation) tcv) $ + throw noAddToManaged ensureConnectedOrSameTeam qusr newUsers checkLocals _ Nothing newUsers = do ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) @@ -824,14 +839,14 @@ performAddMemberAction qusr conv invited role = do -- remote members to the database unless (null remotes) $ do endpoint <- federatorEndpoint - when (isNothing endpoint) $ - throwM federationNotConfigured + liftSem . when (isNothing endpoint) $ + throw federationNotConfigured loc <- qualifyLocal () foldQualified loc ensureConnectedToRemotes - (\_ _ -> throwM federationNotImplemented) + (\_ _ -> liftSem (throw federationNotImplemented)) qusr remotes @@ -897,7 +912,7 @@ addMembers zusr zcon cnv (Public.InviteQualified users role) = do ConversationActionAddMembers users role updateSelfMember :: - Members '[ConversationStore, GundeckAccess, ExternalAccess, MemberStore] r => + Members '[ConversationStore, GundeckAccess, ExternalAccess, MemberStore, WaiError] r => UserId -> ConnId -> Qualified ConvId -> @@ -979,7 +994,7 @@ updateOtherMember zusr zcon qcnv qvictim update = do doUpdate qcnv lusr zcon qvictim update updateOtherMemberLocalConv :: - Members UpdateConversationActions r => + (Members UpdateConversationActions r) => Local ConvId -> Local UserId -> ConnId -> @@ -987,19 +1002,20 @@ 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 updateOtherMemberRemoteConv :: + Member WaiError r => Remote ConvId -> Local UserId -> ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> Galley r () -updateOtherMemberRemoteConv _ _ _ _ _ = throwM federationNotImplemented +updateOtherMemberRemoteConv _ _ _ _ _ = liftSem $ throw federationNotImplemented removeMemberUnqualified :: Members UpdateConversationActions r => @@ -1085,7 +1101,7 @@ data OtrResult | OtrUnknownClient !Public.UnknownClient | OtrConversationNotFound !Public.ConvNotFound -handleOtrResult :: OtrResult -> Galley r Response +handleOtrResult :: Member WaiError r => OtrResult -> Galley r Response handleOtrResult = \case OtrSent m -> pure $ json m & setStatus status201 OtrMissingRecipients m -> pure $ json m & setStatus status412 @@ -1102,7 +1118,8 @@ postBotMessageH :: GundeckAccess, ExternalAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> @@ -1122,7 +1139,8 @@ postBotMessage :: GundeckAccess, ExternalAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => BotId -> @@ -1143,7 +1161,8 @@ postProteusMessage :: GundeckAccess, ExternalAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -1169,7 +1188,8 @@ postOtrMessageUnqualified :: GundeckAccess, ExternalAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -1206,7 +1226,7 @@ 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, GundeckAccess, TeamStore, WaiError] r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> Galley r Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do @@ -1215,7 +1235,7 @@ postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcastH :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => + Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore, WaiError] r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> Galley r Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do @@ -1224,7 +1244,7 @@ postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcast :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => + Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore, WaiError] r => UserId -> ConnId -> Public.OtrFilterMissing -> @@ -1244,7 +1264,7 @@ allowOtrFilterMissingInBody val (NewOtrMessage _ _ _ _ _ _ mrepmiss) = case mrep -- | bots are not supported on broadcast postNewOtrBroadcast :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore] r => + Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore, WaiError] r => UserId -> Maybe ConnId -> OtrFilterMissing -> @@ -1269,7 +1289,8 @@ postNewOtrMessage :: ExternalAccess, GundeckAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserType -> @@ -1338,7 +1359,7 @@ updateConversationName zusr zcon qcnv convRename = do foldQualified lusr (updateLocalConversationName lusr zcon) - (\_ _ -> throwM federationNotImplemented) + (\_ _ -> liftSem (throw federationNotImplemented)) qcnv convRename @@ -1402,7 +1423,7 @@ notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = d pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e isTypingH :: - Members '[GundeckAccess, MemberStore] r => + Members '[GundeckAccess, MemberStore, WaiError] r => UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> Galley r Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do @@ -1411,7 +1432,7 @@ isTypingH (zusr ::: zcon ::: cnv ::: req) = do pure empty isTyping :: - Members '[GundeckAccess, MemberStore] r => + Members '[GundeckAccess, MemberStore, WaiError] r => UserId -> ConnId -> ConvId -> @@ -1433,12 +1454,12 @@ isTyping zusr zcon cnv typingData = do & pushRoute .~ RouteDirect & pushTransient .~ True -addServiceH :: Member ServiceStore r => JsonRequest Service -> Galley r Response +addServiceH :: Members '[ServiceStore, WaiError] 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 '[ServiceStore, WaiError] r => JsonRequest ServiceRef -> Galley r Response rmServiceH req = do liftSem . E.deleteService =<< fromJsonBody req return empty @@ -1450,7 +1471,8 @@ addBotH :: ExternalAccess, GundeckAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId ::: ConnId ::: JsonRequest AddBot -> @@ -1467,7 +1489,8 @@ addBot :: ExternalAccess, GundeckAccess, MemberStore, - TeamStore + TeamStore, + WaiError ] r => UserId -> @@ -1517,11 +1540,12 @@ 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, ExternalAccess, GundeckAccess, MemberStore, WaiError] r => UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley r Response rmBotH (zusr ::: zcon ::: req) = do @@ -1529,7 +1553,15 @@ rmBotH (zusr ::: zcon ::: req) = do handleUpdateResult <$> rmBot zusr zcon bot rmBot :: - Members '[ClientStore, ConversationStore, ExternalAccess, GundeckAccess, MemberStore] r => + Members + '[ ClientStore, + ConversationStore, + ExternalAccess, + GundeckAccess, + MemberStore, + WaiError + ] + r => UserId -> Maybe ConnId -> RemoveBot -> @@ -1561,14 +1593,14 @@ rmBot zusr zcon b = do ------------------------------------------------------------------------------- -- Helpers -ensureMemberLimit :: Foldable f => [LocalMember] -> f a -> Galley r () +ensureMemberLimit :: (Foldable f, Member WaiError r) => [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 + liftSem . when (length old + length new > maxSize) $ + throw tooManyMembers -ensureConvMember :: [LocalMember] -> UserId -> Galley r () +ensureConvMember :: Member WaiError r => [LocalMember] -> UserId -> Galley r () ensureConvMember users usr = unless (usr `isMember` users) $ throwErrorDescriptionType @ConvNotFound @@ -1589,7 +1621,8 @@ data CheckedOtrRecipients -- | bots are not supported on broadcast withValidOtrBroadcastRecipients :: - Members '[BrigAccess, ClientStore, TeamStore] r => + forall r. + Members '[BrigAccess, ClientStore, TeamStore, WaiError] r => UserId -> ClientId -> OtrRecipients -> @@ -1600,8 +1633,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 +1658,18 @@ 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, MemberStore, TeamStore, WaiError] r => UserType -> UserId -> ClientId -> @@ -1663,7 +1697,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, TeamStore, WaiError] r => -- | Type of proposed sender (user / bot) UserType -> -- | Proposed sender (user) @@ -1775,10 +1809,10 @@ 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 '[TeamStore, WaiError] 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 case binding of Binding -> callback tid - NonBinding -> throwM nonBindingTeam + NonBinding -> liftSem $ throw nonBindingTeam diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 5f434712e39..f635f3ab8e4 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -23,9 +23,9 @@ 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.Error (ExceptT, hoistEither) +import qualified Control.Error import Control.Lens (set, view, (.~), (^.)) -import Control.Monad.Catch import Control.Monad.Except (runExceptT) import Control.Monad.Extra (allM, anyM, eitherM) import Data.ByteString.Conversion @@ -65,7 +65,8 @@ 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.Error import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action (ConversationAction (..), conversationActionTag) import Wire.API.ErrorDescription @@ -74,7 +75,11 @@ import Wire.API.Federation.Error (federationNotImplemented) type JSON = Media "application" "json" -ensureAccessRole :: Member BrigAccess r => AccessRole -> [(UserId, Maybe TeamMember)] -> Galley r () +ensureAccessRole :: + Members '[BrigAccess, WaiError] r => + AccessRole -> + [(UserId, Maybe TeamMember)] -> + Galley r () ensureAccessRole role users = case role of PrivateAccessRole -> throwErrorDescriptionType @ConvAccessDenied TeamAccessRole -> @@ -92,7 +97,7 @@ 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 => + Members '[BrigAccess, TeamStore, WaiError] r => Qualified UserId -> [UserId] -> Galley r () @@ -113,12 +118,16 @@ ensureConnectedOrSameTeam (Qualified u domain) uids = do -- 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, WaiError] 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, WaiError] r => UserId -> [UserId] -> Galley r () ensureConnectedToLocals _ [] = pure () ensureConnectedToLocals u uids = do (connsFrom, connsTo) <- @@ -127,35 +136,37 @@ ensureConnectedToLocals u uids = do unless (length connsFrom == length uids && length connsTo == length uids) $ throwErrorDescriptionType @NotConnected -ensureConnectedToRemotes :: Member BrigAccess r => Local UserId -> [Remote UserId] -> Galley r () +ensureConnectedToRemotes :: + Members '[BrigAccess, WaiError] 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 + throw $ errorDescriptionTypeToWai @NotConnected -ensureReAuthorised :: Member BrigAccess r => UserId -> Maybe PlainTextPassword -> Galley r () -ensureReAuthorised u secret = do - reAuthed <- liftSem $ reauthUser u (ReAuthUser secret) +ensureReAuthorised :: Members '[BrigAccess, WaiError] 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 :: (IsConvMember mem, Member WaiError r) => Action -> mem -> Galley r () ensureActionAllowed action self = case isActionAllowed action (convMemberRole self) of Just True -> pure () Just False -> throwErrorDescription (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 -> liftSem $ throw (badRequest "Custom roles not supported") -- | Comprehensive permission check, taking action-specific logic into account. ensureConversationActionAllowed :: - (IsConvMember mem, Member TeamStore r) => + (IsConvMember mem, Members '[TeamStore, WaiError] r) => ConversationAction -> Data.Conversation -> mem -> @@ -181,7 +192,7 @@ ensureConversationActionAllowed action conv self = do liftSem (getTeamMember tid (tUnqualified lusr)) >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) ) - (\_ -> throwM federationNotImplemented) + (\_ -> liftSem (throw federationNotImplemented)) (convMemberId loc self) Nothing -> pure () ConversationActionAccessUpdate target -> do @@ -198,8 +209,8 @@ ensureConversationActionAllowed action conv self = do 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 + liftSem . when (maybe False (view managedConversation) tcv) $ + throw 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 @@ -208,30 +219,38 @@ ensureConversationActionAllowed action conv self = do throwErrorDescriptionType @InvalidTargetAccess _ -> pure () -ensureGroupConvThrowing :: Data.Conversation -> Galley r () -ensureGroupConvThrowing conv = case Data.convType conv of - SelfConv -> throwM invalidSelfOp - One2OneConv -> throwM invalidOne2OneOp - ConnectConv -> throwM invalidConnectOp +ensureGroupConvThrowing :: Member WaiError r => Data.Conversation -> Galley r () +ensureGroupConvThrowing conv = liftSem $ case Data.convType conv of + SelfConv -> throw invalidSelfOp + One2OneConv -> throw invalidOne2OneOp + ConnectConv -> throw invalidConnectOp _ -> pure () -- | 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, Member WaiError 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 invalidActions (_, _) -> - throwM (badRequest "Custom roles not supported") + throw (badRequest "Custom roles not supported") -- | 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 :: + (IsPerm perm, Show perm, Member WaiError r) => + perm -> + Maybe TeamMember -> + Galley r TeamMember permissionCheck p = \case Just m -> do if m `hasPermission` p @@ -239,14 +258,14 @@ permissionCheck p = \case else throwErrorDescription (operationDenied p) Nothing -> throwErrorDescriptionType @NotATeamMember -assertTeamExists :: Members '[TeamStore] r => TeamId -> Galley r () +assertTeamExists :: Members '[TeamStore, WaiError] r => TeamId -> Galley r () assertTeamExists tid = do teamExists <- liftSem $ isJust <$> getTeam tid if teamExists then pure () - else throwM teamNotFound + else liftSem $ throw teamNotFound -assertOnTeam :: Members '[TeamStore] r => UserId -> TeamId -> Galley r () +assertOnTeam :: Members '[TeamStore, WaiError] r => UserId -> TeamId -> Galley r () assertOnTeam uid tid = do liftSem (getTeamMember tid uid) >>= \case Nothing -> throwErrorDescriptionType @NotATeamMember @@ -255,7 +274,7 @@ assertOnTeam uid tid = do -- | 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, TeamStore, WaiError] r => UserId -> ConvId -> Perm -> @@ -269,7 +288,7 @@ permissionCheckTeamConv zusr cnv perm = -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: - Members '[ConversationStore, MemberStore, GundeckAccess] r => + Members '[ConversationStore, MemberStore, GundeckAccess, WaiError] r => UserId -> Data.Conversation -> Maybe ConnId -> @@ -289,7 +308,7 @@ acceptOne2One usr conv conn = do [_, _] -> throwErrorDescriptionType @ConvNotFound _ -> do when (length mems > 2) $ - throwM badConvState + liftSem $ throw badConvState now <- liftIO getCurrentTime mm <- liftSem $ createMember lcid lusr let e = memberJoinEvent lusr (qUntagged lcid) now mm [] @@ -298,7 +317,7 @@ 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" + _ -> liftSem . throw $ invalidOp "accept: invalid conversation type" where cid = Data.convId conv mems = Data.convLocalMembers conv @@ -306,7 +325,7 @@ acceptOne2One usr conv conn = do acceptConnectConversation cid return $ conv {Data.convType = One2OneConv} badConvState = - mkError status500 "bad-state" $ + Wai.mkError status500 "bad-state" $ "Connect conversation with more than 2 members: " <> LT.pack (show cid) @@ -449,7 +468,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 @@ -470,7 +489,7 @@ membersToRecipients (Just u) = map userRecipient . filter (/= u) . map (view use -- | A legacy version of 'getSelfMemberFromLocals' that runs in the Galley r monad. getSelfMemberFromLocalsLegacy :: - Foldable t => + (Foldable t, Member WaiError r) => UserId -> t LocalMember -> Galley r LocalMember @@ -481,6 +500,7 @@ getSelfMemberFromLocalsLegacy usr lmems = -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). ensureOtherMember :: + Member WaiError r => Local a -> Qualified UserId -> Data.Conversation -> @@ -490,7 +510,11 @@ ensureOtherMember loc quid conv = (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 :: + (Foldable t, Member WaiError r) => + Remote UserId -> + t RemoteMember -> + Galley r RemoteMember getSelfMemberFromRemotesLegacy usr rmems = eitherM throwErrorDescription pure . runExceptT $ getMember rmId (mkErrorDescription :: ConvNotFound) usr rmems @@ -520,10 +544,10 @@ getMember :: -- | A list of members to search t mem -> ExceptT e m mem -getMember p ex u = hoistEither . note ex . find ((u ==) . p) +getMember p ex u = hoistEither . Control.Error.note ex . find ((u ==) . p) getConversationAndCheckMembership :: - Member ConversationStore r => + Members '[ConversationStore, WaiError] r => UserId -> ConvId -> Galley r Data.Conversation @@ -536,8 +560,8 @@ getConversationAndCheckMembership uid cnv = do pure conv getConversationAndMemberWithError :: - (Member ConversationStore r, IsConvMemberId uid mem) => - Error -> + (Members '[ConversationStore, WaiError] r, IsConvMemberId uid mem) => + Wai.Error -> uid -> ConvId -> Galley r (Data.Conversation, mem) @@ -549,9 +573,7 @@ getConversationAndMemberWithError ex usr convId = do liftSem $ deleteConversation convId throwErrorDescriptionType @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,7 +608,7 @@ pushConversationEvent conn e users bots = do liftSem $ deliverAsync (toList bots `zip` repeat e) verifyReusableCode :: - Member CodeStore r => + Members '[CodeStore, WaiError] r => ConversationCode -> Galley r DataTypes.Code verifyReusableCode convCode = do @@ -594,11 +616,11 @@ verifyReusableCode convCode = do liftSem (getCode (conversationKey convCode) DataTypes.ReusableCode) >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) unless (DataTypes.codeValue c == conversationCode convCode) $ - throwM (errorDescriptionTypeToWai @CodeNotFound) + liftSem $ throw (errorDescriptionTypeToWai @CodeNotFound) return c ensureConversationAccess :: - Members '[BrigAccess, ConversationStore, TeamStore] r => + Members '[BrigAccess, ConversationStore, TeamStore, WaiError] r => UserId -> ConvId -> Access -> @@ -614,7 +636,7 @@ ensureConversationAccess zusr cnv access = do ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] pure conv -ensureAccess :: Data.Conversation -> Access -> Galley r () +ensureAccess :: Member WaiError r => Data.Conversation -> Access -> Galley r () ensureAccess conv access = unless (access `elem` Data.convAccess conv) $ throwErrorDescriptionType @ConvAccessDenied diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index bdb74e49923..0244df74a90 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -44,6 +44,7 @@ module Galley.App ask, DeleteItem (..), toServantHandler, + WaiError, -- * Utilities ifNothing, @@ -52,6 +53,8 @@ module Galley.App fromProtoBody, fanoutLimit, currentFanoutLimit, + throwErrorDescription, + throwErrorDescriptionType, -- * MonadUnliftIO / Sem compatibility fireAndForget, @@ -84,6 +87,7 @@ import Data.Serialize.Get (runGetLazy) import Data.Text (unpack) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import GHC.TypeLits import Galley.API.Error import qualified Galley.Aws as Aws import Galley.Cassandra.Client @@ -116,20 +120,23 @@ 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 import qualified Servant +import Servant.API.Status (KnownStatus (..)) import Ssl.Util import System.Logger.Class import qualified System.Logger.Extended as Logger import qualified UnliftIO.Exception as UnliftIO import Util.Options +import Wire.API.ErrorDescription import Wire.API.Federation.Client (HasFederatorConfig (..)) -- MTL-style effects derived from the old implementation of the Galley monad. @@ -140,6 +147,8 @@ type GalleyEffects = Append GalleyEffects1 GalleyEffects0 type Galley0 = Galley GalleyEffects0 +type WaiError = Error Wai.Error + newtype Galley r a = Galley {unGalley :: Members GalleyEffects0 r => Sem r a} instance Functor (Galley r) where @@ -156,9 +165,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 +284,41 @@ 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 WaiError r, FromJSON a) => JsonRequest a -> Galley r a +fromJsonBody r = exceptT (liftSem . throw @Wai.Error . 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 WaiError r, FromJSON a) => OptionalJsonRequest a -> Galley r (Maybe a) +fromOptionalJsonBody r = exceptT (liftSem . throw @Wai.Error . invalidPayload) return (parseOptionalBody r) {-# INLINE fromOptionalJsonBody #-} -fromProtoBody :: Proto.Decode a => Request -> Galley r a +fromProtoBody :: (Member WaiError 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 @Wai.Error . invalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) {-# INLINE fromProtoBody #-} -ifNothing :: WaiError.Error -> Maybe a -> Galley r a -ifNothing e = maybe (throwM e) return +ifNothing :: Member WaiError r => Wai.Error -> Maybe a -> Galley r a +ifNothing e = maybe (liftSem (throw e)) return {-# INLINE ifNothing #-} +throwErrorDescription :: + (KnownStatus code, KnownSymbol lbl, Member WaiError r) => + ErrorDescription code lbl desc -> + Galley r a +throwErrorDescription = liftSem . throw . errorDescriptionToWai + +throwErrorDescriptionType :: + forall e (code :: Nat) (lbl :: Symbol) (desc :: Symbol) r a. + ( KnownStatus code, + KnownSymbol lbl, + KnownSymbol desc, + Member WaiError r, + e ~ ErrorDescription code lbl desc + ) => + Galley r a +throwErrorDescriptionType = throwErrorDescription (mkErrorDescription :: e) + toServantHandler :: Env -> Galley GalleyEffects a -> Servant.Handler a toServantHandler env galley = do eith <- liftIO $ Control.Exception.try (evalGalley env galley) @@ -304,14 +327,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 +345,16 @@ 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 . interpretInternalTeamListToCassandra . interpretTeamListToCassandra . interpretLegacyConversationListToCassandra @@ -376,6 +406,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/Effects.hs b/services/galley/src/Galley/Effects.hs index e2f26dea92f..ca9817cd8f5 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -78,7 +78,9 @@ 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 -- All the possible high-level effects. type GalleyEffects1 = @@ -105,5 +107,6 @@ type GalleyEffects1 = ListItems CassandraPaging (Remote ConvId), ListItems LegacyPaging ConvId, ListItems LegacyPaging TeamId, - ListItems InternalPaging TeamId + ListItems InternalPaging TeamId, + Error (Wai.Error) ] diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index 1c4a3038ecb..6daee51417d 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,14 @@ 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 WaiError 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 +83,7 @@ checkLegalHoldServiceStatus fpr url = do -- | @POST /initiate@. requestNewDevice :: - Member LegalHoldStore r => + Members '[LegalHoldStore, WaiError] r => TeamId -> UserId -> Galley r NewLegalHoldClient @@ -91,7 +92,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 +105,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 '[LegalHoldStore, WaiError] r => ClientId -> TeamId -> UserId -> @@ -124,7 +125,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 '[LegalHoldStore, WaiError] r => TeamId -> UserId -> Galley r () @@ -145,14 +146,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 '[LegalHoldStore, WaiError] 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..b0ee789de4a 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -25,21 +25,22 @@ 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 qualified Network.Wai.Utilities as Wai +import Polysemy +import Polysemy.Error -rangeChecked :: (MonadThrow galley, Within a n m) => a -> galley (Range n m a) +rangeChecked :: (Member (Error Wai.Error) 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 Wai.Error) 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 +50,16 @@ newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} deriving (Functor, Foldable, Traversable) checkedConvSize :: - (MonadReader Env galley, MonadThrow galley, Foldable f) => + (Member (Error Wai.Error) 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 Wai.Error) r => String -> Sem r a +throwErr = throw . invalidRange . fromString From 25289e75a9d97d00776b518d76c7aae30b3cb215 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 4 Nov 2021 08:22:27 +0100 Subject: [PATCH 02/10] Throw error descriptions into Sem monad --- services/galley/src/Galley/API/Create.hs | 2 +- services/galley/src/Galley/API/Internal.hs | 2 +- services/galley/src/Galley/API/Query.hs | 4 +- services/galley/src/Galley/API/Teams.hs | 18 ++--- services/galley/src/Galley/API/Update.hs | 32 +++++---- services/galley/src/Galley/API/Util.hs | 82 ++++++++++++---------- services/galley/src/Galley/App.hs | 6 +- 7 files changed, 77 insertions(+), 69 deletions(-) diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index b388d5c1d6a..0f6e445cb9f 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -139,7 +139,7 @@ ensureNoLegalholdConflicts remotes locals = do let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes whenM (anyLegalholdActivated locals) $ unlessM (allLegalholdConsentGiven locals) $ - throwErrorDescriptionType @MissingLegalholdConsent + liftSem $ throwErrorDescriptionType @MissingLegalholdConsent -- | A helper for creating a regular (non-team) group conversation. createRegularGroupConv :: diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index bbc74cb720c..9eadbfe2abd 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -634,5 +634,5 @@ guardLegalholdPolicyConflictsH :: guardLegalholdPolicyConflictsH (req ::: _) = do glh <- fromJsonBody req guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) - >>= either (const (throwErrorDescriptionType @MissingLegalholdConsent)) pure + >>= either (const (liftSem (throwErrorDescriptionType @MissingLegalholdConsent))) pure pure $ Network.Wai.Utilities.setStatus status200 empty diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index b8916bcf4db..44424253a68 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -131,10 +131,10 @@ getConversation zusr cnv = do getRemoteConversation :: Remote ConvId -> Galley r Public.Conversation getRemoteConversation remoteConvId = do conversations <- getRemoteConversations zusr [remoteConvId] - case conversations of + liftSem $ case conversations of [] -> throwErrorDescriptionType @ConvNotFound [conv] -> pure conv - _convs -> liftSem $ throw (federationUnexpectedBody "expected one conversation, got multiple") + _convs -> throw (federationUnexpectedBody "expected one conversation, got multiple") getRemoteConversations :: Members '[ConversationStore, WaiError] r => diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 112d5779066..fd809cb03e5 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -1010,13 +1010,13 @@ getTeamConversations :: 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 + >>= note (errorDescriptionTypeToWai @NotATeamMember) unless (tm `hasPermission` GetTeamConversations) $ throwErrorDescription (operationDenied GetTeamConversations) - liftSem $ Public.newTeamConversationList <$> E.getTeamConversations tid + Public.newTeamConversationList <$> E.getTeamConversations tid getTeamConversation :: Members '[TeamStore, WaiError] r => @@ -1024,14 +1024,14 @@ getTeamConversation :: 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 + >>= note (errorDescriptionTypeToWai @NotATeamMember) unless (tm `hasPermission` GetTeamConversations) $ throwErrorDescription (operationDenied GetTeamConversations) - liftSem (E.getTeamConversation tid cid) - >>= maybe (throwErrorDescriptionType @ConvNotFound) pure + E.getTeamConversation tid cid + >>= note (errorDescriptionTypeToWai @ConvNotFound) deleteTeamConversation :: Members diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index a3a853374ea..b05c4104c09 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -857,11 +857,11 @@ performAddMemberAction qusr conv invited role = do allNewUsersGaveConsent <- allLegalholdConsentGiven newUsers whenM (anyLegalholdActivated (lmId <$> convUsers)) $ - unless allNewUsersGaveConsent $ + liftSem . unless allNewUsersGaveConsent $ throwErrorDescriptionType @MissingLegalholdConsent whenM (anyLegalholdActivated newUsers) $ do - unless allNewUsersGaveConsent $ + liftSem . unless allNewUsersGaveConsent $ throwErrorDescriptionType @MissingLegalholdConsent convUsersLHStatus <- do @@ -881,7 +881,7 @@ performAddMemberAction qusr conv invited role = do void . runMaybeT $ updateLocalConversation lcnv qvictim Nothing $ ConversationActionRemoveMembers (pure qvictim) - else throwErrorDescriptionType @MissingLegalholdConsent + else liftSem $ throwErrorDescriptionType @MissingLegalholdConsent checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley r () checkLHPolicyConflictsRemote _remotes = pure () @@ -921,7 +921,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 (throwErrorDescriptionType @ConvNotFound) liftSem $ E.setSelfMember qcnv lusr update now <- liftIO getCurrentTime let e = Event MemberStateUpdate qcnv (qUntagged lusr) now (EdMemberUpdate (updateData lusr)) @@ -1102,11 +1102,12 @@ data OtrResult | OtrConversationNotFound !Public.ConvNotFound handleOtrResult :: Member WaiError r => 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 = + liftSem . \case + OtrSent m -> pure $ json m & setStatus status201 + OtrMissingRecipients m -> pure $ json m & setStatus status412 + OtrUnknownClient _ -> throwErrorDescriptionType @UnknownClient + OtrConversationNotFound _ -> throwErrorDescriptionType @ConvNotFound postBotMessageH :: Members @@ -1443,7 +1444,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) $ + liftSem . unless (zusr `isMember` mm) $ throwErrorDescriptionType @ConvNotFound now <- liftIO getCurrentTime let e = Event Typing qcnv qusr now (EdTyping typingData) @@ -1529,7 +1530,7 @@ addBot zusr zcon b = do where regularConvChecks lusr c = do let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) - unless (zusr `isMember` users) $ + liftSem . unless (zusr `isMember` users) $ throwErrorDescriptionType @ConvNotFound ensureGroupConvThrowing c ensureActionAllowed AddConversationMember =<< getSelfMemberFromLocalsLegacy zusr users @@ -1573,7 +1574,7 @@ rmBot zusr zcon b = do localDomain <- viewFederationDomain let qcnv = Qualified (Data.convId c) localDomain qusr = Qualified zusr localDomain - unless (zusr `isMember` Data.convLocalMembers c) $ + liftSem . unless (zusr `isMember` Data.convLocalMembers c) $ throwErrorDescriptionType @ConvNotFound let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) if not (any ((== b ^. rmBotId) . botMemId) bots) @@ -1602,8 +1603,9 @@ ensureMemberLimit old new = do ensureConvMember :: Member WaiError r => [LocalMember] -> UserId -> Galley r () ensureConvMember users usr = - unless (usr `isMember` users) $ - throwErrorDescriptionType @ConvNotFound + liftSem $ + unless (usr `isMember` users) $ + throwErrorDescriptionType @ConvNotFound ------------------------------------------------------------------------------- -- OtrRecipients Validation @@ -1721,7 +1723,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 (throwErrorDescriptionType @MissingLegalholdConsent))) pure pure (OtrMissingRecipients m) InvalidOtrSenderUser -> pure $ OtrConversationNotFound mkErrorDescription InvalidOtrSenderClient -> pure $ OtrUnknownClient mkErrorDescription diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index f635f3ab8e4..a49d070603e 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -80,13 +80,13 @@ ensureAccessRole :: AccessRole -> [(UserId, Maybe TeamMember)] -> Galley r () -ensureAccessRole role users = case role of +ensureAccessRole role users = liftSem $ case role of PrivateAccessRole -> throwErrorDescriptionType @ConvAccessDenied TeamAccessRole -> when (any (isNothing . snd) users) $ throwErrorDescriptionType @NotATeamMember ActivatedAccessRole -> do - activated <- liftSem $ lookupActivatedUsers $ map fst users + activated <- lookupActivatedUsers $ map fst users when (length activated /= length users) $ throwErrorDescriptionType @ConvAccessDenied NonActivatedAccessRole -> return () @@ -129,10 +129,9 @@ ensureConnected self others = do ensureConnectedToLocals :: Members '[BrigAccess, WaiError] 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 @@ -157,12 +156,12 @@ ensureReAuthorised u secret = liftSem $ do -- is permitted. If the user does not have the given permission, throw -- 'operationDenied'. ensureActionAllowed :: (IsConvMember mem, Member WaiError r) => Action -> mem -> Galley r () -ensureActionAllowed action self = case isActionAllowed action (convMemberRole self) of +ensureActionAllowed action self = liftSem $ case isActionAllowed action (convMemberRole self) of Just True -> pure () Just False -> throwErrorDescription (actionDenied action) -- Actually, this will "never" happen due to the -- fact that there can be no custom roles at the moment - Nothing -> liftSem $ throw (badRequest "Custom roles not supported") + Nothing -> throw (badRequest "Custom roles not supported") -- | Comprehensive permission check, taking action-specific logic into account. ensureConversationActionAllowed :: @@ -199,10 +198,11 @@ ensureConversationActionAllowed action 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' - when - ( PrivateAccess `elem` Public.cupAccess target - || PrivateAccessRole == Public.cupAccessRole target - ) + liftSem + . when + ( PrivateAccess `elem` Public.cupAccess target + || PrivateAccessRole == Public.cupAccessRole target + ) $ throwErrorDescriptionType @InvalidTargetAccess -- Team conversations incur another round of checks case Data.convTeam conv of @@ -216,7 +216,7 @@ ensureConversationActionAllowed action conv self = do ensureActionAllowed RemoveConversationMember self Nothing -> when (Public.cupAccessRole target == TeamAccessRole) $ - throwErrorDescriptionType @InvalidTargetAccess + liftSem $ throwErrorDescriptionType @InvalidTargetAccess _ -> pure () ensureGroupConvThrowing :: Member WaiError r => Data.Conversation -> Galley r () @@ -251,25 +251,27 @@ permissionCheck :: 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 +permissionCheck p = + liftSem . \case + Just m -> do + if m `hasPermission` p + then pure m + else throwErrorDescription (operationDenied p) + Nothing -> throwErrorDescriptionType @NotATeamMember assertTeamExists :: Members '[TeamStore, WaiError] r => TeamId -> Galley r () -assertTeamExists tid = do - teamExists <- liftSem $ isJust <$> getTeam tid +assertTeamExists tid = liftSem $ do + teamExists <- isJust <$> getTeam tid if teamExists then pure () - else liftSem $ throw teamNotFound + else throw teamNotFound assertOnTeam :: Members '[TeamStore, WaiError] r => UserId -> TeamId -> Galley r () -assertOnTeam uid tid = do - liftSem (getTeamMember tid uid) >>= \case - Nothing -> throwErrorDescriptionType @NotATeamMember - Just _ -> return () +assertOnTeam uid tid = + liftSem $ + getTeamMember tid uid >>= \case + Nothing -> throwErrorDescriptionType @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). @@ -284,7 +286,7 @@ 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 $ throwErrorDescriptionType @ConvNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: @@ -305,7 +307,7 @@ acceptOne2One usr conv conn = do return $ conv {Data.convLocalMembers = mems <> toList mm} ConnectConv -> case mems of [_, _] | usr `isMember` mems -> liftSem promote - [_, _] -> throwErrorDescriptionType @ConvNotFound + [_, _] -> liftSem $ throwErrorDescriptionType @ConvNotFound _ -> do when (length mems > 2) $ liftSem $ throw badConvState @@ -494,8 +496,9 @@ getSelfMemberFromLocalsLegacy :: t LocalMember -> Galley r LocalMember getSelfMemberFromLocalsLegacy usr lmems = - eitherM throwErrorDescription pure . runExceptT $ - getMember lmId (mkErrorDescription :: ConvNotFound) usr lmems + liftSem $ + eitherM throwErrorDescription pure . runExceptT $ + getMember lmId (mkErrorDescription :: ConvNotFound) usr lmems -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). @@ -506,8 +509,9 @@ ensureOtherMember :: Data.Conversation -> Galley r (Either LocalMember RemoteMember) ensureOtherMember loc quid conv = - maybe (throwErrorDescriptionType @ConvMemberNotFound) pure $ - (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) + liftSem + . maybe (throwErrorDescriptionType @ConvMemberNotFound) pure + $ (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) <|> (Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv)) getSelfMemberFromRemotesLegacy :: @@ -516,8 +520,10 @@ getSelfMemberFromRemotesLegacy :: t RemoteMember -> Galley r RemoteMember getSelfMemberFromRemotesLegacy usr rmems = - eitherM throwErrorDescription pure . runExceptT $ - getMember rmId (mkErrorDescription :: ConvNotFound) usr rmems + liftSem + . eitherM throwErrorDescription pure + . runExceptT + $ getMember rmId (mkErrorDescription :: ConvNotFound) usr rmems getQualifiedMember :: Monad m => @@ -569,8 +575,8 @@ getConversationAndMemberWithError ex usr convId = do c <- liftSem (getConversation convId) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) - when (DataTypes.isConvDeleted c) $ do - liftSem $ deleteConversation convId + liftSem . when (DataTypes.isConvDeleted c) $ do + deleteConversation convId throwErrorDescriptionType @ConvNotFound loc <- qualifyLocal () member <- liftSem . note ex $ getConvMember loc c usr @@ -627,8 +633,8 @@ ensureConversationAccess :: Galley r Data.Conversation ensureConversationAccess zusr cnv access = do conv <- - liftSem (getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + liftSem $ + getConversation cnv >>= note (errorDescriptionTypeToWai @ConvNotFound) ensureAccess conv access zusrMembership <- liftSem $ @@ -638,7 +644,7 @@ ensureConversationAccess zusr cnv access = do ensureAccess :: Member WaiError r => Data.Conversation -> Access -> Galley r () ensureAccess conv access = - unless (access `elem` Data.convAccess conv) $ + liftSem . unless (access `elem` Data.convAccess conv) $ throwErrorDescriptionType @ConvAccessDenied -------------------------------------------------------------------------------- diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 0244df74a90..ff190dbd16a 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -305,8 +305,8 @@ ifNothing e = maybe (liftSem (throw e)) return throwErrorDescription :: (KnownStatus code, KnownSymbol lbl, Member WaiError r) => ErrorDescription code lbl desc -> - Galley r a -throwErrorDescription = liftSem . throw . errorDescriptionToWai + Sem r a +throwErrorDescription = throw . errorDescriptionToWai throwErrorDescriptionType :: forall e (code :: Nat) (lbl :: Symbol) (desc :: Symbol) r a. @@ -316,7 +316,7 @@ throwErrorDescriptionType :: Member WaiError r, e ~ ErrorDescription code lbl desc ) => - Galley r a + Sem r a throwErrorDescriptionType = throwErrorDescription (mkErrorDescription :: e) toServantHandler :: Env -> Galley GalleyEffects a -> Servant.Handler a From 1d750e551102655273ba40d1ea6000c30b34d125 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 4 Nov 2021 08:32:27 +0100 Subject: [PATCH 03/10] Refactor ensureConnectedOrSameTeam --- services/galley/src/Galley/API/Update.hs | 32 +++++++++++------------- services/galley/src/Galley/API/Util.hs | 23 +++++++++-------- 2 files changed, 26 insertions(+), 29 deletions(-) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index b05c4104c09..944f62621ab 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -800,7 +800,9 @@ addMembersToLocalConversation lcnv users role = do performAddMemberAction :: forall r. - Members UpdateConversationActions r => + ( Members UpdateConversationActions r, + Member WaiError r + ) => Qualified UserId -> Data.Conversation -> NonEmpty (Qualified UserId) -> @@ -808,47 +810,41 @@ performAddMemberAction :: MaybeT (Galley r) (BotsAndMembers, ConversationAction) performAddMemberAction qusr conv invited role = do lcnv <- lift $ qualifyLocal (Data.convId conv) + lusr <- lift . liftSem $ ensureLocal lcnv qusr 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) + checkLocals lusr lcnv (Data.convTeam conv) (ulLocals newMembers) + checkRemotes lusr (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 + checkLocals :: Local UserId -> Local ConvId -> Maybe TeamId -> [UserId] -> Galley r () + checkLocals lusr 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) liftSem . when (maybe True (view managedConversation) tcv) $ throw noAddToManaged - ensureConnectedOrSameTeam qusr newUsers - checkLocals _ Nothing newUsers = do + ensureConnectedOrSameTeam lusr newUsers + checkLocals lusr _ Nothing newUsers = do ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) - ensureConnectedOrSameTeam qusr newUsers + ensureConnectedOrSameTeam lusr newUsers - checkRemotes :: [Remote UserId] -> Galley r () - checkRemotes remotes = do + checkRemotes :: 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 - - loc <- qualifyLocal () - foldQualified - loc - ensureConnectedToRemotes - (\_ _ -> liftSem (throw federationNotImplemented)) - qusr - remotes + ensureConnectedToRemotes lusr remotes checkLHPolicyConflictsLocal :: Local ConvId -> [UserId] -> Galley r () checkLHPolicyConflictsLocal lcnv newUsers = do diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index a49d070603e..7d8d9a327c8 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -66,6 +66,7 @@ import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error) 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) @@ -98,20 +99,17 @@ ensureAccessRole role users = liftSem $ case role of -- for non-team-members of the _given_ user ensureConnectedOrSameTeam :: Members '[BrigAccess, TeamStore, WaiError] r => - Qualified UserId -> + 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. -- @@ -647,6 +645,9 @@ ensureAccess conv access = liftSem . unless (access `elem` Data.convAccess conv) $ throwErrorDescriptionType @ConvAccessDenied +ensureLocal :: Member WaiError r => Local x -> Qualified a -> Sem r (Local a) +ensureLocal loc = foldQualified loc pure (\_ -> throw federationNotImplemented) + -------------------------------------------------------------------------------- -- Federation From 9b5958fcf2525626f99fb13d996bbd72653c7124 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 4 Nov 2021 11:02:06 +0100 Subject: [PATCH 04/10] Introduce some fine-grained error effects --- services/galley/src/Galley/API/Create.hs | 18 ++++- services/galley/src/Galley/API/Error.hs | 64 ++++++++++++++++++ services/galley/src/Galley/API/Federation.hs | 5 +- services/galley/src/Galley/API/LegalHold.hs | 43 +++++++++++- services/galley/src/Galley/API/Query.hs | 16 ++++- services/galley/src/Galley/API/Teams.hs | 13 ++-- .../galley/src/Galley/API/Teams/Features.hs | 5 +- services/galley/src/Galley/API/Update.hs | 34 ++++++++-- services/galley/src/Galley/API/Util.hs | 67 ++++++++++++------- services/galley/src/Galley/App.hs | 1 + services/galley/src/Galley/Cassandra/Code.hs | 3 + services/galley/src/Galley/Effects.hs | 14 ++-- .../galley/src/Galley/Effects/CodeStore.hs | 11 ++- 13 files changed, 244 insertions(+), 50 deletions(-) diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 0f6e445cb9f..0852c32bf85 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -53,8 +53,8 @@ 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) @@ -76,6 +76,9 @@ createGroupConversation :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -98,6 +101,9 @@ internalCreateManagedConversationH :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -115,6 +121,9 @@ internalCreateManagedConversation :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -147,6 +156,7 @@ createRegularGroupConv :: '[ ConversationStore, BrigAccess, FederatorAccess, + Error ActionError, GundeckAccess, LegalHoldStore, TeamStore, @@ -189,6 +199,9 @@ createTeamGroupConv :: Members '[ ConversationStore, BrigAccess, + Error ActionError, + Error ConversationError, + Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, @@ -271,6 +284,7 @@ createOne2OneConversation :: Members '[ BrigAccess, ConversationStore, + Error ActionError, FederatorAccess, GundeckAccess, TeamStore, diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 8e3c32a3029..27f57ae229a 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -27,8 +27,69 @@ 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 ActionError + = InvalidAction + | CustomRolesNotSupported + | InvalidTargetAccess + | ActionDenied Action + | InvalidOp ConvType + | NotConnected + +instance APIError ActionError where + toWai InvalidAction = invalidActions + toWai CustomRolesNotSupported = badRequest "Custom roles not supported" + toWai InvalidTargetAccess = errorDescriptionTypeToWai @InvalidTargetAccess + toWai (ActionDenied action) = errorDescriptionToWai (actionDenied action) + toWai (InvalidOp RegularConv) = invalidOp "invalid operation" + toWai (InvalidOp SelfConv) = invalidSelfOp + toWai (InvalidOp One2OneConv) = invalidOne2OneOp + toWai (InvalidOp ConnectConv) = invalidConnectOp + toWai NotConnected = errorDescriptionTypeToWai @NotConnected + +data ConversationError + = ConvAccessDenied + | ConvNotFound + +instance APIError ConversationError where + toWai ConvAccessDenied = errorDescriptionTypeToWai @ConvAccessDenied + toWai ConvNotFound = errorDescriptionTypeToWai @ConvNotFound + +data TeamError = NotATeamMember + +instance APIError TeamError where + toWai NotATeamMember = errorDescriptionTypeToWai @NotATeamMember + +instance APIError FederationError where + toWai = federationErrorToWai + +type AllErrorEffects = + '[ P.Error ActionError, + P.Error ConversationError, + P.Error TeamError, + P.Error FederationError + ] + +mapAllErrors :: Member (P.Error Error) r => Sem (Append AllErrorEffects r) a -> Sem r a +mapAllErrors = P.mapError toWai . P.mapError toWai . P.mapError toWai . P.mapError toWai + +---------------------------------------------------------------------------- +-- Error description integration errorDescriptionToWai :: forall (code :: Nat) (lbl :: Symbol) (desc :: Symbol). @@ -48,6 +109,9 @@ errorDescriptionTypeToWai :: Error errorDescriptionTypeToWai = errorDescriptionToWai (mkErrorDescription :: e) +---------------------------------------------------------------------------- +-- Other errors + internalError :: Error internalError = internalErrorWithDescription "internal error" diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 665128fcd22..f552590d2b9 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -31,7 +31,7 @@ import Data.Qualified import Data.Range import qualified Data.Set as Set import qualified Data.Text.Lazy as LT -import Galley.API.Error (invalidPayload) +import Galley.API.Error import qualified Galley.API.Mapping as Mapping import Galley.API.Message (MessageMetadata (..), UserType (..), postQualifiedOtrMessage, sendLocalMessages) import Galley.API.Update (notifyConversationMetadataUpdate) @@ -242,6 +242,9 @@ leaveConversation :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error ConversationError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 9ea36e33a31..6a28517da15 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -68,8 +68,8 @@ 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 (..)) @@ -164,6 +164,9 @@ removeSettingsH :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -192,6 +195,9 @@ removeSettings :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -240,6 +246,9 @@ removeSettings' :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -323,6 +332,9 @@ grantConsentH :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -351,6 +363,9 @@ grantConsent :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -384,6 +399,9 @@ requestDeviceH :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -414,6 +432,9 @@ requestDevice :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -477,6 +498,9 @@ approveDeviceH :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -502,6 +526,9 @@ approveDevice :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -564,6 +591,9 @@ disableForUserH :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -594,6 +624,9 @@ disableForUser :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -643,6 +676,9 @@ changeLegalholdStatus :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -775,6 +811,9 @@ handleGroupConvPolicyConflicts :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 44424253a68..a64f68c0d8b 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -62,8 +62,8 @@ 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 Network.Wai.Predicate hiding (Error, result, setStatus) +import Network.Wai.Utilities hiding (Error) import qualified Network.Wai.Utilities.Error as Wai import Polysemy import Polysemy.Error @@ -485,7 +485,17 @@ getConversationMeta cnv = liftSem $ do pure Nothing getConversationByReusableCode :: - Members '[CodeStore, ConversationStore, BrigAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error TeamError, + TeamStore, + WaiError + ] + r => UserId -> Key -> Value -> diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index fd809cb03e5..c8a19d115a8 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -117,8 +117,8 @@ 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 @@ -195,7 +195,7 @@ lookupTeam zusr tid = do else pure Nothing createNonBindingTeamH :: - Members '[GundeckAccess, BrigAccess, TeamStore, WaiError] r => + Members '[BrigAccess, Error ActionError, GundeckAccess, TeamStore, WaiError] r => UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> Galley r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do @@ -204,7 +204,7 @@ createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do pure (empty & setStatus status201 . location newTeamId) createNonBindingTeam :: - Members '[BrigAccess, GundeckAccess, TeamStore, WaiError] r => + Members '[BrigAccess, Error ActionError, GundeckAccess, TeamStore, WaiError] r => UserId -> ConnId -> Public.NonBindingNewTeam -> @@ -700,6 +700,7 @@ addTeamMemberH :: Members '[ BrigAccess, GundeckAccess, + Error ActionError, LegalHoldStore, MemberStore, TeamFeatureStore, @@ -719,6 +720,7 @@ addTeamMember :: Members '[ BrigAccess, GundeckAccess, + Error ActionError, LegalHoldStore, MemberStore, TeamFeatureStore, @@ -1039,6 +1041,9 @@ deleteTeamConversation :: BrigAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 848bdc788be..016d74877ae 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -73,7 +73,7 @@ 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 @@ -366,6 +366,9 @@ setLegalholdStatusInternal :: BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error ConversationError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 944f62621ab..a8561eb189b 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -121,8 +121,8 @@ 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 @@ -278,6 +278,9 @@ performAccessUpdateAction :: BotAccess, CodeStore, ConversationStore, + Error ConversationError, + Error ActionError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -454,6 +457,9 @@ deleteLocalConversation lusr con lcnv = type UpdateConversationActions = '[ BotAccess, BrigAccess, + Error ActionError, + Error ConversationError, + Error TeamError, ExternalAccess, FederatorAccess, FireAndForget, @@ -675,6 +681,9 @@ joinConversationByReusableCodeH :: CodeStore, ConversationStore, FederatorAccess, + Error ActionError, + Error ConversationError, + Error TeamError, ExternalAccess, GundeckAccess, MemberStore, @@ -693,6 +702,9 @@ joinConversationByReusableCode :: '[ BrigAccess, CodeStore, ConversationStore, + Error ActionError, + Error ConversationError, + Error TeamError, FederatorAccess, ExternalAccess, GundeckAccess, @@ -714,6 +726,9 @@ joinConversationByIdH :: '[ BrigAccess, ConversationStore, FederatorAccess, + Error ActionError, + Error ConversationError, + Error TeamError, ExternalAccess, GundeckAccess, MemberStore, @@ -731,6 +746,9 @@ joinConversationById :: '[ BrigAccess, FederatorAccess, ConversationStore, + Error ActionError, + Error ConversationError, + Error TeamError, ExternalAccess, GundeckAccess, MemberStore, @@ -750,6 +768,9 @@ joinConversation :: '[ BrigAccess, ConversationStore, FederatorAccess, + Error ActionError, + Error ConversationError, + Error TeamError, ExternalAccess, GundeckAccess, MemberStore, @@ -766,7 +787,7 @@ joinConversation zusr zcon cnv access = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv conv <- ensureConversationAccess zusr cnv access - ensureGroupConvThrowing conv + liftSem . mapError toWai $ ensureGroupConversation conv -- FUTUREWORK: remote users? ensureMemberLimit (toList $ Data.convLocalMembers conv) [zusr] getUpdateResult $ do @@ -1465,6 +1486,7 @@ addBotH :: Members '[ ClientStore, ConversationStore, + Error ActionError, ExternalAccess, GundeckAccess, MemberStore, @@ -1483,6 +1505,7 @@ addBot :: Members '[ ClientStore, ConversationStore, + Error ActionError, ExternalAccess, GundeckAccess, MemberStore, @@ -1528,8 +1551,9 @@ addBot zusr zcon b = do let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) liftSem . unless (zusr `isMember` users) $ throwErrorDescriptionType @ConvNotFound - ensureGroupConvThrowing c - ensureActionAllowed AddConversationMember =<< getSelfMemberFromLocalsLegacy zusr users + liftSem . mapError toWai $ ensureGroupConversation c + self <- getSelfMemberFromLocalsLegacy 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] diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 7d8d9a327c8..6bed1b2f60c 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -77,19 +77,19 @@ import Wire.API.Federation.Error (federationNotImplemented) type JSON = Media "application" "json" ensureAccessRole :: - Members '[BrigAccess, WaiError] r => + Members '[BrigAccess, Error TeamError, Error ConversationError] r => AccessRole -> [(UserId, Maybe TeamMember)] -> Galley r () ensureAccessRole role users = liftSem $ case role of - PrivateAccessRole -> throwErrorDescriptionType @ConvAccessDenied + PrivateAccessRole -> throw ConvAccessDenied TeamAccessRole -> when (any (isNothing . snd) users) $ - throwErrorDescriptionType @NotATeamMember + throw NotATeamMember ActivatedAccessRole -> do 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 @@ -98,7 +98,7 @@ ensureAccessRole role users = liftSem $ 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, WaiError] r => + Members '[BrigAccess, TeamStore, Error ActionError] r => Local UserId -> [UserId] -> Galley r () @@ -117,7 +117,7 @@ ensureConnectedOrSameTeam (tUnqualified -> u) uids = do -- B blocks A, the status of A-to-B is still 'Accepted' but it doesn't mean -- that they are connected). ensureConnected :: - Members '[BrigAccess, WaiError] r => + Members '[BrigAccess, Error ActionError] r => Local UserId -> UserList UserId -> Galley r () @@ -125,16 +125,20 @@ ensureConnected self others = do ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToRemotes self (ulRemotes others) -ensureConnectedToLocals :: Members '[BrigAccess, WaiError] r => UserId -> [UserId] -> Galley r () +ensureConnectedToLocals :: + Members '[BrigAccess, Error ActionError] r => + UserId -> + [UserId] -> + Galley r () ensureConnectedToLocals _ [] = pure () ensureConnectedToLocals u uids = liftSem $ do (connsFrom, connsTo) <- getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) unless (length connsFrom == length uids && length connsTo == length uids) $ - throwErrorDescriptionType @NotConnected + throw NotConnected ensureConnectedToRemotes :: - Members '[BrigAccess, WaiError] r => + Members '[BrigAccess, Error ActionError] r => Local UserId -> [Remote UserId] -> Galley r () @@ -142,7 +146,7 @@ ensureConnectedToRemotes _ [] = pure () ensureConnectedToRemotes u remotes = liftSem $ do acceptedConns <- getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) when (length acceptedConns /= length remotes) $ - throw $ errorDescriptionTypeToWai @NotConnected + throw NotConnected ensureReAuthorised :: Members '[BrigAccess, WaiError] r => UserId -> Maybe PlainTextPassword -> Galley r () ensureReAuthorised u secret = liftSem $ do @@ -153,17 +157,21 @@ ensureReAuthorised u secret = liftSem $ do -- | 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, Member WaiError r) => Action -> mem -> Galley r () +ensureActionAllowed :: + (IsConvMember mem, Member (Error ActionError) 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 -> throw (badRequest "Custom roles not supported") + Nothing -> throw CustomRolesNotSupported -- | Comprehensive permission check, taking action-specific logic into account. ensureConversationActionAllowed :: - (IsConvMember mem, Members '[TeamStore, WaiError] r) => + (IsConvMember mem, Members '[Error ActionError, TeamStore, WaiError] r) => ConversationAction -> Data.Conversation -> mem -> @@ -174,8 +182,8 @@ ensureConversationActionAllowed action conv self = do -- general action check ensureActionAllowed tag self -- check if it is a group conversation (except for rename actions) - when (tag /= ModifyConversationName) $ - ensureGroupConvThrowing conv + liftSem . mapError toWai . when (tag /= ModifyConversationName) $ + ensureGroupConversation conv -- extra action-specific checks case action of ConversationActionAddMembers _ role -> ensureConvRoleNotElevated self role @@ -217,19 +225,17 @@ ensureConversationActionAllowed action conv self = do liftSem $ throwErrorDescriptionType @InvalidTargetAccess _ -> pure () -ensureGroupConvThrowing :: Member WaiError r => Data.Conversation -> Galley r () -ensureGroupConvThrowing conv = liftSem $ case Data.convType conv of - SelfConv -> throw invalidSelfOp - One2OneConv -> throw invalidOne2OneOp - ConnectConv -> throw 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, Member WaiError r) => + (IsConvMember mem, Member (Error ActionError) r) => mem -> RoleName -> Galley r () @@ -237,9 +243,9 @@ ensureConvRoleNotElevated origMember targetRole = liftSem $ do case (roleNameToActions targetRole, roleNameToActions (convMemberRole origMember)) of (Just targetActions, Just memberActions) -> unless (Set.isSubsetOf targetActions memberActions) $ - throw invalidActions + throw InvalidAction (_, _) -> - throw (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'. @@ -624,7 +630,16 @@ verifyReusableCode convCode = do return c ensureConversationAccess :: - Members '[BrigAccess, ConversationStore, TeamStore, WaiError] r => + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error TeamError, + TeamStore, + WaiError + ] + r => UserId -> ConvId -> Access -> diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index ff190dbd16a..0f862add01c 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -355,6 +355,7 @@ interpretGalleyToGalley0 :: Galley GalleyEffects a -> Galley0 a interpretGalleyToGalley0 = Galley . interpretErrorToException + . mapAllErrors . interpretInternalTeamListToCassandra . interpretTeamListToCassandra . interpretLegacyConversationListToCassandra 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 ca9817cd8f5..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 @@ -81,9 +82,9 @@ 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,6 +108,11 @@ type GalleyEffects1 = ListItems CassandraPaging (Remote ConvId), ListItems LegacyPaging ConvId, ListItems LegacyPaging TeamId, - ListItems InternalPaging TeamId, - Error (Wai.Error) + 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 From 0881c1b010958a3c85e8766ca6296b5b14070264 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 4 Nov 2021 17:34:07 +0100 Subject: [PATCH 05/10] Split ConversationAction into several action types --- .../src/Wire/API/Conversation/Action.hs | 3 +- services/galley/galley.cabal | 3 +- services/galley/src/Galley/API/Action.hs | 511 +++++++++++++ services/galley/src/Galley/API/Create.hs | 20 +- services/galley/src/Galley/API/Error.hs | 22 +- services/galley/src/Galley/API/Federation.hs | 11 +- services/galley/src/Galley/API/LegalHold.hs | 40 +- services/galley/src/Galley/API/Query.hs | 13 +- services/galley/src/Galley/API/Teams.hs | 4 +- .../galley/src/Galley/API/Teams/Features.hs | 2 + services/galley/src/Galley/API/Update.hs | 709 ++++++++---------- services/galley/src/Galley/API/Util.hs | 115 +-- services/galley/src/Galley/App.hs | 3 +- services/galley/src/Galley/Validation.hs | 11 +- 14 files changed, 964 insertions(+), 503 deletions(-) create mode 100644 services/galley/src/Galley/API/Action.hs 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/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..8d36940711f --- /dev/null +++ b/services/galley/src/Galley/API/Action.hs @@ -0,0 +1,511 @@ +-- 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.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 LegalHoldError, + Error TeamError, + 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 TeamError, + 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, + 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 TeamError, 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) >>= note 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 = Member (Error ActionError) 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, + 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, + 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, + Member (Error ActionError) 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 0852c32bf85..d93e2e543b8 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -407,7 +407,15 @@ createOne2OneConversationRemotely _ _ _ _ _ _ = throw federationNotImplemented createConnectConversation :: - Members '[ConversationStore, FederatorAccess, GundeckAccess, MemberStore, WaiError] r => + Members + '[ ConversationStore, + Error ActionError, + FederatorAccess, + GundeckAccess, + MemberStore, + WaiError + ] + r => UserId -> Maybe ConnId -> Connect -> @@ -431,7 +439,15 @@ createConnectConversationWithRemote _ _ _ = throw federationNotImplemented createLegacyConnectConversation :: - Members '[ConversationStore, FederatorAccess, GundeckAccess, MemberStore, WaiError] r => + Members + '[ ConversationStore, + Error ActionError, + FederatorAccess, + GundeckAccess, + MemberStore, + WaiError + ] + r => Local UserId -> Maybe ConnId -> Local UserId -> diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 27f57ae229a..70e5e778b1e 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -47,9 +47,11 @@ data ActionError = InvalidAction | CustomRolesNotSupported | InvalidTargetAccess + | InvalidTargetUserOp | ActionDenied Action | InvalidOp ConvType | NotConnected + | InvalidRange LText instance APIError ActionError where toWai InvalidAction = invalidActions @@ -61,14 +63,20 @@ instance APIError ActionError where toWai (InvalidOp One2OneConv) = invalidOne2OneOp toWai (InvalidOp ConnectConv) = invalidConnectOp toWai NotConnected = errorDescriptionTypeToWai @NotConnected + toWai (InvalidRange t) = invalidRange t + toWai InvalidTargetUserOp = invalidTargetUserOp data ConversationError = ConvAccessDenied | ConvNotFound + | TooManyMembers + | ConvMemberNotFound instance APIError ConversationError where toWai ConvAccessDenied = errorDescriptionTypeToWai @ConvAccessDenied toWai ConvNotFound = errorDescriptionTypeToWai @ConvNotFound + toWai TooManyMembers = tooManyMembers + toWai ConvMemberNotFound = errorDescriptionTypeToWai @ConvMemberNotFound data TeamError = NotATeamMember @@ -78,15 +86,27 @@ instance APIError TeamError where instance APIError FederationError where toWai = federationErrorToWai +data LegalHoldError + = MissingLegalholdConsent + +instance APIError LegalHoldError where + toWai MissingLegalholdConsent = errorDescriptionTypeToWai @MissingLegalholdConsent + type AllErrorEffects = '[ P.Error ActionError, P.Error ConversationError, + P.Error LegalHoldError, P.Error TeamError, P.Error FederationError ] mapAllErrors :: Member (P.Error Error) r => Sem (Append AllErrorEffects r) a -> Sem r a -mapAllErrors = P.mapError toWai . P.mapError toWai . P.mapError toWai . P.mapError toWai +mapAllErrors = + P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai ---------------------------------------------------------------------------- -- Error description integration diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index f552590d2b9..d37685f33ef 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -31,11 +31,10 @@ import Data.Qualified import Data.Range import qualified Data.Set as Set import qualified Data.Text.Lazy as LT +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.Util import Galley.App import qualified Galley.Data.Conversation as Data @@ -70,6 +69,7 @@ import Wire.API.Federation.API.Galley UserDeletedConversationsNotification, ) import qualified Wire.API.Federation.API.Galley as FederationAPIGalley +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 (..)) @@ -244,6 +244,7 @@ leaveConversation :: ConversationStore, Error ActionError, Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -267,8 +268,8 @@ leaveConversation requestingDomain lc = do ) . runMaybeT . void - . API.updateLocalConversation lcnv leaver Nothing - . ConversationActionRemoveMembers + . updateLocalConversation lcnv leaver Nothing + . ConversationLeave . pure $ leaver @@ -379,5 +380,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/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 6a28517da15..62f57d02e6b 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -74,6 +74,7 @@ import Polysemy.Error import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) +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)) @@ -164,8 +165,9 @@ removeSettingsH :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -195,8 +197,9 @@ removeSettings :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -246,8 +249,9 @@ removeSettings' :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -332,8 +336,9 @@ grantConsentH :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -363,8 +368,9 @@ grantConsent :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -399,8 +405,9 @@ requestDeviceH :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -432,8 +439,9 @@ requestDevice :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -498,8 +506,9 @@ approveDeviceH :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -526,8 +535,9 @@ approveDevice :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -591,8 +601,9 @@ disableForUserH :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -624,8 +635,9 @@ disableForUser :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -676,8 +688,9 @@ changeLegalholdStatus :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, @@ -811,8 +824,9 @@ handleGroupConvPolicyConflicts :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index a64f68c0d8b..c2b3eb131ab 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -81,19 +81,19 @@ import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public getBotConversationH :: - Members '[ConversationStore, WaiError] r => + Members '[ConversationStore, Error ConversationError] r => BotId ::: ConvId ::: JSON -> Galley r Response getBotConversationH (zbot ::: zcnv ::: _) = do json <$> getBotConversation zbot zcnv getBotConversation :: - Members '[ConversationStore, WaiError] 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 +106,7 @@ getBotConversation zbot zcnv = do Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) getUnqualifiedConversation :: - Members '[ConversationStore, WaiError] r => + Members '[ConversationStore, Error ConversationError, WaiError] r => UserId -> ConvId -> Galley r Public.Conversation @@ -116,7 +116,7 @@ getUnqualifiedConversation zusr cnv = do getConversation :: forall r. - Members '[ConversationStore, WaiError] r => + Members '[ConversationStore, Error ConversationError, WaiError] r => UserId -> Qualified ConvId -> Galley r Public.Conversation @@ -231,7 +231,7 @@ getRemoteConversationsWithFailures zusr convs = do throwE e getConversationRoles :: - Members '[ConversationStore, WaiError] r => + Members '[ConversationStore, Error ConversationError] r => UserId -> ConvId -> Galley r Public.ConversationRolesList @@ -491,6 +491,7 @@ getConversationByReusableCode :: ConversationStore, Error ActionError, Error ConversationError, + Error FederationError, Error TeamError, TeamStore, WaiError diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index c8a19d115a8..389158f8a97 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -125,6 +125,7 @@ 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.Federation.Client import qualified Wire.API.Notification as Public import qualified Wire.API.Team as Public import qualified Wire.API.Team.Conversation as Public @@ -1041,8 +1042,9 @@ deleteTeamConversation :: BrigAccess, CodeStore, ConversationStore, - Error ConversationError, Error ActionError, + Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 016d74877ae..03ee4c74c0e 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -87,6 +87,7 @@ import Wire.API.Event.FeatureConfig ), ) 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 @@ -368,6 +369,7 @@ setLegalholdStatusInternal :: ConversationStore, Error ActionError, Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, FederatorAccess, diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index a8561eb189b..950a192853e 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,7 +65,6 @@ module Galley.API.Update ) where -import qualified Brig.Types.User as User import Control.Lens import Control.Monad.State import Control.Monad.Trans.Maybe @@ -77,14 +72,13 @@ 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 @@ -95,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 @@ -113,10 +106,9 @@ 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 @@ -126,7 +118,6 @@ 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 @@ -139,13 +130,11 @@ import Wire.API.ErrorDescription 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 :: @@ -222,7 +211,22 @@ handleUpdateResult = \case Unchanged -> empty & setStatus status204 updateConversationAccess :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -238,7 +242,21 @@ updateConversationAccess usr con qcnv update = do doUpdate qcnv lusr con update updateConversationAccessUnqualified :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -250,111 +268,50 @@ updateConversationAccessUnqualified usr zcon cnv update = do updateLocalConversationAccess lcnv lusr zcon update updateLocalConversationAccess :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + 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 WaiError r => + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Public.ConversationAccessData -> Galley r (UpdateResult Event) -updateRemoteConversationAccess _ _ _ _ = liftSem $ throw federationNotImplemented +updateRemoteConversationAccess _ _ _ _ = liftSem $ throw FederationNotImplemented -performAccessUpdateAction :: - forall r. +updateConversationReceiptMode :: Members - '[ BrigAccess, - BotAccess, - CodeStore, - ConversationStore, - Error ConversationError, + '[ ConversationStore, Error ActionError, - Error TeamError, + Error ConversationError, ExternalAccess, FederatorAccess, - FireAndForget, - GundeckAccess, - LegalHoldStore, - MemberStore, - TeamStore, - WaiError + 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 -> @@ -370,7 +327,15 @@ updateConversationReceiptMode usr zcon qcnv update = do doUpdate qcnv lusr zcon update updateConversationReceiptModeUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -382,7 +347,15 @@ updateConversationReceiptModeUnqualified usr zcon cnv update = do updateLocalConversationReceiptMode lcnv lusr zcon update updateLocalConversationReceiptMode :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local ConvId -> Local UserId -> ConnId -> @@ -390,20 +363,27 @@ 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 WaiError r => + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> Galley r (UpdateResult Event) -updateRemoteConversationReceiptMode _ _ _ _ = liftSem $ throw federationNotImplemented +updateRemoteConversationReceiptMode _ _ _ _ = liftSem $ throw FederationNotImplemented updateConversationMessageTimerUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -415,7 +395,16 @@ updateConversationMessageTimerUnqualified usr zcon cnv update = do updateLocalConversationMessageTimer lusr zcon lcnv update updateConversationMessageTimer :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -426,12 +415,20 @@ updateConversationMessageTimer usr zcon qcnv update = do foldQualified lusr (updateLocalConversationMessageTimer lusr zcon) - (\_ _ -> liftSem (throw federationNotImplemented)) + (\_ _ -> liftSem (throw FederationNotImplemented)) qcnv update updateLocalConversationMessageTimer :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> @@ -439,119 +436,44 @@ 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 TeamError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + TeamStore + ] + r => + Members '[] 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, - Error ActionError, - Error ConversationError, - Error TeamError, - ExternalAccess, - FederatorAccess, - FireAndForget, - GundeckAccess, - CodeStore, - ConversationStore, - LegalHoldStore, - MemberStore, - TeamStore, - WaiError - ] - --- | 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 . liftSem $ do - cn <- rangeChecked (cupName rename) - 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, WaiError] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess, + WaiError + ] + r => UserId ::: ConnId ::: ConvId -> Galley r Response addCodeH (usr ::: zcon ::: cnv) = @@ -565,7 +487,15 @@ data AddCodeResult addCode :: forall r. - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess, WaiError] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess, + WaiError + ] + r => UserId -> ConnId -> ConvId -> @@ -578,7 +508,7 @@ addCode usr zcon cnv = do liftSem (E.getConversation cnv) >>= ifNothing (errorDescriptionTypeToWai @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 @@ -601,14 +531,30 @@ addCode usr zcon cnv = do return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix rmCodeH :: - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess, WaiError] r => + Members + '[ CodeStore, + ConversationStore, + ExternalAccess, + Error ConversationError, + GundeckAccess, + WaiError + ] + r => UserId ::: ConnId ::: ConvId -> Galley r Response rmCodeH (usr ::: zcon ::: cnv) = setStatus status200 . json <$> rmCode usr zcon cnv rmCode :: - Members '[CodeStore, ConversationStore, ExternalAccess, GundeckAccess, WaiError] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess, + WaiError + ] + r => UserId -> ConnId -> ConvId -> @@ -621,7 +567,7 @@ rmCode usr zcon cnv = do liftSem (E.getConversation cnv) >>= ifNothing (errorDescriptionTypeToWai @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 @@ -631,14 +577,26 @@ rmCode usr zcon cnv = do pure event getCodeH :: - Members '[CodeStore, ConversationStore, WaiError] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + WaiError + ] + r => UserId ::: ConvId -> Galley r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv getCode :: - Members '[CodeStore, ConversationStore, WaiError] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + WaiError + ] + r => UserId -> ConvId -> Galley r Public.ConversationCode @@ -646,7 +604,7 @@ getCode usr cnv = do conv <- liftSem (E.getConversation cnv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) - ensureAccess conv CodeAccess + liftSem $ ensureAccess conv CodeAccess ensureConvMember (Data.convLocalMembers conv) usr key <- mkKey cnv c <- @@ -683,6 +641,7 @@ joinConversationByReusableCodeH :: FederatorAccess, Error ActionError, Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, GundeckAccess, @@ -704,6 +663,7 @@ joinConversationByReusableCode :: ConversationStore, Error ActionError, Error ConversationError, + Error FederationError, Error TeamError, FederatorAccess, ExternalAccess, @@ -728,6 +688,7 @@ joinConversationByIdH :: FederatorAccess, Error ActionError, Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, GundeckAccess, @@ -748,6 +709,7 @@ joinConversationById :: ConversationStore, Error ActionError, Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, GundeckAccess, @@ -770,6 +732,7 @@ joinConversation :: FederatorAccess, Error ActionError, Error ConversationError, + Error FederationError, Error TeamError, ExternalAccess, GundeckAccess, @@ -798,113 +761,30 @@ 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, - Member WaiError 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) - lusr <- lift . liftSem $ ensureLocal lcnv qusr - let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited - lift $ do - ensureMemberLimit (toList (Data.convLocalMembers conv)) newMembers - ensureAccess conv InviteAccess - checkLocals lusr lcnv (Data.convTeam conv) (ulLocals newMembers) - checkRemotes lusr (ulRemotes newMembers) - checkLHPolicyConflictsLocal lcnv (ulLocals newMembers) - checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) - addMembersToLocalConversation lcnv newMembers role - where - userIsMember u = (^. userId . to (== u)) - - checkLocals :: Local UserId -> Local ConvId -> Maybe TeamId -> [UserId] -> Galley r () - checkLocals lusr 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) - liftSem . when (maybe True (view managedConversation) tcv) $ - throw noAddToManaged - ensureConnectedOrSameTeam lusr newUsers - checkLocals lusr _ Nothing newUsers = do - ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) - ensureConnectedOrSameTeam lusr newUsers - - checkRemotes :: 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 :: Local ConvId -> [UserId] -> Galley r () - checkLHPolicyConflictsLocal lcnv newUsers = do - let convUsers = Data.convLocalMembers conv - - allNewUsersGaveConsent <- allLegalholdConsentGiven newUsers - - whenM (anyLegalholdActivated (lmId <$> convUsers)) $ - liftSem . unless allNewUsersGaveConsent $ - throwErrorDescriptionType @MissingLegalholdConsent - - whenM (anyLegalholdActivated newUsers) $ do - liftSem . 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 liftSem $ 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 LegalHoldError, + Error TeamError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -915,7 +795,22 @@ 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 LegalHoldError, + Error TeamError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -926,7 +821,7 @@ 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, WaiError] r => @@ -973,7 +868,7 @@ updateSelfMember zusr zcon qcnv update = do } updateUnqualifiedSelfMember :: - Members UpdateConversationActions r => + Members '[ConversationStore, GundeckAccess, ExternalAccess, MemberStore, WaiError] r => UserId -> ConnId -> ConvId -> @@ -984,7 +879,16 @@ updateUnqualifiedSelfMember zusr zcon cnv update = do updateSelfMember zusr zcon (qUntagged lcnv) update updateOtherMemberUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -998,7 +902,17 @@ 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, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -1011,7 +925,16 @@ updateOtherMember zusr zcon qcnv qvictim update = do doUpdate qcnv lusr zcon qvictim update updateOtherMemberLocalConv :: - (Members UpdateConversationActions r) => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => Local ConvId -> Local UserId -> ConnId -> @@ -1020,22 +943,31 @@ updateOtherMemberLocalConv :: Galley r () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do lift . liftSem . when (qUntagged lusr == qvictim) $ - throw invalidTargetUserOp + throw InvalidTargetUserOp updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionMemberUpdate qvictim update + ConversationMemberUpdate qvictim update updateOtherMemberRemoteConv :: - Member WaiError r => + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> Galley r () -updateOtherMemberRemoteConv _ _ _ _ _ = liftSem $ throw federationNotImplemented +updateOtherMemberRemoteConv _ _ _ _ _ = liftSem $ throw FederationNotImplemented removeMemberUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -1047,7 +979,16 @@ removeMemberUnqualified zusr con cnv victim = do removeMemberQualified zusr con (qUntagged lcnv) (qUntagged lvictim) removeMemberQualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -1058,7 +999,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 -> @@ -1082,20 +1023,18 @@ 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, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => Local ConvId -> Local UserId -> Maybe ConnId -> @@ -1106,7 +1045,7 @@ removeMemberFromLocalConv lcnv lusr con victim = fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) . runMaybeT . updateLocalConversation lcnv (qUntagged lusr) con - . ConversationActionRemoveMembers + . ConversationLeave . pure $ victim @@ -1166,8 +1105,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 @@ -1366,7 +1304,16 @@ 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, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -1377,12 +1324,20 @@ updateConversationName zusr zcon qcnv convRename = do foldQualified lusr (updateLocalConversationName lusr zcon) - (\_ _ -> liftSem (throw federationNotImplemented)) + (\_ _ -> liftSem (throw FederationNotImplemented)) qcnv convRename updateUnqualifiedConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -1394,7 +1349,15 @@ updateUnqualifiedConversationName zusr zcon cnv rename = do updateLocalConversationName lusr zcon lcnv rename updateLocalConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> @@ -1407,7 +1370,15 @@ updateLocalConversationName lusr zcon lcnv convRename = do else liftSem $ Nothing <$ E.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> @@ -1415,30 +1386,7 @@ 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, WaiError] r => @@ -1487,6 +1435,7 @@ addBotH :: '[ ClientStore, ConversationStore, Error ActionError, + Error ConversationError, ExternalAccess, GundeckAccess, MemberStore, @@ -1506,6 +1455,7 @@ addBot :: '[ ClientStore, ConversationStore, Error ActionError, + Error ConversationError, ExternalAccess, GundeckAccess, MemberStore, @@ -1614,13 +1564,6 @@ rmBot zusr zcon b = do ------------------------------------------------------------------------------- -- Helpers -ensureMemberLimit :: (Foldable f, Member WaiError 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 - ensureConvMember :: Member WaiError r => [LocalMember] -> UserId -> Galley r () ensureConvMember users usr = liftSem $ diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 6bed1b2f60c..7e13162aff2 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -55,7 +55,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 @@ -69,10 +69,9 @@ 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" @@ -169,62 +168,6 @@ ensureActionAllowed action self = liftSem $ case isActionAllowed action (convMem -- fact that there can be no custom roles at the moment Nothing -> throw CustomRolesNotSupported --- | Comprehensive permission check, taking action-specific logic into account. -ensureConversationActionAllowed :: - (IsConvMember mem, Members '[Error ActionError, TeamStore, WaiError] 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) - liftSem . mapError toWai . when (tag /= ModifyConversationName) $ - ensureGroupConversation 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) - ) - (\_ -> liftSem (throw 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' - liftSem - . 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) - liftSem . when (maybe False (view managedConversation) tcv) $ - throw 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) $ - liftSem $ throwErrorDescriptionType @InvalidTargetAccess - _ -> pure () - ensureGroupConversation :: Member (Error ActionError) r => Data.Conversation -> Sem r () ensureGroupConversation conv = do let ty = Data.convType conv @@ -507,16 +450,15 @@ getSelfMemberFromLocalsLegacy usr lmems = -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). ensureOtherMember :: - Member WaiError r => + Member (Error ConversationError) r => Local a -> Qualified UserId -> Data.Conversation -> - Galley r (Either LocalMember RemoteMember) + Sem r (Either LocalMember RemoteMember) ensureOtherMember loc quid conv = - liftSem - . maybe (throwErrorDescriptionType @ConvMemberNotFound) pure - $ (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) - <|> (Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv)) + note ConvMemberNotFound $ + Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv) + <|> Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv) getSelfMemberFromRemotesLegacy :: (Foldable t, Member WaiError r) => @@ -557,31 +499,29 @@ getMember :: getMember p ex u = hoistEither . Control.Error.note ex . find ((u ==) . p) getConversationAndCheckMembership :: - Members '[ConversationStore, WaiError] 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 :: - (Members '[ConversationStore, WaiError] r, IsConvMemberId uid mem) => - Wai.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) + c <- liftSem $ getConversation convId >>= note ConvNotFound liftSem . when (DataTypes.isConvDeleted c) $ do deleteConversation convId - throwErrorDescriptionType @ConvNotFound + throw ConvNotFound loc <- qualifyLocal () member <- liftSem . note ex $ getConvMember loc c usr pure (c, member) @@ -635,9 +575,9 @@ ensureConversationAccess :: ConversationStore, Error ActionError, Error ConversationError, + Error FederationError, Error TeamError, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -647,21 +587,25 @@ ensureConversationAccess :: ensureConversationAccess zusr cnv access = do conv <- liftSem $ - getConversation cnv >>= note (errorDescriptionTypeToWai @ConvNotFound) - ensureAccess conv access + 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 :: Member WaiError r => Data.Conversation -> Access -> Galley r () +ensureAccess :: + Member (Error ConversationError) r => + Data.Conversation -> + Access -> + Sem r () ensureAccess conv access = - liftSem . unless (access `elem` Data.convAccess conv) $ - throwErrorDescriptionType @ConvAccessDenied + unless (access `elem` Data.convAccess conv) $ + throw ConvAccessDenied -ensureLocal :: Member WaiError r => Local x -> Qualified a -> Sem r (Local a) -ensureLocal loc = foldQualified loc pure (\_ -> throw federationNotImplemented) +ensureLocal :: Member (Error FederationError) r => Local x -> Qualified a -> Sem r (Local a) +ensureLocal loc = foldQualified loc pure (\_ -> throw FederationNotImplemented) -------------------------------------------------------------------------------- -- Federation @@ -877,3 +821,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 0f862add01c..2748d00b25f 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -56,11 +56,12 @@ module Galley.App throwErrorDescription, throwErrorDescriptionType, - -- * MonadUnliftIO / Sem compatibility + -- * Temporary compatibility functions fireAndForget, spawnMany, liftGalley0, liftSem, + unGalley, interpretGalleyToGalley0, ) where diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index b0ee789de4a..d1c7af1af55 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -29,16 +29,15 @@ import Data.Range import Galley.API.Error import Galley.Options import Imports -import qualified Network.Wai.Utilities as Wai import Polysemy import Polysemy.Error -rangeChecked :: (Member (Error Wai.Error) r, Within a n m) => a -> Sem r (Range n m a) +rangeChecked :: (Member (Error ActionError) r, Within a n m) => a -> Sem r (Range n m a) rangeChecked = either throwErr return . checkedEither {-# INLINE rangeChecked #-} rangeCheckedMaybe :: - (Member (Error Wai.Error) r, Within a n m) => + (Member (Error ActionError) r, Within a n m) => Maybe a -> Sem r (Maybe (Range n m a)) rangeCheckedMaybe Nothing = return Nothing @@ -50,7 +49,7 @@ newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} deriving (Functor, Foldable, Traversable) checkedConvSize :: - (Member (Error Wai.Error) r, Foldable f) => + (Member (Error ActionError) r, Foldable f) => Opts -> f a -> Sem r (ConvSizeChecked f a) @@ -61,5 +60,5 @@ checkedConvSize o x = do then return (ConvSizeChecked x) else throwErr (errorMsg minV limit "") -throwErr :: Member (Error Wai.Error) r => String -> Sem r a -throwErr = throw . invalidRange . fromString +throwErr :: Member (Error ActionError) r => String -> Sem r a +throwErr = throw . InvalidRange . fromString From 670bacb1b8bd10e4e50c907aa86595ed2ea53dc6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Sat, 6 Nov 2021 00:29:19 +0100 Subject: [PATCH 06/10] Replace Wai.Error with fine-grained error types --- .../src/Wire/API/Federation/Client.hs | 1 + .../src/Wire/API/Federation/Error.hs | 1 + .../wire-api/src/Wire/API/ErrorDescription.hs | 9 +- services/galley/src/Galley/API/Action.hs | 11 +- services/galley/src/Galley/API/Create.hs | 121 ++++-- .../galley/src/Galley/API/CustomBackend.hs | 19 +- services/galley/src/Galley/API/Error.hs | 165 +++++++- services/galley/src/Galley/API/Federation.hs | 167 ++++---- services/galley/src/Galley/API/Internal.hs | 35 +- services/galley/src/Galley/API/LegalHold.hs | 159 ++++--- services/galley/src/Galley/API/Mapping.hs | 8 +- services/galley/src/Galley/API/Query.hs | 46 ++- services/galley/src/Galley/API/Teams.hs | 371 +++++++++++------ .../galley/src/Galley/API/Teams/Features.hs | 96 +++-- .../src/Galley/API/Teams/Notifications.hs | 6 +- services/galley/src/Galley/API/Update.hs | 388 ++++++++++++------ services/galley/src/Galley/API/Util.hs | 109 ++--- services/galley/src/Galley/App.hs | 47 +-- .../src/Galley/External/LegalHoldService.hs | 20 +- services/galley/src/Galley/Validation.hs | 8 +- 20 files changed, 1193 insertions(+), 594 deletions(-) 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/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/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 8d36940711f..1a082cc68fc 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -126,6 +126,7 @@ instance IsConversationAction ConversationJoin where Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, Error LegalHoldError, Error TeamError, ExternalAccess, @@ -198,6 +199,7 @@ instance IsConversationAction ConversationJoin where Error ActionError, Error ConversationError, Error LegalHoldError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess, @@ -289,7 +291,10 @@ instance IsConversationAction ConversationDelete where pure (mempty, action) instance IsConversationAction ConversationRename where - type HasConversationActionEffects ConversationRename r = Member (Error ActionError) r + type + HasConversationActionEffects ConversationRename r = + Members '[Error ActionError, Error InvalidInput] r + conversationAction = ConversationActionRename conversationActionTag' _ _ = ModifyConversationName performAction _ lcnv _ action = lift . liftSem $ do @@ -323,6 +328,7 @@ instance IsConversationAction ConversationAccessData where BrigAccess, CodeStore, Error ActionError, + Error InvalidInput, ExternalAccess, FederatorAccess, FireAndForget, @@ -417,6 +423,7 @@ updateLocalConversation :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess @@ -457,7 +464,7 @@ ensureConversationActionAllowed :: ( IsConvMember mem, IsConversationAction a, HasConversationActionEffects a r, - Member (Error ActionError) r + Members '[Error ActionError, Error InvalidInput] r ) => Local x -> a -> diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index d93e2e543b8..56cda1806a4 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, @@ -59,9 +58,8 @@ 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.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)) @@ -78,12 +76,14 @@ createGroupConversation :: BrigAccess, Error ActionError, Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -103,12 +103,14 @@ internalCreateManagedConversationH :: BrigAccess, Error ActionError, Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, - TeamStore, - WaiError + TeamStore ] r => UserId ::: ConnId ::: JsonRequest NewConvManaged -> @@ -123,12 +125,14 @@ internalCreateManagedConversation :: BrigAccess, Error ActionError, Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -136,11 +140,11 @@ internalCreateManagedConversation :: NewConvManaged -> Galley r ConversationResponse internalCreateManagedConversation zusr zcon (NewConvManaged body) = do - tinfo <- liftSem $ note internalError (newConvTeam body) + tinfo <- liftSem $ note CannotCreateManagedConv (newConvTeam body) createTeamGroupConv zusr zcon tinfo body ensureNoLegalholdConflicts :: - Members '[LegalHoldStore, TeamStore, WaiError] r => + Members '[Error LegalHoldError, LegalHoldStore, TeamStore] r => [Remote UserId] -> [UserId] -> Galley r () @@ -148,7 +152,7 @@ ensureNoLegalholdConflicts remotes locals = do let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes whenM (anyLegalholdActivated locals) $ unlessM (allLegalholdConsentGiven locals) $ - liftSem $ throwErrorDescriptionType @MissingLegalholdConsent + liftSem $ throw MissingLegalholdConsent -- | A helper for creating a regular (non-team) group conversation. createRegularGroupConv :: @@ -157,10 +161,12 @@ createRegularGroupConv :: BrigAccess, FederatorAccess, Error ActionError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, GundeckAccess, LegalHoldStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -201,12 +207,14 @@ createTeamGroupConv :: BrigAccess, Error ActionError, Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, Error TeamError, FederatorAccess, GundeckAccess, LegalHoldStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -267,7 +275,7 @@ createTeamGroupConv zusr zcon tinfo body = do -- Other kinds of conversations createSelfConversation :: - Members '[ConversationStore, WaiError] r => + Members '[ConversationStore, Error InternalError] r => UserId -> Galley r ConversationResponse createSelfConversation zusr = do @@ -285,10 +293,14 @@ createOne2OneConversation :: '[ BrigAccess, ConversationStore, Error ActionError, + Error ConversationError, + Error FederationError, + Error InternalError, + Error InvalidInput, + Error TeamError, FederatorAccess, GundeckAccess, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -300,10 +312,10 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do let allUsers = newConvMembers lusr j other <- liftSem $ ensureOne (ulAll lusr allUsers) liftSem . when (qUntagged lusr == other) $ - throw (invalidOp "Cannot create a 1-1 with yourself") + throw (InvalidOpGeneral "Cannot create a 1-1 with yourself") mtid <- case newConvTeam j of Just ti - | cnvManaged ti -> liftSem $ throw noManagedTeamConv + | cnvManaged ti -> liftSem $ throw NoManagedTeamConv | otherwise -> do foldQualified lusr @@ -322,9 +334,8 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do verifyMembership tid u = do membership <- liftSem $ E.getTeamMember tid u liftSem . when (isNothing membership) $ - throw noBindingTeamMembers + throw NoBindingTeamMembers checkBindingTeamPermissions :: - Member WaiError r => Local UserId -> Local UserId -> TeamId -> @@ -337,11 +348,19 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do verifyMembership tid (tUnqualified lusr) verifyMembership tid (tUnqualified lother) pure (Just tid) - Just _ -> liftSem $ throw nonBindingTeam - Nothing -> liftSem $ throw teamNotFound + Just _ -> liftSem $ throw NotABindingTeamMember + Nothing -> liftSem $ throw TeamNotFound createLegacyOne2OneConversationUnchecked :: - Members '[ConversationStore, FederatorAccess, GundeckAccess, WaiError] r => + Members + '[ ConversationStore, + Error ActionError, + Error InternalError, + Error InvalidInput, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -360,7 +379,14 @@ createLegacyOne2OneConversationUnchecked self zcon name mtid other = do conversationCreated (tUnqualified self) c createOne2OneConversationUnchecked :: - Members '[ConversationStore, FederatorAccess, GundeckAccess, WaiError] r => + Members + '[ ConversationStore, + Error FederationError, + Error InternalError, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -376,7 +402,7 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId (qUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: - Members '[ConversationStore, FederatorAccess, GundeckAccess, WaiError] r => + Members '[ConversationStore, Error InternalError, FederatorAccess, GundeckAccess] r => Local ConvId -> Local UserId -> ConnId -> @@ -394,7 +420,7 @@ createOne2OneConversationLocally lcnv self zcon name mtid other = do conversationCreated (tUnqualified self) c createOne2OneConversationRemotely :: - Member WaiError r => + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> @@ -404,16 +430,19 @@ createOne2OneConversationRemotely :: Galley r ConversationResponse createOne2OneConversationRemotely _ _ _ _ _ _ = liftSem $ - throw federationNotImplemented + throw FederationNotImplemented createConnectConversation :: Members '[ ConversationStore, Error ActionError, + Error ConversationError, + Error FederationError, + Error InternalError, + Error InvalidInput, FederatorAccess, GundeckAccess, - MemberStore, - WaiError + MemberStore ] r => UserId -> @@ -429,23 +458,25 @@ createConnectConversation usr conn j = do (cRecipient j) createConnectConversationWithRemote :: - Member WaiError r => + Member (Error FederationError) r => Local UserId -> Maybe ConnId -> Remote UserId -> Galley r ConversationResponse createConnectConversationWithRemote _ _ _ = liftSem $ - throw federationNotImplemented + throw FederationNotImplemented createLegacyConnectConversation :: Members '[ ConversationStore, Error ActionError, + Error InvalidInput, + Error ConversationError, + Error InternalError, FederatorAccess, GundeckAccess, - MemberStore, - WaiError + MemberStore ] r => Local UserId -> @@ -518,14 +549,14 @@ createLegacyConnectConversation lusr conn lrecipient j = do -- Helpers conversationCreated :: - Member WaiError r => + Member (Error InternalError) r => UserId -> Data.Conversation -> Galley r ConversationResponse conversationCreated usr cnv = Created <$> conversationView usr cnv conversationExisted :: - Member WaiError r => + Member (Error InternalError) r => UserId -> Data.Conversation -> Galley r ConversationResponse @@ -537,7 +568,7 @@ handleConversationResponse = \case Existed cnv -> json cnv & setStatus status200 . location (qUnqualified . cnvQualifiedId $ cnv) notifyCreatedConversation :: - Members '[FederatorAccess, GundeckAccess, WaiError] r => + Members '[Error InternalError, FederatorAccess, GundeckAccess] r => Maybe UTCTime -> UserId -> Maybe ConnId -> @@ -569,7 +600,7 @@ notifyCreatedConversation dtime usr conn c = do & pushRoute .~ route localOne2OneConvId :: - Member WaiError r => + Member (Error InvalidInput) r => Local UserId -> Local UserId -> Galley r (Local ConvId) @@ -578,13 +609,13 @@ localOne2OneConvId self other = do pure . qualifyAs self $ Data.localOne2OneConvId x y toUUIDs :: - Member WaiError r => + 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 @@ -600,6 +631,6 @@ newConvMembers loc body = UserList (newConvUsers body) [] <> toUserList loc (newConvQualifiedUsers body) -ensureOne :: Member WaiError r => [a] -> Sem r a +ensureOne :: Member (Error InvalidInput) r => [a] -> Sem r a ensureOne [x] = pure x -ensureOne _ = throw (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 1d2ee80e1ab..52cfd656b5d 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -31,32 +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 :: Members '[CustomBackendStore, WaiError] r => Domain ::: JSON -> Galley r Response +getCustomBackendByDomainH :: + Members + '[ CustomBackendStore, + Error CustomBackendError + ] + r => + Domain ::: JSON -> + Galley r Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain getCustomBackendByDomain :: - Members '[CustomBackendStore, WaiError] r => + Members '[CustomBackendStore, Error CustomBackendError] r => Domain -> Galley r Public.CustomBackend getCustomBackendByDomain domain = liftSem $ getCustomBackend domain >>= \case - Nothing -> throw (customBackendNotFound domain) + Nothing -> throw (CustomBackendNotFound domain) Just customBackend -> pure customBackend -- INTERNAL ------------------------------------------------------------------- internalPutCustomBackendByDomainH :: - Members '[CustomBackendStore, WaiError] 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 70e5e778b1e..05a1536bb1d 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -18,6 +18,7 @@ module Galley.API.Error where import Data.Domain (Domain, domainText) +import Data.Id import Data.Proxy import Data.String.Conversions (cs) import Data.Text.Lazy as LT (pack) @@ -43,61 +44,197 @@ import Wire.API.Federation.Error 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 - | CustomRolesNotSupported | InvalidTargetAccess | InvalidTargetUserOp | ActionDenied Action + | AccessDenied | InvalidOp ConvType + | InvalidOpGeneral LText + | OperationDenied String | NotConnected - | InvalidRange LText + | NoAddToManaged + | BroadcastLimitExceeded + | InvalidTeamStatusUpdate + | InvalidPermissions instance APIError ActionError where toWai InvalidAction = invalidActions - toWai CustomRolesNotSupported = badRequest "Custom roles not supported" 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 (InvalidOpGeneral t) = invalidOp t + toWai (OperationDenied p) = errorDescriptionToWai $ operationDeniedSpecialized p toWai NotConnected = errorDescriptionTypeToWai @NotConnected - toWai (InvalidRange t) = invalidRange t 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 - -data TeamError = NotATeamMember + toWai NoBindingTeamMembers = noBindingTeamMembers + toWai NoManagedTeamConv = noManagedTeamConv + +data TeamError + = NotATeamMember + | NoBindingTeam + | NoAddToBinding + | NotABindingTeamMember + | NotAOneMemberTeam + | TeamNotFound + | TeamMemberNotFound + | TeamSearchVisibilityNotEnabled + | UserBindingExists + | TooManyTeamMembers + | CannotEnableLegalHoldServiceLargeTeam instance APIError TeamError where toWai NotATeamMember = errorDescriptionTypeToWai @NotATeamMember + 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 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 FederationError + P.Error TeamFeatureError, + P.Error TeamNotificationError ] mapAllErrors :: Member (P.Error Error) r => Sem (Append AllErrorEffects r) a -> Sem r a @@ -107,6 +244,14 @@ mapAllErrors = . 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 @@ -189,6 +334,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 d37685f33ef..348bec3dec9 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -21,20 +21,20 @@ import Control.Lens (itraversed, (<.>)) 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.Action import Galley.API.Error import qualified Galley.API.Mapping as Mapping -import Galley.API.Message (MessageMetadata (..), UserType (..), postQualifiedOtrMessage, sendLocalMessages) +import Galley.API.Message import Galley.API.Util import Galley.App import qualified Galley.Data.Conversation as Data @@ -42,10 +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 +import Polysemy.Error (Error, throw) import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) @@ -55,53 +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? @@ -245,6 +233,7 @@ leaveConversation :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, Error TeamError, ExternalAccess, FederatorAccess, @@ -252,18 +241,17 @@ leaveConversation :: GundeckAccess, LegalHoldStore, MemberStore, - TeamStore, - WaiError + TeamStore ] 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 @@ -278,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)) @@ -305,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 @@ -324,23 +321,23 @@ sendMessage :: BrigAccess, ClientStore, ConversationStore, + Error InvalidInput, FederatorAccess, GundeckAccess, ExternalAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] 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 = liftSem . throw . invalidPayload . LT.pack + err = liftSem . throw . InvalidPayload . LT.pack onUserDeleted :: Members @@ -353,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 diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 9eadbfe2abd..72a08dc4058 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -38,6 +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 import Galley.API.LegalHold (getTeamLegalholdWhitelistedH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) import qualified Galley.API.One2One as One2One @@ -72,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 @@ -86,7 +88,6 @@ 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.Federation.API.Galley (ConversationUpdate (..), UserDeletedConversationsNotification (UserDeletedConversationsNotification)) import qualified Wire.API.Federation.API.Galley as FedGalley import Wire.API.Federation.Client (FederationError) @@ -302,7 +303,14 @@ servantSitemap = iGetTeamFeature :: forall a r. - (Public.KnownTeamFeatureName a, Members '[TeamStore, WaiError] r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + TeamStore + ] + r + ) => (Features.GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Galley r (Public.TeamFeatureStatus a) @@ -310,7 +318,14 @@ iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: forall a r. - (Public.KnownTeamFeatureName a, Members '[TeamStore, WaiError] r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + TeamStore + ] + r + ) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Public.TeamFeatureStatus a -> @@ -628,11 +643,17 @@ safeForever funName action = threadDelay 60000000 -- pause to keep worst-case noise in logs manageable guardLegalholdPolicyConflictsH :: - Members '[BrigAccess, TeamStore, WaiError] 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 (liftSem (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 62f57d02e6b..5535f40f292 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -81,15 +81,15 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotIm import qualified Wire.API.Team.LegalHold as Public assertLegalHoldEnabledForTeam :: - Members '[LegalHoldStore, TeamFeatureStore, WaiError] r => + Members '[Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r () assertLegalHoldEnabledForTeam tid = unlessM (isLegalHoldEnabledForTeam tid) $ - liftSem $ throw legalHoldNotEnabled + liftSem $ throw LegalHoldNotEnabled isLegalHoldEnabledForTeam :: - Members '[LegalHoldStore, TeamFeatureStore, WaiError] r => + Members '[LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r Bool isLegalHoldEnabledForTeam tid = do @@ -108,7 +108,16 @@ isLegalHoldEnabledForTeam tid = do liftSem $ LegalHoldData.isTeamLegalholdWhitelisted tid createSettingsH :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error LegalHoldError, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley r Response createSettingsH (zusr ::: tid ::: req ::: _) = do @@ -116,7 +125,16 @@ createSettingsH (zusr ::: tid ::: req ::: _) = do setStatus status201 . json <$> createSettings zusr tid newService createSettings :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error LegalHoldError, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> TeamId -> Public.NewLegalHoldService -> @@ -131,21 +149,37 @@ createSettings zusr tid newService = do void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership (key :: ServiceKey, fpr :: Fingerprint Rsa) <- LHService.validateServiceKey (newLegalHoldServiceKey newService) - >>= liftSem . note legalHoldServiceInvalidKey + >>= 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, WaiError] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId ::: TeamId ::: JSON -> Galley r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid getSettings :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> TeamId -> Galley r Public.ViewLegalHoldService @@ -166,8 +200,11 @@ removeSettingsH :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, + Error AuthenticationError, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -178,8 +215,7 @@ removeSettingsH :: MemberStore, TeamStore, TeamFeatureStore, - TeamMemberStore InternalPaging, - WaiError + TeamMemberStore InternalPaging ] r => UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> @@ -198,8 +234,11 @@ removeSettings :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, + Error AuthenticationError, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -210,8 +249,7 @@ removeSettings :: MemberStore, TeamFeatureStore, TeamStore, - TeamMemberStore p, - WaiError + TeamMemberStore p ] r ) => @@ -231,13 +269,13 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do ensureReAuthorised zusr mPassword removeSettings' tid where - assertNotWhitelisting :: Member WaiError r => 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 - liftSem $ throw legalHoldDisableUnimplemented + liftSem $ throw LegalHoldDisableUnimplemented -- | Remove legal hold settings from team; also disabling for all users and removing LH devices removeSettings' :: @@ -250,8 +288,11 @@ removeSettings' :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, + Error AuthenticationError, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -261,8 +302,7 @@ removeSettings' :: ListItems LegacyPaging ConvId, MemberStore, TeamStore, - TeamMemberStore p, - WaiError + TeamMemberStore p ] r ) => @@ -291,7 +331,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, WaiError] r => + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do @@ -299,12 +339,12 @@ getUserStatusH (_zusr ::: tid ::: uid ::: _) = do getUserStatus :: forall r. - Members '[LegalHoldStore, TeamStore, WaiError] r => + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => TeamId -> UserId -> Galley r Public.UserLegalHoldStatusResponse getUserStatus tid uid = do - teamMember <- liftSem $ note teamMemberNotFound =<< getTeamMember tid uid + teamMember <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid let status = view legalHoldStatus teamMember (mlk, lcid) <- case status of UserLegalHoldNoConsent -> pure (Nothing, Nothing) @@ -322,7 +362,7 @@ getUserStatus tid uid = do "expected to find a prekey for user: " <> toByteString' uid <> " but none was found" - liftSem $ throw internalError + liftSem $ throw NoPrekeyForUser Just lstKey -> pure lstKey let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey pure (Just lastKey, Just clientId) @@ -337,8 +377,10 @@ grantConsentH :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -347,8 +389,7 @@ grantConsentH :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId ::: TeamId ::: JSON -> @@ -369,8 +410,10 @@ grantConsent :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -379,8 +422,7 @@ grantConsent :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -389,7 +431,7 @@ grantConsent :: grantConsent zusr tid = do userLHStatus <- liftSem $ - note teamMemberNotFound + note TeamMemberNotFound =<< fmap (view legalHoldStatus) <$> getTeamMember tid zusr case userLHStatus of lhs@UserLegalHoldNoConsent -> @@ -406,8 +448,10 @@ requestDeviceH :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -417,8 +461,7 @@ requestDeviceH :: ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore, - WaiError + TeamStore ] r => UserId ::: TeamId ::: UserId ::: JSON -> @@ -440,8 +483,10 @@ requestDevice :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -451,8 +496,7 @@ requestDevice :: ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -466,12 +510,12 @@ requestDevice zusr tid uid = do . Log.field "action" (Log.val "LegalHold.requestDevice") zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership - member <- liftSem $ note teamMemberNotFound =<< getTeamMember tid uid + member <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid case member ^. legalHoldStatus of - UserLegalHoldEnabled -> liftSem $ throw userLegalHoldAlreadyEnabled + UserLegalHoldEnabled -> liftSem $ throw UserLegalHoldAlreadyEnabled lhs@UserLegalHoldPending -> RequestDeviceAlreadyPending <$ provisionLHDevice lhs lhs@UserLegalHoldDisabled -> RequestDeviceSuccess <$ provisionLHDevice lhs - UserLegalHoldNoConsent -> liftSem $ throw 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: @@ -507,8 +551,11 @@ approveDeviceH :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, + Error AuthenticationError, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -518,8 +565,7 @@ approveDeviceH :: ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore, - WaiError + TeamStore ] r => UserId ::: TeamId ::: UserId ::: ConnId ::: JsonRequest Public.ApproveLegalHoldForUserRequest ::: JSON -> @@ -536,8 +582,11 @@ approveDevice :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, + Error AuthenticationError, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -547,8 +596,7 @@ approveDevice :: ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -562,7 +610,7 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo Log.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "LegalHold.approveDevice") - liftSem . unless (zusr == uid) $ throw accessDenied + liftSem . unless (zusr == uid) $ throw AccessDenied assertOnTeam uid tid ensureReAuthorised zusr mPassword userLHStatus <- @@ -573,7 +621,7 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo (prekeys, lastPrekey') <- case mPreKeys of Nothing -> do Log.info $ Log.msg @Text "No prekeys found" - liftSem $ throw 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 @@ -587,13 +635,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 :: Member WaiError r => UserLegalHoldStatus -> Galley r () + assertUserLHPending :: Member (Error LegalHoldError) r => UserLegalHoldStatus -> Galley r () assertUserLHPending userLHStatus = liftSem $ do case userLHStatus of - UserLegalHoldEnabled -> throw userLegalHoldAlreadyEnabled + UserLegalHoldEnabled -> throw UserLegalHoldAlreadyEnabled UserLegalHoldPending -> pure () - UserLegalHoldDisabled -> throw userLegalHoldNotPending - UserLegalHoldNoConsent -> throw userLegalHoldNotPending + UserLegalHoldDisabled -> throw UserLegalHoldNotPending + UserLegalHoldNoConsent -> throw UserLegalHoldNotPending disableForUserH :: Members @@ -602,8 +650,11 @@ disableForUserH :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, + Error AuthenticationError, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -612,8 +663,7 @@ disableForUserH :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId ::: TeamId ::: UserId ::: JsonRequest Public.DisableLegalHoldForUserRequest ::: JSON -> @@ -636,8 +686,11 @@ disableForUser :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, + Error AuthenticationError, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -646,8 +699,7 @@ disableForUser :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -689,8 +741,10 @@ changeLegalholdStatus :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, Error ConversationError, Error FederationError, + Error LegalHoldError, Error TeamError, ExternalAccess, FederatorAccess, @@ -699,8 +753,7 @@ changeLegalholdStatus :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore, - WaiError + TeamStore ] r => TeamId -> @@ -740,12 +793,12 @@ changeLegalholdStatus tid uid old new = do blockNonConsentingConnections uid handleGroupConvPolicyConflicts uid new noop = pure () - illegal = liftSem $ throw userLegalHoldIllegalOperation + illegal = liftSem $ throw UserLegalHoldIllegalOperation -- FUTUREWORK: make this async? blockNonConsentingConnections :: forall r. - Members '[BrigAccess, LegalHoldStore, TeamStore, WaiError] r => + Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamStore] r => UserId -> Galley r () blockNonConsentingConnections uid = do @@ -757,7 +810,7 @@ blockNonConsentingConnections uid = do [] -> pure () msgs@(_ : _) -> do Log.warn $ Log.msg @String msgs - liftSem $ throw legalHoldCouldNotBlockConnections + liftSem $ throw LegalHoldCouldNotBlockConnections where findConflicts :: [ConnectionStatus] -> Galley r [[UserId]] findConflicts conns = do @@ -825,6 +878,7 @@ handleGroupConvPolicyConflicts :: CodeStore, ConversationStore, Error ActionError, + Error InvalidInput, Error ConversationError, Error FederationError, Error TeamError, @@ -835,8 +889,7 @@ handleGroupConvPolicyConflicts :: LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index f1c0c1da887..3d193b2f6c8 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -29,14 +29,13 @@ where 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 @@ -49,7 +48,7 @@ import Wire.API.Federation.API.Galley -- -- Throws "bad-state" when the user is not part of the conversation. conversationView :: - Members '[WaiError] r => + Member (Error InternalError) r => UserId -> Data.Conversation -> Galley r Conversation @@ -64,8 +63,7 @@ conversationView uid conv = do +++ idToText uid +++ val " is not a member of conv " +++ idToText (convId conv) - liftSem $ throw badState - badState = mkError status500 "bad-state" "Bad internal member state." + liftSem $ throw BadMemberState -- | View for a given user of a stored conversation. -- diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index c2b3eb131ab..ee3bd5cb1ad 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -64,7 +64,6 @@ import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error, result, setStatus) import Network.Wai.Utilities hiding (Error) -import qualified Network.Wai.Utilities.Error as Wai import Polysemy import Polysemy.Error import qualified System.Logger.Class as Logger @@ -72,11 +71,9 @@ 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.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 @@ -106,7 +103,7 @@ getBotConversation zbot zcnv = do Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) getUnqualifiedConversation :: - Members '[ConversationStore, Error ConversationError, WaiError] r => + Members '[ConversationStore, Error ConversationError, Error InternalError] r => UserId -> ConvId -> Galley r Public.Conversation @@ -116,7 +113,13 @@ getUnqualifiedConversation zusr cnv = do getConversation :: forall r. - Members '[ConversationStore, Error ConversationError, WaiError] r => + Members + '[ ConversationStore, + Error ConversationError, + Error FederationError, + Error InternalError + ] + r => UserId -> Qualified ConvId -> Galley r Public.Conversation @@ -132,36 +135,40 @@ getConversation zusr cnv = do getRemoteConversation remoteConvId = do conversations <- getRemoteConversations zusr [remoteConvId] liftSem $ case conversations of - [] -> throwErrorDescriptionType @ConvNotFound + [] -> throw ConvNotFound [conv] -> pure conv - _convs -> throw (federationUnexpectedBody "expected one conversation, got multiple") + -- _convs -> throw (federationUnexpectedBody "expected one conversation, got multiple") + _convs -> throw $ FederationUnexpectedBody "expected one conversation, got multiple" getRemoteConversations :: - Members '[ConversationStore, WaiError] 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 : _, _) -> liftSem $ throw (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 +-- fgcrError :: FailedGetConversationReason -> Wai.Error +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 @@ -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, WaiError] 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 :: - Members '[ConversationStore, WaiError] r => + Members '[ConversationStore, Error InternalError] r => UserId -> Public.ListConversations -> Galley r Public.ConversationsResponse @@ -490,11 +496,11 @@ getConversationByReusableCode :: CodeStore, ConversationStore, Error ActionError, + Error CodeError, Error ConversationError, Error FederationError, Error TeamError, - TeamStore, - WaiError + TeamStore ] r => UserId -> diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 389158f8a97..4271345b07c 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -124,7 +124,6 @@ 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.Federation.Client import qualified Wire.API.Notification as Public import qualified Wire.API.Team as Public @@ -140,27 +139,27 @@ import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) getTeamH :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => UserId ::: TeamId ::: JSON -> Galley r Response getTeamH (zusr ::: tid ::: _) = - maybe (liftSem (throw teamNotFound)) (pure . json) =<< lookupTeam zusr tid + maybe (liftSem (throw TeamNotFound)) (pure . json) =<< lookupTeam zusr tid getTeamInternalH :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => TeamId ::: JSON -> Galley r Response getTeamInternalH (tid ::: _) = liftSem . fmap json $ - E.getTeam tid >>= note teamNotFound + E.getTeam tid >>= note TeamNotFound getTeamNameInternalH :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => TeamId ::: JSON -> Galley r Response getTeamNameInternalH (tid ::: _) = liftSem . fmap json $ - getTeamNameInternal tid >>= note teamNotFound + getTeamNameInternal tid >>= note TeamNotFound getTeamNameInternal :: Member TeamStore r => TeamId -> Sem r (Maybe TeamName) getTeamNameInternal = fmap (fmap TeamName) . E.getTeamName @@ -196,7 +195,15 @@ lookupTeam zusr tid = do else pure Nothing createNonBindingTeamH :: - Members '[BrigAccess, Error ActionError, GundeckAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> Galley r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do @@ -205,7 +212,14 @@ createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do pure (empty & setStatus status201 . location newTeamId) createNonBindingTeam :: - Members '[BrigAccess, Error ActionError, GundeckAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + Error ActionError, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> Public.NonBindingNewTeam -> @@ -235,7 +249,7 @@ createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do pure (team ^. teamId) createBindingTeamH :: - Members '[BrigAccess, GundeckAccess, TeamStore, WaiError] r => + Members '[BrigAccess, Error InvalidInput, GundeckAccess, TeamStore] r => UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley r Response createBindingTeamH (zusr ::: tid ::: req ::: _) = do @@ -244,7 +258,7 @@ createBindingTeamH (zusr ::: tid ::: req ::: _) = do pure (empty & setStatus status201 . location newTeamId) createBindingTeam :: - Members '[BrigAccess, GundeckAccess, TeamStore, WaiError] r => + Members '[BrigAccess, GundeckAccess, TeamStore] r => UserId -> TeamId -> BindingNewTeam -> @@ -258,7 +272,14 @@ createBindingTeam zusr tid (BindingNewTeam body) = do pure tid updateTeamStatusH :: - Members '[BrigAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + TeamStore + ] + r => TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley r Response updateTeamStatusH (tid ::: req ::: _) = do @@ -267,12 +288,12 @@ updateTeamStatusH (tid ::: req ::: _) = do return empty updateTeamStatus :: - Members '[BrigAccess, TeamStore, WaiError] r => + Members '[BrigAccess, Error ActionError, Error TeamError, 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 @@ -290,18 +311,25 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do then 1 else possiblyStaleSize Journal.teamActivate tid size c teamCreationTime - journal _ _ = liftSem $ throw invalidTeamStatusUpdate - validateTransition :: Member WaiError r => (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 - (_, _) -> liftSem $ throw invalidTeamStatusUpdate + (_, _) -> liftSem $ throw InvalidTeamStatusUpdate updateTeamH :: - Members '[GundeckAccess, TeamStore, WaiError] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> Galley r Response updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -310,7 +338,13 @@ updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do pure empty updateTeam :: - Members '[GundeckAccess, TeamStore, WaiError] r => + Members + '[ Error ActionError, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -331,7 +365,16 @@ updateTeam zusr zcon tid updateData = do liftSem . E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon deleteTeamH :: - Members '[BrigAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + Error ActionError, + Error AuthenticationError, + Error InternalError, + Error InvalidInput, + Error TeamError, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> Galley r Response deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -341,16 +384,25 @@ deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do -- | 'TeamDeleteData' is only required for binding teams deleteTeam :: - Members '[BrigAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + Error ActionError, + Error AuthenticationError, + Error InternalError, + Error InvalidInput, + Error TeamError, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> Maybe Public.TeamDeleteData -> Galley r () deleteTeam zusr zcon tid mBody = do - team <- liftSem $ E.getTeam tid >>= note teamNotFound + team <- liftSem $ E.getTeam tid >>= note TeamNotFound case tdStatus team of - Deleted -> liftSem $ throw teamNotFound + Deleted -> liftSem $ throw TeamNotFound PendingDelete -> queueTeamDeletion tid zusr (Just zcon) _ -> do @@ -360,22 +412,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 :: - Members '[TeamStore, WaiError] r => + Members '[Error InternalError, Error TeamError, TeamStore] r => TeamId -> Galley r () internalDeleteBindingTeamWithOneMember tid = do team <- liftSem (E.getTeam tid) liftSem . unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ - throw noBindingTeam + throw NoBindingTeam mems <- liftSem $ E.getTeamMembersWithLimit tid (unsafeRange 2) case mems ^. teamMembers of (mem : []) -> queueTeamDeletion tid (mem ^. userId) Nothing - _ -> liftSem $ throw notAOneMemberTeam + _ -> liftSem $ throw NotAOneMemberTeam -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. uncheckedDeleteTeam :: @@ -464,18 +516,18 @@ uncheckedDeleteTeam zusr zcon tid = do pure (pp', ee' ++ ee) getTeamConversationRoles :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => UserId -> TeamId -> Galley r Public.ConversationRolesList getTeamConversationRoles zusr tid = do - liftSem . void $ E.getTeamMember tid zusr >>= note (errorDescriptionTypeToWai @NotATeamMember) + liftSem . void $ E.getTeamMember tid zusr >>= note 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 :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley r Response getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do @@ -483,26 +535,26 @@ getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do pure . json $ teamMemberListJson withPerms memberList getTeamMembers :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) getTeamMembers zusr tid maxResults = liftSem $ do - m <- E.getTeamMember tid zusr >>= note (errorDescriptionTypeToWai @NotATeamMember) + m <- E.getTeamMember tid zusr >>= note NotATeamMember mems <- E.getTeamMembersWithLimit tid maxResults let withPerms = (m `canSeePermsOf`) pure (mems, withPerms) getTeamMembersCSVH :: - (Members '[BrigAccess, TeamStore, WaiError] r) => + (Members '[BrigAccess, Error ActionError, TeamStore] r) => UserId ::: TeamId ::: JSON -> Galley r Response getTeamMembersCSVH (zusr ::: tid ::: _) = do liftSem $ E.getTeamMember tid zusr >>= \case - Nothing -> throw accessDenied - Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throw accessDenied + Nothing -> throw AccessDenied + Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throw AccessDenied env <- ask -- In case an exception is thrown inside the StreamingBody of responseStream @@ -612,7 +664,13 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do (UserScimExternalId _) -> Nothing bulkGetTeamMembersH :: - Members '[TeamStore, WaiError] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + TeamStore + ] + r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley r Response bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do @@ -622,7 +680,7 @@ bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do -- | like 'getTeamMembers', but with an explicit list of users we are to return. bulkGetTeamMembers :: - Members '[TeamStore, WaiError] r => + Members '[Error ActionError, Error InvalidInput, Error TeamError, TeamStore] r => UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> @@ -630,15 +688,15 @@ bulkGetTeamMembers :: Galley r (TeamMemberList, TeamMember -> Bool) bulkGetTeamMembers zusr tid maxResults uids = liftSem $ do unless (length uids <= fromIntegral (fromRange maxResults)) $ - throw bulkGetMemberLimitExceeded - m <- E.getTeamMember tid zusr >>= note (errorDescriptionTypeToWai @NotATeamMember) + throw BulkGetMemberLimitExceeded + m <- E.getTeamMember tid zusr >>= note NotATeamMember mems <- E.selectTeamMembers tid uids let withPerms = (m `canSeePermsOf`) hasMore = ListComplete pure (newTeamMemberList mems hasMore, withPerms) getTeamMemberH :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do @@ -646,7 +704,7 @@ getTeamMemberH (zusr ::: tid ::: uid ::: _) = do pure . json $ teamMemberJson withPerms member getTeamMember :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => UserId -> TeamId -> UserId -> @@ -655,13 +713,13 @@ getTeamMember zusr tid uid = do m <- liftSem $ E.getTeamMember tid zusr - >>= note (errorDescriptionTypeToWai @NotATeamMember) + >>= note NotATeamMember let withPerms = (m `canSeePermsOf`) - member <- liftSem $ E.getTeamMember tid uid >>= note teamMemberNotFound + member <- liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound pure (member, withPerms) internalDeleteBindingTeamWithOneMemberH :: - Members '[TeamStore, WaiError] r => + Members '[Error InternalError, Error TeamError, TeamStore] r => TeamId -> Galley r Response internalDeleteBindingTeamWithOneMemberH tid = do @@ -669,19 +727,19 @@ internalDeleteBindingTeamWithOneMemberH tid = do pure (empty & setStatus status202) uncheckedGetTeamMemberH :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => TeamId ::: UserId ::: JSON -> Galley r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid uncheckedGetTeamMember :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => TeamId -> UserId -> Galley r TeamMember uncheckedGetTeamMember tid uid = - liftSem (E.getTeamMember tid uid) >>= ifNothing teamMemberNotFound + liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound uncheckedGetTeamMembersH :: Member TeamStore r => @@ -702,12 +760,14 @@ addTeamMemberH :: '[ BrigAccess, GundeckAccess, Error ActionError, + Error LegalHoldError, + Error InvalidInput, + Error TeamError, LegalHoldStore, MemberStore, TeamFeatureStore, TeamNotificationStore, - TeamStore, - WaiError + TeamStore ] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> @@ -722,12 +782,13 @@ addTeamMember :: '[ BrigAccess, GundeckAccess, Error ActionError, + Error LegalHoldError, + Error TeamError, LegalHoldStore, MemberStore, TeamFeatureStore, TeamNotificationStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -758,13 +819,15 @@ addTeamMember zusr zcon tid nmem = do uncheckedAddTeamMemberH :: Members '[ BrigAccess, + Error LegalHoldError, + Error InvalidInput, + Error TeamError, GundeckAccess, - MemberStore, LegalHoldStore, + MemberStore, TeamFeatureStore, TeamStore, - TeamNotificationStore, - WaiError + TeamNotificationStore ] r => TeamId ::: JsonRequest NewTeamMember ::: JSON -> @@ -778,12 +841,13 @@ uncheckedAddTeamMember :: Members '[ BrigAccess, GundeckAccess, + Error LegalHoldError, + Error TeamError, MemberStore, LegalHoldStore, TeamFeatureStore, TeamStore, - TeamNotificationStore, - WaiError + TeamNotificationStore ] r => TeamId -> @@ -798,7 +862,15 @@ uncheckedAddTeamMember tid nmem = do Journal.teamUpdate tid (sizeBeforeAdd + 1) billingUserIds updateTeamMemberH :: - Members '[BrigAccess, GundeckAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -809,7 +881,14 @@ updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do updateTeamMember :: forall r. - Members '[BrigAccess, GundeckAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + Error ActionError, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -823,7 +902,7 @@ updateTeamMember zusr zcon tid targetMember = do . Log.field "action" (Log.val "Teams.updateTeamMember") -- get the team and verify permissions - team <- liftSem . fmap tdTeam $ E.getTeam tid >>= note teamNotFound + team <- liftSem . fmap tdTeam $ E.getTeam tid >>= note TeamNotFound user <- liftSem (E.getTeamMember tid zusr) >>= permissionCheck SetMemberPermissions @@ -831,13 +910,13 @@ updateTeamMember zusr zcon tid targetMember = do -- user may not elevate permissions targetPermissions `ensureNotElevated` user previousMember <- - liftSem $ E.getTeamMember tid targetId >>= note teamMemberNotFound + liftSem $ E.getTeamMember tid targetId >>= note TeamMemberNotFound liftSem . when ( downgradesOwner previousMember targetPermissions && not (canDowngradeOwner user previousMember) ) - $ throw accessDenied + $ throw AccessDenied -- update target in Cassandra liftSem $ E.setTeamMemberPermissions (previousMember ^. permissions) tid targetId targetPermissions @@ -878,11 +957,14 @@ deleteTeamMemberH :: Members '[ BrigAccess, ConversationStore, + Error ActionError, + Error AuthenticationError, + Error InvalidInput, + Error TeamError, ExternalAccess, GundeckAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> @@ -902,11 +984,14 @@ deleteTeamMember :: Members '[ BrigAccess, ConversationStore, + Error ActionError, + Error AuthenticationError, + Error InvalidInput, + Error TeamError, ExternalAccess, GundeckAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -923,14 +1008,14 @@ deleteTeamMember zusr zcon tid remove mBody = do targetMember <- liftSem $ E.getTeamMember tid remove void $ permissionCheck RemoveTeamMember zusrMember liftSem $ do - dm <- note teamMemberNotFound zusrMember - tm <- note teamMemberNotFound targetMember - unless (canDeleteMember dm tm) $ throw accessDenied - team <- tdTeam <$> (liftSem (E.getTeam tid) >>= ifNothing teamNotFound) + 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 @@ -1009,20 +1094,26 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do liftSem $ E.deliverAsync (bots `zip` repeat y) getTeamConversations :: - Members '[TeamStore, WaiError] r => + Members '[Error ActionError, Error TeamError, TeamStore] r => UserId -> TeamId -> Galley r Public.TeamConversationList getTeamConversations zusr tid = liftSem $ do tm <- E.getTeamMember tid zusr - >>= note (errorDescriptionTypeToWai @NotATeamMember) + >>= note NotATeamMember unless (tm `hasPermission` GetTeamConversations) $ - throwErrorDescription (operationDenied GetTeamConversations) + throw . OperationDenied . show $ GetTeamConversations Public.newTeamConversationList <$> E.getTeamConversations tid getTeamConversation :: - Members '[TeamStore, WaiError] r => + Members + '[ Error ActionError, + Error ConversationError, + Error TeamError, + TeamStore + ] + r => UserId -> TeamId -> ConvId -> @@ -1030,11 +1121,11 @@ getTeamConversation :: getTeamConversation zusr tid cid = liftSem $ do tm <- E.getTeamMember tid zusr - >>= note (errorDescriptionTypeToWai @NotATeamMember) + >>= note NotATeamMember unless (tm `hasPermission` GetTeamConversations) $ - throwErrorDescription (operationDenied GetTeamConversations) + throw . OperationDenied . show $ GetTeamConversations E.getTeamConversation tid cid - >>= note (errorDescriptionTypeToWai @ConvNotFound) + >>= note ConvNotFound deleteTeamConversation :: Members @@ -1045,6 +1136,7 @@ deleteTeamConversation :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, Error TeamError, ExternalAccess, FederatorAccess, @@ -1052,8 +1144,7 @@ deleteTeamConversation :: GundeckAccess, LegalHoldStore, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -1067,7 +1158,13 @@ deleteTeamConversation zusr zcon _tid cid = do void $ API.deleteLocalConversation lusr zcon lconv getSearchVisibilityH :: - Members '[SearchVisibilityStore, TeamStore, WaiError] r => + Members + '[ Error ActionError, + Error TeamError, + SearchVisibilityStore, + TeamStore + ] + r => UserId ::: TeamId ::: JSON -> Galley r Response getSearchVisibilityH (uid ::: tid ::: _) = do @@ -1076,7 +1173,15 @@ getSearchVisibilityH (uid ::: tid ::: _) = do json <$> getSearchVisibilityInternal tid setSearchVisibilityH :: - Members '[SearchVisibilityStore, TeamStore, TeamFeatureStore, WaiError] r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + SearchVisibilityStore, + TeamStore, + TeamFeatureStore + ] + r => UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do @@ -1118,38 +1223,38 @@ withTeamIds usr range size k = case range of k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: Members '[TeamStore, WaiError] r => [UserId] -> Galley r () +ensureUnboundUsers :: Members '[Error TeamError, 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 liftSem . when (any (== Binding) binds) $ - throw userBindingExists + throw UserBindingExists -ensureNonBindingTeam :: Members '[TeamStore, WaiError] r => TeamId -> Galley r () +ensureNonBindingTeam :: Members '[Error TeamError, TeamStore] r => TeamId -> Galley r () ensureNonBindingTeam tid = do - team <- liftSem $ note teamNotFound =<< E.getTeam tid + team <- liftSem $ note TeamNotFound =<< E.getTeam tid liftSem . when ((tdTeam team) ^. teamBinding == Binding) $ - throw noAddToBinding + 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 :: Member WaiError r => Permissions -> TeamMember -> Galley r () +ensureNotElevated :: Member (Error ActionError) r => Permissions -> TeamMember -> Galley r () ensureNotElevated targetPermissions member = liftSem . unless ( (targetPermissions ^. self) `Set.isSubsetOf` (member ^. permissions . copy) ) - $ throw invalidPermissions + $ throw InvalidPermissions -ensureNotTooLarge :: Members '[BrigAccess, WaiError] r => TeamId -> Galley r TeamSize +ensureNotTooLarge :: Members '[BrigAccess, Error TeamError] r => TeamId -> Galley r TeamSize ensureNotTooLarge tid = do o <- view options (TeamSize size) <- liftSem $ E.getSize tid liftSem . unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ - throw tooManyTeamMembers + throw TooManyTeamMembers return $ TeamSize size -- | Ensure that a team doesn't exceed the member count limit for the LegalHold @@ -1162,23 +1267,23 @@ ensureNotTooLarge tid = do -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. ensureNotTooLargeForLegalHold :: - Members '[BrigAccess, LegalHoldStore, TeamFeatureStore, WaiError] r => + Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => TeamId -> Int -> Galley r () ensureNotTooLargeForLegalHold tid teamSize = whenM (isLegalHoldEnabledForTeam tid) $ unlessM (teamSizeBelowLimit teamSize) $ - liftSem $ throw tooManyTeamMembersOnTeamWithLegalhold + liftSem $ throw TooManyTeamMembersOnTeamWithLegalhold ensureNotTooLargeToActivateLegalHold :: - Members '[BrigAccess, WaiError] r => + Members '[BrigAccess, Error TeamError] r => TeamId -> Galley r () ensureNotTooLargeToActivateLegalHold tid = do (TeamSize teamSize) <- liftSem $ E.getSize tid unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ - liftSem $ throw cannotEnableLegalHoldServiceLargeTeam + liftSem $ throw CannotEnableLegalHoldServiceLargeTeam teamSizeBelowLimit :: Int -> Galley r Bool teamSizeBelowLimit teamSize = do @@ -1194,11 +1299,11 @@ teamSizeBelowLimit teamSize = do addTeamMemberInternal :: Members '[ BrigAccess, + Error TeamError, GundeckAccess, MemberStore, TeamNotificationStore, - TeamStore, - WaiError + TeamStore ] r => TeamId -> @@ -1238,7 +1343,13 @@ 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, WaiError] r => + Members + '[ BrigAccess, + Error TeamError, + Error TeamNotificationError, + TeamNotificationStore + ] + r => UserId ::: Maybe ByteString {- NotificationId -} ::: Range 1 10000 Int32 @@ -1249,13 +1360,13 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do json @Public.QueuedNotificationList <$> APITeamQueue.getTeamNotifications zusr since size where - parseSince :: Member WaiError r => Galley r (Maybe Public.NotificationId) + parseSince :: Member (Error TeamNotificationError) r => Galley r (Maybe Public.NotificationId) parseSince = maybe (pure Nothing) (fmap Just . parseUUID) sinceRaw - parseUUID :: Member WaiError r => ByteString -> Galley r Public.NotificationId + parseUUID :: Member (Error TeamNotificationError) r => ByteString -> Galley r Public.NotificationId parseUUID raw = maybe - (liftSem (throw invalidTeamNotificationId)) + (liftSem (throw InvalidTeamNotificationId)) (pure . Id) ((UUID.fromASCIIBytes >=> isV1UUID) raw) @@ -1263,7 +1374,7 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do isV1UUID u = if UUID.version u == 1 then Just u else Nothing finishCreateTeam :: - Members '[GundeckAccess, TeamStore, WaiError] r => + Members '[GundeckAccess, TeamStore] r => Team -> TeamMember -> [TeamMember] -> @@ -1281,38 +1392,54 @@ finishCreateTeam team owner others zcon = do -- FUTUREWORK: Get rid of CPS withBindingTeam :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => UserId -> (TeamId -> Galley r b) -> Galley r b withBindingTeam zusr callback = do - tid <- liftSem $ E.getOneUserTeam zusr >>= note teamNotFound - binding <- liftSem $ E.getTeamBinding tid >>= note teamNotFound + tid <- liftSem $ E.getOneUserTeam zusr >>= note TeamNotFound + binding <- liftSem $ E.getTeamBinding tid >>= note TeamNotFound case binding of Binding -> callback tid - NonBinding -> liftSem $ throw nonBindingTeam + NonBinding -> liftSem $ throw NotABindingTeamMember -getBindingTeamIdH :: Members '[TeamStore, WaiError] r => UserId -> Galley r Response +getBindingTeamIdH :: Members '[Error TeamError, TeamStore] r => UserId -> Galley r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: Members '[TeamStore, WaiError] r => UserId -> Galley r TeamId +getBindingTeamId :: Members '[Error TeamError, TeamStore] r => UserId -> Galley r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: Members '[TeamStore, WaiError] r => UserId -> Galley r Response +getBindingTeamMembersH :: Members '[Error TeamError, TeamStore] r => UserId -> Galley r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers -getBindingTeamMembers :: Members '[TeamStore, WaiError] r => UserId -> Galley r TeamMemberList +getBindingTeamMembers :: + Members + '[ Error TeamError, + TeamStore + ] + r => + UserId -> + Galley r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> getTeamMembersForFanout tid canUserJoinTeamH :: - Members '[BrigAccess, LegalHoldStore, TeamFeatureStore, WaiError] 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, WaiError] r => TeamId -> Galley r () +canUserJoinTeam :: + Members + '[ BrigAccess, + Error LegalHoldError, + LegalHoldStore, + TeamFeatureStore + ] + r => + TeamId -> + Galley r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do @@ -1352,7 +1479,13 @@ getSearchVisibilityInternal = . SearchVisibilityData.getSearchVisibility setSearchVisibilityInternalH :: - Members '[SearchVisibilityStore, TeamFeatureStore, WaiError] r => + Members + '[ Error InvalidInput, + Error TeamError, + SearchVisibilityStore, + TeamFeatureStore + ] + r => TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityInternalH (tid ::: req ::: _) = do @@ -1360,27 +1493,27 @@ setSearchVisibilityInternalH (tid ::: req ::: _) = do pure noContent setSearchVisibilityInternal :: - Members '[SearchVisibilityStore, TeamFeatureStore, WaiError] r => + Members '[Error TeamError, SearchVisibilityStore, TeamFeatureStore] r => TeamId -> TeamSearchVisibilityView -> Galley r () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do status <- getTeamSearchVisibilityAvailableInternal tid liftSem . unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ - throw teamSearchVisibilityNotEnabled + throw TeamSearchVisibilityNotEnabled liftSem $ SearchVisibilityData.setSearchVisibility tid searchVisibility userIsTeamOwnerH :: - Members '[TeamStore, WaiError] r => + Members '[Error ActionError, Error TeamError, TeamStore] r => TeamId ::: UserId ::: JSON -> Galley r Response userIsTeamOwnerH (tid ::: uid ::: _) = do userIsTeamOwner tid uid >>= \case True -> pure empty - False -> liftSem $ throw accessDenied + False -> liftSem $ throw AccessDenied userIsTeamOwner :: - Members '[TeamStore, WaiError] r => + Members '[Error TeamError, TeamStore] r => TeamId -> UserId -> Galley r Bool @@ -1390,7 +1523,7 @@ userIsTeamOwner tid uid = do -- Queues a team for async deletion queueTeamDeletion :: - Member WaiError r => + Member (Error InternalError) r => TeamId -> UserId -> Maybe ConnId -> @@ -1399,4 +1532,4 @@ queueTeamDeletion tid zusr zcon = do q <- view deleteQueue ok <- Q.tryPush q (TeamItem tid zusr zcon) liftSem . unless ok $ - throw deleteQueueFull + throw DeleteQueueFull diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 03ee4c74c0e..3f1f8c2720a 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -45,7 +45,6 @@ module Galley.API.Teams.Features ) where -import Bilge (MonadHttp) import Control.Lens import qualified Data.Aeson as Aeson import Data.ByteString.Conversion hiding (fromList) @@ -98,7 +97,14 @@ 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, Members '[TeamStore, WaiError] r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + TeamStore + ] + r + ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -115,7 +121,14 @@ getFeatureStatus getter doauth tid = do -- | For team-settings, like 'getFeatureStatus'. setFeatureStatus :: forall (a :: Public.TeamFeatureName) r. - (Public.KnownTeamFeatureName a, Members '[TeamStore, WaiError] r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + TeamStore + ] + r + ) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -133,7 +146,14 @@ 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, Members '[TeamStore, WaiError] r) => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + TeamStore + ] + r + ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> UserId -> Galley r (Public.TeamFeatureStatus a) @@ -148,7 +168,15 @@ getFeatureConfig getter zusr = do getter (Right tid) getAllFeatureConfigs :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => + Members + '[ Error ActionError, + Error InternalError, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> Galley r AllFeatureConfigs getAllFeatureConfigs zusr = do @@ -158,7 +186,7 @@ getAllFeatureConfigs zusr = do forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a), - Members '[TeamStore, WaiError] r + Members '[Error ActionError, Error TeamError, TeamStore] r ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> Galley r (Text, Aeson.Value) @@ -184,7 +212,15 @@ getAllFeatureConfigs zusr = do ] getAllFeaturesH :: - Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => + Members + '[ Error ActionError, + Error InternalError, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId ::: TeamId ::: JSON -> Galley r Response getAllFeaturesH (uid ::: tid ::: _) = @@ -192,7 +228,15 @@ getAllFeaturesH (uid ::: tid ::: _) = getAllFeatures :: forall r. - Members '[LegalHoldStore, TeamFeatureStore, TeamStore, WaiError] r => + Members + '[ Error ActionError, + Error InternalError, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> TeamId -> Galley r Aeson.Value @@ -225,8 +269,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 ) => @@ -275,12 +318,12 @@ getSSOStatusInternal = FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled setSSOStatusInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore, WaiError] 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 (liftSem (throw disableSsoNotImplemented)) + Public.TeamFeatureDisabled -> const (liftSem (throw DisableSsoNotImplemented)) Public.TeamFeatureEnabled -> const (pure ()) getTeamSearchVisibilityAvailableInternal :: @@ -349,7 +392,7 @@ setDigitalSignaturesInternal :: setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () getLegalholdStatusInternal :: - Members '[LegalHoldStore, TeamFeatureStore, WaiError] r => + Members '[LegalHoldStore, TeamFeatureStore] r => GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = @@ -368,9 +411,13 @@ setLegalholdStatusInternal :: CodeStore, ConversationStore, Error ActionError, + Error AuthenticationError, Error ConversationError, Error FederationError, + Error InvalidInput, + Error LegalHoldError, Error TeamError, + Error TeamFeatureError, ExternalAccess, FederatorAccess, FireAndForget, @@ -380,8 +427,7 @@ setLegalholdStatusInternal :: MemberStore, TeamFeatureStore, TeamStore, - TeamMemberStore p, - WaiError + TeamMemberStore p ] r ) => @@ -398,9 +444,9 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do FeatureLegalHoldDisabledByDefault -> do pure () FeatureLegalHoldDisabledPermanently -> do - throw legalHoldFeatureFlagNotEnabled + throw LegalHoldFeatureFlagNotEnabled FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do - throw legalHoldWhitelistedOnly + throw LegalHoldWhitelistedOnly -- we're good to update the status now. case statusValue of @@ -451,13 +497,13 @@ getAppLockInternal mbtid = do pure $ fromMaybe defaultStatus status setAppLockInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore, WaiError] 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) $ - liftSem $ throw inactivityTimeoutTooLow + liftSem $ throw AppLockinactivityTimeoutTooLow let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureAppLock (EdFeatureApplockChanged status) @@ -473,7 +519,7 @@ getClassifiedDomainsInternal _mbtid = do Public.TeamFeatureEnabled -> config getConferenceCallingInternal :: - Members '[TeamFeatureStore, WaiError] r => + Members '[Error InternalError, TeamFeatureStore] r => GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do @@ -534,7 +580,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, Member WaiError r) => + (flag ~ 'Public.TeamFeatureConferenceCalling, Member (Error InternalError) r) => UserId -> Galley r (Public.TeamFeatureStatus flag) getFeatureConfigViaAccount uid = do @@ -543,14 +589,14 @@ getFeatureConfigViaAccount uid = do getAccountFeatureConfigClient brigep mgr uid >>= handleResp where handleResp :: - Member WaiError r => + Member (Error InternalError) r => Either Client.ClientError Public.TeamFeatureStatusNoConfig -> Galley r Public.TeamFeatureStatusNoConfig handleResp (Right cfg) = pure cfg - handleResp (Left errmsg) = liftSem . throw . 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 -> @@ -566,7 +612,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 7d858c8e264..0836369ee8a 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -58,17 +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, WaiError] r => + Members '[BrigAccess, Error TeamError, TeamNotificationStore] r => UserId -> Maybe NotificationId -> Range 1 10000 Int32 -> Galley r QueuedNotificationList getTeamNotifications zusr since size = do - tid <- liftSem . (note teamNotFound =<<) $ (userTeam . accountUser =<<) <$> Intra.getUser zusr + tid <- liftSem . (note TeamNotFound =<<) $ (userTeam . accountUser =<<) <$> Intra.getUser zusr page <- liftSem $ E.getTeamNotifications tid since size pure $ queuedNotificationList diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 950a192853e..cdc4789c215 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -121,11 +121,7 @@ import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Code as Public import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.ErrorDescription - ( CodeNotFound, - ConvNotFound, - MissingLegalholdConsent, - UnknownClient, - mkErrorDescription, + ( mkErrorDescription, ) import qualified Wire.API.ErrorDescription as Public import qualified Wire.API.Event.Conversation as Public @@ -138,68 +134,107 @@ import Wire.API.ServantProto (RawProto (..)) import Wire.API.User.Client acceptConvH :: - Members '[ConversationStore, GundeckAccess, MemberStore, WaiError] 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, WaiError] 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, WaiError] 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, WaiError] 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]) $ liftSem . throw $ - invalidOp "block: invalid conversation type" + InvalidOpGeneral "block: invalid conversation type" let mems = Data.convLocalMembers conv when (zusr `isMember` mems) . liftSem $ E.deleteMembers cnv (UserList [zusr] []) unblockConvH :: - Members '[ConversationStore, GundeckAccess, MemberStore, WaiError] 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, WaiError] 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]) $ - liftSem . throw $ - invalidOp "unblock: invalid conversation type" + liftSem . throw . InvalidOp . Data.convType $ conv conv' <- acceptOne2One usr conv conn conversationView usr conv' @@ -219,6 +254,7 @@ updateConversationAccess :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, ExternalAccess, FederatorAccess, FireAndForget, @@ -249,6 +285,7 @@ updateConversationAccessUnqualified :: ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, FireAndForget, @@ -275,6 +312,7 @@ updateLocalConversationAccess :: ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, FireAndForget, @@ -306,6 +344,7 @@ updateConversationReceiptMode :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess @@ -331,6 +370,7 @@ updateConversationReceiptModeUnqualified :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess @@ -351,6 +391,7 @@ updateLocalConversationReceiptMode :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess @@ -379,6 +420,7 @@ updateConversationMessageTimerUnqualified :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess @@ -400,6 +442,7 @@ updateConversationMessageTimer :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess @@ -424,6 +467,7 @@ updateLocalConversationMessageTimer :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess @@ -445,6 +489,7 @@ deleteLocalConversation :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, Error TeamError, ExternalAccess, FederatorAccess, @@ -452,7 +497,6 @@ deleteLocalConversation :: TeamStore ] r => - Members '[] r => Local UserId -> ConnId -> Local ConvId -> @@ -470,8 +514,7 @@ addCodeH :: ConversationStore, Error ConversationError, ExternalAccess, - GundeckAccess, - WaiError + GundeckAccess ] r => UserId ::: ConnId ::: ConvId -> @@ -492,8 +535,7 @@ addCode :: ConversationStore, Error ConversationError, ExternalAccess, - GundeckAccess, - WaiError + GundeckAccess ] r => UserId -> @@ -504,9 +546,7 @@ 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 liftSem $ ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv @@ -534,10 +574,9 @@ rmCodeH :: Members '[ CodeStore, ConversationStore, - ExternalAccess, Error ConversationError, - GundeckAccess, - WaiError + ExternalAccess, + GundeckAccess ] r => UserId ::: ConnId ::: ConvId -> @@ -551,8 +590,7 @@ rmCode :: ConversationStore, Error ConversationError, ExternalAccess, - GundeckAccess, - WaiError + GundeckAccess ] r => UserId -> @@ -564,8 +602,7 @@ 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 liftSem $ ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv @@ -580,8 +617,8 @@ getCodeH :: Members '[ CodeStore, ConversationStore, - Error ConversationError, - WaiError + Error CodeError, + Error ConversationError ] r => UserId ::: ConvId -> @@ -593,8 +630,8 @@ getCode :: Members '[ CodeStore, ConversationStore, - Error ConversationError, - WaiError + Error CodeError, + Error ConversationError ] r => UserId -> @@ -602,14 +639,11 @@ getCode :: Galley r Public.ConversationCode getCode usr cnv = do conv <- - liftSem (E.getConversation cnv) - >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + 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 @@ -618,7 +652,7 @@ returnCode c = do pure $ Public.mkConversationCode (codeKey c) (codeValue c) urlPrefix checkReusableCodeH :: - Members '[CodeStore, WaiError] r => + Members '[CodeStore, Error CodeError, Error InvalidInput] r => JsonRequest Public.ConversationCode -> Galley r Response checkReusableCodeH req = do @@ -627,7 +661,7 @@ checkReusableCodeH req = do pure empty checkReusableCode :: - Members '[CodeStore, WaiError] r => + Members '[CodeStore, Error CodeError] r => Public.ConversationCode -> Galley r () checkReusableCode convCode = @@ -640,14 +674,15 @@ joinConversationByReusableCodeH :: ConversationStore, FederatorAccess, Error ActionError, + Error CodeError, Error ConversationError, Error FederationError, + Error InvalidInput, Error TeamError, ExternalAccess, GundeckAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> @@ -662,15 +697,16 @@ joinConversationByReusableCode :: CodeStore, ConversationStore, Error ActionError, + Error CodeError, Error ConversationError, Error FederationError, + Error InvalidInput, Error TeamError, FederatorAccess, ExternalAccess, GundeckAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -689,12 +725,12 @@ joinConversationByIdH :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, Error TeamError, ExternalAccess, GundeckAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId ::: ConnId ::: ConvId ::: JSON -> @@ -710,12 +746,12 @@ joinConversationById :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, Error TeamError, ExternalAccess, GundeckAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -733,12 +769,12 @@ joinConversation :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, Error TeamError, ExternalAccess, GundeckAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -750,7 +786,7 @@ joinConversation zusr zcon cnv access = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv conv <- ensureConversationAccess zusr cnv access - liftSem . mapError toWai $ ensureGroupConversation conv + liftSem . ensureGroupConversation $ conv -- FUTUREWORK: remote users? ensureMemberLimit (toList $ Data.convLocalMembers conv) [zusr] getUpdateResult $ do @@ -775,6 +811,7 @@ addMembersUnqualified :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, Error LegalHoldError, Error TeamError, ExternalAccess, @@ -801,6 +838,7 @@ addMembers :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, Error LegalHoldError, Error TeamError, ExternalAccess, @@ -824,7 +862,14 @@ addMembers zusr zcon cnv (Public.InviteQualified users role) = do ConversationJoin users role updateSelfMember :: - Members '[ConversationStore, GundeckAccess, ExternalAccess, MemberStore, WaiError] r => + Members + '[ ConversationStore, + Error ConversationError, + GundeckAccess, + ExternalAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -833,7 +878,7 @@ updateSelfMember :: updateSelfMember zusr zcon qcnv update = do lusr <- qualifyLocal zusr exists <- liftSem $ foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr - liftSem $ 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)) @@ -868,7 +913,14 @@ updateSelfMember zusr zcon qcnv update = do } updateUnqualifiedSelfMember :: - Members '[ConversationStore, GundeckAccess, ExternalAccess, MemberStore, WaiError] r => + Members + '[ ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -883,6 +935,7 @@ updateOtherMemberUnqualified :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess, @@ -907,6 +960,7 @@ updateOtherMember :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess, @@ -929,6 +983,7 @@ updateOtherMemberLocalConv :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess, @@ -962,6 +1017,7 @@ removeMemberUnqualified :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess, @@ -983,6 +1039,7 @@ removeMemberQualified :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess, @@ -1029,6 +1086,7 @@ removeMemberFromLocalConv :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess, @@ -1057,13 +1115,20 @@ data OtrResult | OtrUnknownClient !Public.UnknownClient | OtrConversationNotFound !Public.ConvNotFound -handleOtrResult :: Member WaiError r => OtrResult -> Galley r Response +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 _ -> throwErrorDescriptionType @UnknownClient - OtrConversationNotFound _ -> throwErrorDescriptionType @ConvNotFound + OtrUnknownClient _ -> throw UnknownClient + OtrConversationNotFound _ -> throw ConvNotFound postBotMessageH :: Members @@ -1071,12 +1136,15 @@ postBotMessageH :: BrigAccess, ClientStore, ConversationStore, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, FederatorAccess, GundeckAccess, ExternalAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> @@ -1092,12 +1160,12 @@ postBotMessage :: BrigAccess, ClientStore, ConversationStore, + Error LegalHoldError, + ExternalAccess, FederatorAccess, GundeckAccess, - ExternalAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => BotId -> @@ -1117,8 +1185,7 @@ postProteusMessage :: GundeckAccess, ExternalAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -1144,8 +1211,7 @@ postOtrMessageUnqualified :: GundeckAccess, ExternalAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -1182,7 +1248,19 @@ postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do <$> postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage postProtoOtrBroadcastH :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> Galley r Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do @@ -1191,7 +1269,19 @@ postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcastH :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> Galley r Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do @@ -1200,7 +1290,16 @@ postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcast :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> Public.OtrFilterMissing -> @@ -1220,7 +1319,16 @@ allowOtrFilterMissingInBody val (NewOtrMessage _ _ _ _ _ _ mrepmiss) = case mrep -- | bots are not supported on broadcast postNewOtrBroadcast :: - Members '[BrigAccess, ClientStore, GundeckAccess, TeamStore, WaiError] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId -> Maybe ConnId -> OtrFilterMissing -> @@ -1242,11 +1350,11 @@ postNewOtrMessage :: BrigAccess, ClientStore, ConversationStore, + Error LegalHoldError, ExternalAccess, GundeckAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserType -> @@ -1309,6 +1417,7 @@ updateConversationName :: Error ActionError, Error ConversationError, Error FederationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess @@ -1333,6 +1442,7 @@ updateUnqualifiedConversationName :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess @@ -1353,6 +1463,7 @@ updateLocalConversationName :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess @@ -1374,6 +1485,7 @@ updateLiveLocalConversationName :: '[ ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, FederatorAccess, GundeckAccess @@ -1389,7 +1501,13 @@ updateLiveLocalConversationName lusr con lcnv rename = updateLocalConversation lcnv (qUntagged lusr) (Just con) rename isTypingH :: - Members '[GundeckAccess, MemberStore, WaiError] r => + Members + '[ Error ConversationError, + Error InvalidInput, + GundeckAccess, + MemberStore + ] + r => UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> Galley r Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do @@ -1398,7 +1516,7 @@ isTypingH (zusr ::: zcon ::: cnv ::: req) = do pure empty isTyping :: - Members '[GundeckAccess, MemberStore, WaiError] r => + Members '[Error ConversationError, GundeckAccess, MemberStore] r => UserId -> ConnId -> ConvId -> @@ -1409,8 +1527,7 @@ isTyping zusr zcon cnv typingData = do let qcnv = Qualified cnv localDomain qusr = Qualified zusr localDomain mm <- liftSem $ E.getLocalMembers cnv - liftSem . 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 -> @@ -1420,12 +1537,22 @@ isTyping zusr zcon cnv typingData = do & pushRoute .~ RouteDirect & pushTransient .~ True -addServiceH :: Members '[ServiceStore, WaiError] 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 :: Members '[ServiceStore, WaiError] 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 @@ -1435,12 +1562,12 @@ addBotH :: '[ ClientStore, ConversationStore, Error ActionError, + Error InvalidInput, Error ConversationError, ExternalAccess, GundeckAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId ::: ConnId ::: JsonRequest AddBot -> @@ -1456,11 +1583,11 @@ addBot :: ConversationStore, Error ActionError, Error ConversationError, + Error InvalidInput, ExternalAccess, GundeckAccess, MemberStore, - TeamStore, - WaiError + TeamStore ] r => UserId -> @@ -1470,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 @@ -1499,10 +1625,9 @@ addBot zusr zcon b = do where regularConvChecks lusr c = do let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) - liftSem . unless (zusr `isMember` users) $ - throwErrorDescriptionType @ConvNotFound - liftSem . mapError toWai $ ensureGroupConversation c - self <- 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)) @@ -1513,10 +1638,19 @@ addBot zusr zcon b = do tcv <- liftSem $ E.getTeamConversation tid cid liftSem $ when (maybe True (view managedConversation) tcv) $ - throw noAddToManaged + throw NoAddToManaged rmBotH :: - Members '[ClientStore, ConversationStore, ExternalAccess, GundeckAccess, MemberStore, WaiError] 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 @@ -1527,10 +1661,10 @@ rmBot :: Members '[ ClientStore, ConversationStore, + Error ConversationError, ExternalAccess, GundeckAccess, - MemberStore, - WaiError + MemberStore ] r => UserId -> @@ -1539,13 +1673,12 @@ rmBot :: 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 liftSem . unless (zusr `isMember` Data.convLocalMembers c) $ - throwErrorDescriptionType @ConvNotFound + throw ConvNotFound let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) if not (any ((== b ^. rmBotId) . botMemId) bots) then pure Unchanged @@ -1564,11 +1697,10 @@ rmBot zusr zcon b = do ------------------------------------------------------------------------------- -- Helpers -ensureConvMember :: Member WaiError r => [LocalMember] -> UserId -> Galley r () +ensureConvMember :: Member (Error ConversationError) r => [LocalMember] -> UserId -> Galley r () ensureConvMember users usr = liftSem $ - unless (usr `isMember` users) $ - throwErrorDescriptionType @ConvNotFound + unless (usr `isMember` users) $ throw ConvNotFound ------------------------------------------------------------------------------- -- OtrRecipients Validation @@ -1587,7 +1719,15 @@ data CheckedOtrRecipients -- | bots are not supported on broadcast withValidOtrBroadcastRecipients :: forall r. - Members '[BrigAccess, ClientStore, TeamStore, WaiError] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error TeamError, + TeamStore + ] + r => UserId -> ClientId -> OtrRecipients -> @@ -1599,7 +1739,7 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ limit <- fromIntegral . fromRange <$> fanoutLimit -- If we are going to fan this out to more than limit, we want to fail early liftSem . unless (Map.size (userClientMap (otrRecipientsMap rcps)) <= limit) $ - throw broadcastLimitExceeded + 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. @@ -1624,17 +1764,25 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ let localUserIdsInRcps = Map.keys $ userClientMap (otrRecipientsMap rcps) let localUserIdsToLookup = Set.toList $ Set.union (Set.fromList localUserIdsInFilter) (Set.fromList localUserIdsInRcps) liftSem . unless (length localUserIdsToLookup <= limit) $ - throw broadcastLimitExceeded + throw BroadcastLimitExceeded liftSem $ E.selectTeamMembers tid localUserIdsToLookup maybeFetchAllMembersInTeam :: TeamId -> Galley r [TeamMember] maybeFetchAllMembersInTeam tid = do mems <- getTeamMembersForFanout tid liftSem . when (mems ^. teamMemberListType == ListTruncated) $ - throw broadcastLimitExceeded + throw BroadcastLimitExceeded pure (mems ^. teamMembers) withValidOtrRecipients :: - Members '[BrigAccess, ClientStore, ConversationStore, MemberStore, TeamStore, WaiError] r => + Members + '[ BrigAccess, + ClientStore, + ConversationStore, + Error LegalHoldError, + MemberStore, + TeamStore + ] + r => UserType -> UserId -> ClientId -> @@ -1662,7 +1810,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, WaiError] r => + Members '[BrigAccess, Error LegalHoldError, TeamStore] r => -- | Type of proposed sender (user / bot) UserType -> -- | Proposed sender (user) @@ -1686,7 +1834,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 (liftSem (throwErrorDescriptionType @MissingLegalholdConsent))) pure + >>= either (const (liftSem . throw $ MissingLegalholdConsent)) pure pure (OtrMissingRecipients m) InvalidOtrSenderUser -> pure $ OtrConversationNotFound mkErrorDescription InvalidOtrSenderClient -> pure $ OtrUnknownClient mkErrorDescription @@ -1774,10 +1922,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 :: Members '[TeamStore, WaiError] 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 -> liftSem $ throw nonBindingTeam + NonBinding -> liftSem $ throw NotABindingTeamMember diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 7e13162aff2..f13f643b9b9 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) -import qualified Control.Error import Control.Lens (set, view, (.~), (^.)) -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 @@ -69,7 +65,6 @@ import qualified Network.Wai.Utilities as Wai import Polysemy import Polysemy.Error import qualified Wire.API.Conversation as Public -import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley as FederatedGalley import Wire.API.Federation.Client @@ -147,17 +142,25 @@ ensureConnectedToRemotes u remotes = liftSem $ do when (length acceptedConns /= length remotes) $ throw NotConnected -ensureReAuthorised :: Members '[BrigAccess, WaiError] r => UserId -> Maybe PlainTextPassword -> Galley r () +ensureReAuthorised :: + Members + '[ BrigAccess, + Error AuthenticationError + ] + r => + UserId -> + Maybe PlainTextPassword -> + Galley r () ensureReAuthorised u secret = liftSem $ do reAuthed <- reauthUser u (ReAuthUser secret) unless reAuthed $ - throw 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, Member (Error ActionError) r) => + (IsConvMember mem, Members '[Error ActionError, Error InvalidInput] r) => Action -> mem -> Galley r () @@ -178,7 +181,7 @@ ensureGroupConversation conv = do -- 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, Member (Error ActionError) r) => + (IsConvMember mem, Members '[Error InvalidInput, Error ActionError] r) => mem -> RoleName -> Galley r () @@ -194,7 +197,7 @@ ensureConvRoleNotElevated origMember targetRole = liftSem $ do -- member does not have the given permission, throw 'operationDenied'. -- Otherwise, return the team member. permissionCheck :: - (IsPerm perm, Show perm, Member WaiError r) => + (IsPerm perm, Show perm, Members '[Error ActionError, Error TeamError] r) => perm -> Maybe TeamMember -> Galley r TeamMember @@ -203,27 +206,34 @@ permissionCheck p = Just m -> do if m `hasPermission` p then pure m - else throwErrorDescription (operationDenied p) - Nothing -> throwErrorDescriptionType @NotATeamMember + else throw (OperationDenied (show p)) + Nothing -> throw NotATeamMember -assertTeamExists :: Members '[TeamStore, WaiError] r => TeamId -> Galley r () +assertTeamExists :: Members '[Error TeamError, TeamStore] r => TeamId -> Galley r () assertTeamExists tid = liftSem $ do teamExists <- isJust <$> getTeam tid if teamExists then pure () - else throw teamNotFound + else throw TeamNotFound -assertOnTeam :: Members '[TeamStore, WaiError] r => UserId -> TeamId -> Galley r () +assertOnTeam :: Members '[Error TeamError, TeamStore] r => UserId -> TeamId -> Galley r () assertOnTeam uid tid = liftSem $ getTeamMember tid uid >>= \case - Nothing -> throwErrorDescriptionType @NotATeamMember + Nothing -> throw 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, WaiError] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error TeamError, + TeamStore + ] + r => UserId -> ConvId -> Perm -> @@ -233,11 +243,19 @@ permissionCheckTeamConv zusr cnv perm = Just cnv' -> case Data.convTeam cnv' of Just tid -> void $ permissionCheck perm =<< liftSem (getTeamMember tid zusr) Nothing -> pure () - Nothing -> liftSem $ throwErrorDescriptionType @ConvNotFound + Nothing -> liftSem $ throw ConvNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: - Members '[ConversationStore, MemberStore, GundeckAccess, WaiError] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + MemberStore, + GundeckAccess + ] + r => UserId -> Data.Conversation -> Maybe ConnId -> @@ -254,10 +272,10 @@ acceptOne2One usr conv conn = do return $ conv {Data.convLocalMembers = mems <> toList mm} ConnectConv -> case mems of [_, _] | usr `isMember` mems -> liftSem promote - [_, _] -> liftSem $ throwErrorDescriptionType @ConvNotFound + [_, _] -> liftSem $ throw ConvNotFound _ -> do when (length mems > 2) $ - liftSem $ throw badConvState + liftSem . throw . BadConvState $ cid now <- liftIO getCurrentTime mm <- liftSem $ createMember lcid lusr let e = memberJoinEvent lusr (qUntagged lcid) now mm [] @@ -266,17 +284,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'} - _ -> liftSem . throw $ 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 = - Wai.mkError status500 "bad-state" $ - "Connect conversation with more than 2 members: " - <> LT.pack (show cid) memberJoinEvent :: Local UserId -> @@ -436,16 +450,13 @@ 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, Member WaiError r) => +getSelfMemberFromLocals :: + (Foldable t, Member (Error ConversationError) r) => UserId -> t LocalMember -> Galley r LocalMember -getSelfMemberFromLocalsLegacy usr lmems = - liftSem $ - 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). @@ -460,24 +471,21 @@ ensureOtherMember loc quid conv = Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv) <|> Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv) -getSelfMemberFromRemotesLegacy :: - (Foldable t, Member WaiError r) => +getSelfMemberFromRemotes :: + (Foldable t, Member (Error ConversationError) r) => Remote UserId -> t RemoteMember -> Galley r RemoteMember -getSelfMemberFromRemotesLegacy usr rmems = - liftSem - . eitherM throwErrorDescription pure - . runExceptT - $ getMember rmId (mkErrorDescription :: ConvNotFound) usr rmems +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 @@ -486,7 +494,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 @@ -495,8 +503,8 @@ getMember :: userId -> -- | A list of members to search t mem -> - ExceptT e m mem -getMember p ex u = hoistEither . Control.Error.note ex . find ((u ==) . p) + Sem r mem +getMember p ex u = note ex . find ((u ==) . p) getConversationAndCheckMembership :: Members '[ConversationStore, Error ConversationError] r => @@ -558,15 +566,16 @@ pushConversationEvent conn e users bots = do liftSem $ deliverAsync (toList bots `zip` repeat e) verifyReusableCode :: - Members '[CodeStore, WaiError] 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) $ - liftSem $ throw (errorDescriptionTypeToWai @CodeNotFound) + liftSem $ throw CodeNotFound return c ensureConversationAccess :: diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 2748d00b25f..5d512b05f92 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -44,17 +44,13 @@ module Galley.App ask, DeleteItem (..), toServantHandler, - WaiError, -- * Utilities - ifNothing, fromJsonBody, fromOptionalJsonBody, fromProtoBody, fanoutLimit, currentFanoutLimit, - throwErrorDescription, - throwErrorDescriptionType, -- * Temporary compatibility functions fireAndForget, @@ -88,7 +84,6 @@ import Data.Serialize.Get (runGetLazy) import Data.Text (unpack) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import GHC.TypeLits import Galley.API.Error import qualified Galley.Aws as Aws import Galley.Cassandra.Client @@ -131,13 +126,11 @@ import Polysemy.Internal (Append) import qualified Polysemy.Reader as P import qualified Polysemy.TinyLog as P import qualified Servant -import Servant.API.Status (KnownStatus (..)) import Ssl.Util import System.Logger.Class import qualified System.Logger.Extended as Logger import qualified UnliftIO.Exception as UnliftIO import Util.Options -import Wire.API.ErrorDescription import Wire.API.Federation.Client (HasFederatorConfig (..)) -- MTL-style effects derived from the old implementation of the Galley monad. @@ -148,8 +141,6 @@ type GalleyEffects = Append GalleyEffects1 GalleyEffects0 type Galley0 = Galley GalleyEffects0 -type WaiError = Error Wai.Error - newtype Galley r a = Galley {unGalley :: Members GalleyEffects0 r => Sem r a} instance Functor (Galley r) where @@ -285,41 +276,25 @@ evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders -fromJsonBody :: (Member WaiError r, FromJSON a) => JsonRequest a -> Galley r a -fromJsonBody r = exceptT (liftSem . throw @Wai.Error . 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 :: (Member WaiError r, FromJSON a) => OptionalJsonRequest a -> Galley r (Maybe a) -fromOptionalJsonBody r = exceptT (liftSem . throw @Wai.Error . 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 :: (Member WaiError r, 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 (liftSem . throw @Wai.Error . invalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) + either (liftSem . throw . InvalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) {-# INLINE fromProtoBody #-} -ifNothing :: Member WaiError r => Wai.Error -> Maybe a -> Galley r a -ifNothing e = maybe (liftSem (throw e)) return -{-# INLINE ifNothing #-} - -throwErrorDescription :: - (KnownStatus code, KnownSymbol lbl, Member WaiError r) => - ErrorDescription code lbl desc -> - Sem r a -throwErrorDescription = throw . errorDescriptionToWai - -throwErrorDescriptionType :: - forall e (code :: Nat) (lbl :: Symbol) (desc :: Symbol) r a. - ( KnownStatus code, - KnownSymbol lbl, - KnownSymbol desc, - Member WaiError r, - e ~ ErrorDescription code lbl desc - ) => - Sem r a -throwErrorDescriptionType = throwErrorDescription (mkErrorDescription :: e) - toServantHandler :: Env -> Galley GalleyEffects a -> Servant.Handler a toServantHandler env galley = do eith <- liftIO $ Control.Exception.try (evalGalley env galley) diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index 6daee51417d..affafacf2ee 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -66,14 +66,18 @@ import URI.ByteString (uriPath) -- api -- | Get /status from legal hold service; throw 'Wai.Error' if things go wrong. -checkLegalHoldServiceStatus :: Member WaiError r => 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 - liftSem $ throw legalHoldServiceBadResponse + liftSem $ throw LegalHoldServiceBadResponse where reqBuilder :: Http.Request -> Http.Request reqBuilder = @@ -83,7 +87,7 @@ checkLegalHoldServiceStatus fpr url = do -- | @POST /initiate@. requestNewDevice :: - Members '[LegalHoldStore, WaiError] r => + Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> UserId -> Galley r NewLegalHoldClient @@ -92,7 +96,7 @@ requestNewDevice tid uid = do case eitherDecode (responseBody resp) of Left e -> do Log.info . Log.msg $ "Error decoding NewLegalHoldClient: " <> e - liftSem $ throw legalHoldServiceBadResponse + liftSem $ throw LegalHoldServiceBadResponse Right client -> pure client where reqParams = @@ -105,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 :: - Members '[LegalHoldStore, WaiError] r => + Members '[Error LegalHoldError, LegalHoldStore] r => ClientId -> TeamId -> UserId -> @@ -125,7 +129,7 @@ confirmLegalHold clientId tid uid legalHoldAuthToken = do -- | @POST /remove@ -- Inform the LegalHold Service that a user's legalhold has been disabled. removeLegalHold :: - Members '[LegalHoldStore, WaiError] r => + Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> UserId -> Galley r () @@ -146,14 +150,14 @@ removeLegalHold tid uid = do -- the TSL fingerprint via 'makeVerifiedRequest' and passes the token so the service can -- authenticate the request. makeLegalHoldServiceRequest :: - Members '[LegalHoldStore, WaiError] 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 -> liftSem $ throw 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 d1c7af1af55..b3aad0e32df 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -32,12 +32,12 @@ import Imports import Polysemy import Polysemy.Error -rangeChecked :: (Member (Error ActionError) r, Within a n m) => a -> Sem r (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 :: - (Member (Error ActionError) r, Within a n m) => + (Member (Error InvalidInput) r, Within a n m) => Maybe a -> Sem r (Maybe (Range n m a)) rangeCheckedMaybe Nothing = return Nothing @@ -49,7 +49,7 @@ newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} deriving (Functor, Foldable, Traversable) checkedConvSize :: - (Member (Error ActionError) r, Foldable f) => + (Member (Error InvalidInput) r, Foldable f) => Opts -> f a -> Sem r (ConvSizeChecked f a) @@ -60,5 +60,5 @@ checkedConvSize o x = do then return (ConvSizeChecked x) else throwErr (errorMsg minV limit "") -throwErr :: Member (Error ActionError) r => String -> Sem r a +throwErr :: Member (Error InvalidInput) r => String -> Sem r a throwErr = throw . InvalidRange . fromString From febd7f710dd51540d37a6e4c802d57a4705544c3 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 9 Nov 2021 07:04:56 +0100 Subject: [PATCH 07/10] Separate out NotATeamMember error --- services/galley/src/Galley/API/Action.hs | 9 +- services/galley/src/Galley/API/Create.hs | 6 ++ services/galley/src/Galley/API/Error.hs | 28 ++++-- services/galley/src/Galley/API/Internal.hs | 3 + services/galley/src/Galley/API/LegalHold.hs | 21 ++++- services/galley/src/Galley/API/Query.hs | 3 +- services/galley/src/Galley/API/Teams.hs | 85 ++++++++++++------- .../galley/src/Galley/API/Teams/Features.hs | 16 ++-- services/galley/src/Galley/API/Update.hs | 28 +++--- services/galley/src/Galley/API/Util.hs | 17 ++-- 10 files changed, 146 insertions(+), 70 deletions(-) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 1a082cc68fc..4f3e508b11e 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -68,6 +68,7 @@ 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 @@ -128,7 +129,7 @@ instance IsConversationAction ConversationJoin where Error FederationError, Error InvalidInput, Error LegalHoldError, - Error TeamError, + Error NotATeamMember, ExternalAccess, FederatorAccess, GundeckAccess, @@ -162,7 +163,7 @@ instance IsConversationAction ConversationJoin where '[ BrigAccess, Error ActionError, Error ConversationError, - Error TeamError, + Error NotATeamMember, TeamStore ] r => @@ -275,12 +276,12 @@ instance IsConversationAction ConversationMemberUpdate where instance IsConversationAction ConversationDelete where type HasConversationActionEffects ConversationDelete r = - Members '[Error FederationError, Error TeamError, CodeStore, TeamStore] 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) >>= note NotATeamMember + void $ E.getTeamMember tid (tUnqualified lusr) >>= noteED @NotATeamMember conversationActionTag' _ _ = DeleteConversation performAction _ lcnv conv action = lift . liftSem $ do key <- E.makeKey (tUnqualified lcnv) diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 56cda1806a4..f86aa170df0 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -58,6 +58,7 @@ import Polysemy import Polysemy.Error import Wire.API.Conversation hiding (Conversation, Member) import qualified Wire.API.Conversation as Public +import Wire.API.ErrorDescription import Wire.API.Event.Conversation hiding (Conversation) import Wire.API.Federation.Client import Wire.API.Routes.Public.Galley (ConversationResponse) @@ -79,6 +80,7 @@ createGroupConversation :: Error InternalError, Error InvalidInput, Error LegalHoldError, + Error NotATeamMember, Error TeamError, FederatorAccess, GundeckAccess, @@ -106,6 +108,7 @@ internalCreateManagedConversationH :: Error InternalError, Error InvalidInput, Error LegalHoldError, + Error NotATeamMember, Error TeamError, FederatorAccess, GundeckAccess, @@ -128,6 +131,7 @@ internalCreateManagedConversation :: Error InternalError, Error InvalidInput, Error LegalHoldError, + Error NotATeamMember, Error TeamError, FederatorAccess, GundeckAccess, @@ -210,6 +214,7 @@ createTeamGroupConv :: Error InternalError, Error InvalidInput, Error LegalHoldError, + Error NotATeamMember, Error TeamError, FederatorAccess, GundeckAccess, @@ -297,6 +302,7 @@ createOne2OneConversation :: Error FederationError, Error InternalError, Error InvalidInput, + Error NotATeamMember, Error TeamError, FederatorAccess, GundeckAccess, diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 05a1536bb1d..daab5fe29d1 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -135,8 +135,7 @@ instance APIError ConversationError where toWai NoManagedTeamConv = noManagedTeamConv data TeamError - = NotATeamMember - | NoBindingTeam + = NoBindingTeam | NoAddToBinding | NotABindingTeamMember | NotAOneMemberTeam @@ -148,7 +147,6 @@ data TeamError | CannotEnableLegalHoldServiceLargeTeam instance APIError TeamError where - toWai NotATeamMember = errorDescriptionTypeToWai @NotATeamMember toWai NoBindingTeam = noBindingTeam toWai NoAddToBinding = noAddToBinding toWai NotABindingTeamMember = nonBindingTeam @@ -221,6 +219,24 @@ 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, @@ -234,12 +250,14 @@ type AllErrorEffects = P.Error LegalHoldError, P.Error TeamError, P.Error TeamFeatureError, - P.Error TeamNotificationError + P.Error TeamNotificationError, + P.Error NotATeamMember ] mapAllErrors :: Member (P.Error Error) r => Sem (Append AllErrorEffects r) a -> Sem r a mapAllErrors = - P.mapError toWai + P.mapError errorDescriptionToWai + . P.mapError toWai . P.mapError toWai . P.mapError toWai . P.mapError toWai diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 72a08dc4058..3ca5ceaafb1 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -88,6 +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 import Wire.API.Federation.API.Galley (ConversationUpdate (..), UserDeletedConversationsNotification (UserDeletedConversationsNotification)) import qualified Wire.API.Federation.API.Galley as FedGalley import Wire.API.Federation.Client (FederationError) @@ -306,6 +307,7 @@ iGetTeamFeature :: ( Public.KnownTeamFeatureName a, Members '[ Error ActionError, + Error NotATeamMember, Error TeamError, TeamStore ] @@ -321,6 +323,7 @@ iPutTeamFeature :: ( Public.KnownTeamFeatureName a, Members '[ Error ActionError, + Error NotATeamMember, Error TeamError, TeamStore ] diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 5535f40f292..998ea8ed751 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -74,6 +74,7 @@ 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 @@ -81,7 +82,7 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotIm import qualified Wire.API.Team.LegalHold as Public assertLegalHoldEnabledForTeam :: - Members '[Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => + Members '[Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamFeatureStore] r => TeamId -> Galley r () assertLegalHoldEnabledForTeam tid = @@ -112,6 +113,7 @@ createSettingsH :: '[ Error ActionError, Error InvalidInput, Error LegalHoldError, + Error NotATeamMember, Error TeamError, LegalHoldStore, TeamFeatureStore, @@ -129,6 +131,7 @@ createSettings :: '[ Error ActionError, Error InvalidInput, Error LegalHoldError, + Error NotATeamMember, Error TeamError, LegalHoldStore, TeamFeatureStore, @@ -160,6 +163,7 @@ getSettingsH :: '[ Error ActionError, Error InvalidInput, Error TeamError, + Error NotATeamMember, LegalHoldStore, TeamFeatureStore, TeamStore @@ -175,6 +179,7 @@ getSettings :: '[ Error ActionError, Error InvalidInput, Error TeamError, + Error NotATeamMember, LegalHoldStore, TeamFeatureStore, TeamStore @@ -205,6 +210,7 @@ removeSettingsH :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -239,6 +245,7 @@ removeSettings :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -293,6 +300,7 @@ removeSettings' :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -381,6 +389,7 @@ grantConsentH :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -414,6 +423,7 @@ grantConsent :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -452,6 +462,7 @@ requestDeviceH :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -487,6 +498,7 @@ requestDevice :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -556,6 +568,7 @@ approveDeviceH :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -587,6 +600,7 @@ approveDevice :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -655,6 +669,7 @@ disableForUserH :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -691,6 +706,7 @@ disableForUser :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -745,6 +761,7 @@ changeLegalholdStatus :: Error ConversationError, Error FederationError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, @@ -798,7 +815,7 @@ changeLegalholdStatus tid uid old new = do -- FUTUREWORK: make this async? blockNonConsentingConnections :: forall r. - Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamStore] r => + Members '[BrigAccess, Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamStore] r => UserId -> Galley r () blockNonConsentingConnections uid = do diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index ee3bd5cb1ad..89b71ff3f41 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -71,6 +71,7 @@ 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 import Wire.API.Federation.API.Galley (gcresConvs) import qualified Wire.API.Federation.API.Galley as FederatedGalley import Wire.API.Federation.Client (FederationError (FederationUnexpectedBody), executeFederated) @@ -499,7 +500,7 @@ getConversationByReusableCode :: Error CodeError, Error ConversationError, Error FederationError, - Error TeamError, + Error NotATeamMember, TeamStore ] r => diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 4271345b07c..f73b5e2ebe2 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -124,6 +124,7 @@ 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 import Wire.API.Federation.Client import qualified Wire.API.Notification as Public import qualified Wire.API.Team as Public @@ -139,14 +140,14 @@ import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) getTeamH :: - Members '[Error TeamError, TeamStore] r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId ::: TeamId ::: JSON -> Galley r Response getTeamH (zusr ::: tid ::: _) = maybe (liftSem (throw TeamNotFound)) (pure . json) =<< lookupTeam zusr tid getTeamInternalH :: - Members '[Error TeamError, TeamStore] r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId ::: JSON -> Galley r Response getTeamInternalH (tid ::: _) = @@ -154,7 +155,7 @@ getTeamInternalH (tid ::: _) = E.getTeam tid >>= note TeamNotFound getTeamNameInternalH :: - Members '[Error TeamError, TeamStore] r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId ::: JSON -> Galley r Response getTeamNameInternalH (tid ::: _) = @@ -200,6 +201,7 @@ createNonBindingTeamH :: Error ActionError, Error InvalidInput, Error TeamError, + Error NotATeamMember, GundeckAccess, TeamStore ] @@ -216,6 +218,7 @@ createNonBindingTeam :: '[ BrigAccess, Error ActionError, Error TeamError, + Error NotATeamMember, GundeckAccess, TeamStore ] @@ -277,6 +280,7 @@ updateTeamStatusH :: Error ActionError, Error InvalidInput, Error TeamError, + Error NotATeamMember, TeamStore ] r => @@ -288,7 +292,7 @@ updateTeamStatusH (tid ::: req ::: _) = do return empty updateTeamStatus :: - Members '[BrigAccess, Error ActionError, Error TeamError, TeamStore] r => + Members '[BrigAccess, Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> TeamStatusUpdate -> Galley r () @@ -326,6 +330,7 @@ updateTeamH :: '[ Error ActionError, Error InvalidInput, Error TeamError, + Error NotATeamMember, GundeckAccess, TeamStore ] @@ -341,6 +346,7 @@ updateTeam :: Members '[ Error ActionError, Error TeamError, + Error NotATeamMember, GundeckAccess, TeamStore ] @@ -372,6 +378,7 @@ deleteTeamH :: Error InternalError, Error InvalidInput, Error TeamError, + Error NotATeamMember, TeamStore ] r => @@ -391,6 +398,7 @@ deleteTeam :: Error InternalError, Error InvalidInput, Error TeamError, + Error NotATeamMember, TeamStore ] r => @@ -417,7 +425,7 @@ deleteTeam zusr zcon tid mBody = do -- This can be called by stern internalDeleteBindingTeamWithOneMember :: - Members '[Error InternalError, Error TeamError, TeamStore] r => + Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> Galley r () internalDeleteBindingTeamWithOneMember tid = do @@ -516,18 +524,18 @@ uncheckedDeleteTeam zusr zcon tid = do pure (pp', ee' ++ ee) getTeamConversationRoles :: - Members '[Error TeamError, TeamStore] r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r Public.ConversationRolesList getTeamConversationRoles zusr tid = do - liftSem . void $ E.getTeamMember tid zusr >>= note NotATeamMember + 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 :: - Members '[Error TeamError, 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 @@ -535,13 +543,13 @@ getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do pure . json $ teamMemberListJson withPerms memberList getTeamMembers :: - Members '[Error TeamError, 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 = liftSem $ do - m <- E.getTeamMember tid zusr >>= note NotATeamMember + m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember mems <- E.getTeamMembersWithLimit tid maxResults let withPerms = (m `canSeePermsOf`) pure (mems, withPerms) @@ -668,6 +676,7 @@ bulkGetTeamMembersH :: '[ Error ActionError, Error InvalidInput, Error TeamError, + Error NotATeamMember, TeamStore ] r => @@ -680,7 +689,7 @@ bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do -- | like 'getTeamMembers', but with an explicit list of users we are to return. bulkGetTeamMembers :: - Members '[Error ActionError, Error InvalidInput, Error TeamError, TeamStore] r => + Members '[Error ActionError, Error InvalidInput, Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> @@ -689,14 +698,14 @@ bulkGetTeamMembers :: bulkGetTeamMembers zusr tid maxResults uids = liftSem $ do unless (length uids <= fromIntegral (fromRange maxResults)) $ throw BulkGetMemberLimitExceeded - m <- E.getTeamMember tid zusr >>= note NotATeamMember + m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember mems <- E.selectTeamMembers tid uids let withPerms = (m `canSeePermsOf`) hasMore = ListComplete pure (newTeamMemberList mems hasMore, withPerms) getTeamMemberH :: - Members '[Error TeamError, TeamStore] r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do @@ -704,7 +713,7 @@ getTeamMemberH (zusr ::: tid ::: uid ::: _) = do pure . json $ teamMemberJson withPerms member getTeamMember :: - Members '[Error TeamError, TeamStore] r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> UserId -> @@ -713,13 +722,13 @@ getTeamMember zusr tid uid = do m <- liftSem $ E.getTeamMember tid zusr - >>= note NotATeamMember + >>= noteED @NotATeamMember let withPerms = (m `canSeePermsOf`) member <- liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound pure (member, withPerms) internalDeleteBindingTeamWithOneMemberH :: - Members '[Error InternalError, Error TeamError, TeamStore] r => + Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> Galley r Response internalDeleteBindingTeamWithOneMemberH tid = do @@ -727,14 +736,14 @@ internalDeleteBindingTeamWithOneMemberH tid = do pure (empty & setStatus status202) uncheckedGetTeamMemberH :: - Members '[Error TeamError, TeamStore] r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId ::: UserId ::: JSON -> Galley r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid uncheckedGetTeamMember :: - Members '[Error TeamError, TeamStore] r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> UserId -> Galley r TeamMember @@ -763,6 +772,7 @@ addTeamMemberH :: Error LegalHoldError, Error InvalidInput, Error TeamError, + Error NotATeamMember, LegalHoldStore, MemberStore, TeamFeatureStore, @@ -784,6 +794,7 @@ addTeamMember :: Error ActionError, Error LegalHoldError, Error TeamError, + Error NotATeamMember, LegalHoldStore, MemberStore, TeamFeatureStore, @@ -822,6 +833,7 @@ uncheckedAddTeamMemberH :: Error LegalHoldError, Error InvalidInput, Error TeamError, + Error NotATeamMember, GundeckAccess, LegalHoldStore, MemberStore, @@ -843,6 +855,7 @@ uncheckedAddTeamMember :: GundeckAccess, Error LegalHoldError, Error TeamError, + Error NotATeamMember, MemberStore, LegalHoldStore, TeamFeatureStore, @@ -867,6 +880,7 @@ updateTeamMemberH :: Error ActionError, Error InvalidInput, Error TeamError, + Error NotATeamMember, GundeckAccess, TeamStore ] @@ -885,6 +899,7 @@ updateTeamMember :: '[ BrigAccess, Error ActionError, Error TeamError, + Error NotATeamMember, GundeckAccess, TeamStore ] @@ -961,6 +976,7 @@ deleteTeamMemberH :: Error AuthenticationError, Error InvalidInput, Error TeamError, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -988,6 +1004,7 @@ deleteTeamMember :: Error AuthenticationError, Error InvalidInput, Error TeamError, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -1094,14 +1111,14 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do liftSem $ E.deliverAsync (bots `zip` repeat y) getTeamConversations :: - Members '[Error ActionError, Error TeamError, TeamStore] r => + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r Public.TeamConversationList getTeamConversations zusr tid = liftSem $ do tm <- E.getTeamMember tid zusr - >>= note NotATeamMember + >>= noteED @NotATeamMember unless (tm `hasPermission` GetTeamConversations) $ throw . OperationDenied . show $ GetTeamConversations Public.newTeamConversationList <$> E.getTeamConversations tid @@ -1111,6 +1128,7 @@ getTeamConversation :: '[ Error ActionError, Error ConversationError, Error TeamError, + Error NotATeamMember, TeamStore ] r => @@ -1121,7 +1139,7 @@ getTeamConversation :: getTeamConversation zusr tid cid = liftSem $ do tm <- E.getTeamMember tid zusr - >>= note NotATeamMember + >>= noteED @NotATeamMember unless (tm `hasPermission` GetTeamConversations) $ throw . OperationDenied . show $ GetTeamConversations E.getTeamConversation tid cid @@ -1138,6 +1156,7 @@ deleteTeamConversation :: Error FederationError, Error InvalidInput, Error TeamError, + Error NotATeamMember, ExternalAccess, FederatorAccess, FireAndForget, @@ -1161,6 +1180,7 @@ getSearchVisibilityH :: Members '[ Error ActionError, Error TeamError, + Error NotATeamMember, SearchVisibilityStore, TeamStore ] @@ -1177,6 +1197,7 @@ setSearchVisibilityH :: '[ Error ActionError, Error InvalidInput, Error TeamError, + Error NotATeamMember, SearchVisibilityStore, TeamStore, TeamFeatureStore @@ -1223,7 +1244,7 @@ withTeamIds usr range size k = case range of k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: Members '[Error TeamError, 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. @@ -1232,7 +1253,7 @@ ensureUnboundUsers uids = do liftSem . when (any (== Binding) binds) $ throw UserBindingExists -ensureNonBindingTeam :: Members '[Error TeamError, TeamStore] r => TeamId -> Galley r () +ensureNonBindingTeam :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> Galley r () ensureNonBindingTeam tid = do team <- liftSem $ note TeamNotFound =<< E.getTeam tid liftSem . when ((tdTeam team) ^. teamBinding == Binding) $ @@ -1300,6 +1321,7 @@ addTeamMemberInternal :: Members '[ BrigAccess, Error TeamError, + Error NotATeamMember, GundeckAccess, MemberStore, TeamNotificationStore, @@ -1346,6 +1368,7 @@ getTeamNotificationsH :: Members '[ BrigAccess, Error TeamError, + Error NotATeamMember, Error TeamNotificationError, TeamNotificationStore ] @@ -1392,7 +1415,7 @@ finishCreateTeam team owner others zcon = do -- FUTUREWORK: Get rid of CPS withBindingTeam :: - Members '[Error TeamError, TeamStore] r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> (TeamId -> Galley r b) -> Galley r b @@ -1403,18 +1426,19 @@ withBindingTeam zusr callback = do Binding -> callback tid NonBinding -> liftSem $ throw NotABindingTeamMember -getBindingTeamIdH :: Members '[Error TeamError, TeamStore] r => UserId -> Galley r Response +getBindingTeamIdH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: Members '[Error TeamError, TeamStore] r => UserId -> Galley r TeamId +getBindingTeamId :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: Members '[Error TeamError, TeamStore] r => UserId -> Galley r Response +getBindingTeamMembersH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers getBindingTeamMembers :: Members '[ Error TeamError, + Error NotATeamMember, TeamStore ] r => @@ -1482,6 +1506,7 @@ setSearchVisibilityInternalH :: Members '[ Error InvalidInput, Error TeamError, + Error NotATeamMember, SearchVisibilityStore, TeamFeatureStore ] @@ -1493,7 +1518,7 @@ setSearchVisibilityInternalH (tid ::: req ::: _) = do pure noContent setSearchVisibilityInternal :: - Members '[Error TeamError, SearchVisibilityStore, TeamFeatureStore] r => + Members '[Error TeamError, Error NotATeamMember, SearchVisibilityStore, TeamFeatureStore] r => TeamId -> TeamSearchVisibilityView -> Galley r () @@ -1504,7 +1529,7 @@ setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do liftSem $ SearchVisibilityData.setSearchVisibility tid searchVisibility userIsTeamOwnerH :: - Members '[Error ActionError, Error TeamError, TeamStore] r => + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => TeamId ::: UserId ::: JSON -> Galley r Response userIsTeamOwnerH (tid ::: uid ::: _) = do @@ -1513,7 +1538,7 @@ userIsTeamOwnerH (tid ::: uid ::: _) = do False -> liftSem $ throw AccessDenied userIsTeamOwner :: - Members '[Error TeamError, TeamStore] r => + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> UserId -> Galley r Bool diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 3f1f8c2720a..4498865cf33 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -78,13 +78,8 @@ 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 @@ -101,6 +96,7 @@ getFeatureStatus :: Members '[ Error ActionError, Error TeamError, + Error NotATeamMember, TeamStore ] r @@ -125,6 +121,7 @@ setFeatureStatus :: Members '[ Error ActionError, Error TeamError, + Error NotATeamMember, TeamStore ] r @@ -150,6 +147,7 @@ getFeatureConfig :: Members '[ Error ActionError, Error TeamError, + Error NotATeamMember, TeamStore ] r @@ -171,6 +169,7 @@ getAllFeatureConfigs :: Members '[ Error ActionError, Error InternalError, + Error NotATeamMember, Error TeamError, LegalHoldStore, TeamFeatureStore, @@ -186,7 +185,7 @@ getAllFeatureConfigs zusr = do forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a), - Members '[Error ActionError, Error TeamError, TeamStore] r + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> Galley r (Text, Aeson.Value) @@ -216,6 +215,7 @@ getAllFeaturesH :: '[ Error ActionError, Error InternalError, Error TeamError, + Error NotATeamMember, LegalHoldStore, TeamFeatureStore, TeamStore @@ -232,6 +232,7 @@ getAllFeatures :: '[ Error ActionError, Error InternalError, Error TeamError, + Error NotATeamMember, LegalHoldStore, TeamFeatureStore, TeamStore @@ -417,6 +418,7 @@ setLegalholdStatusInternal :: Error InvalidInput, Error LegalHoldError, Error TeamError, + Error NotATeamMember, Error TeamFeatureError, ExternalAccess, FederatorAccess, diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index cdc4789c215..7e67b316029 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -121,9 +121,6 @@ import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Code as Public import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.ErrorDescription - ( 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 @@ -490,7 +487,7 @@ deleteLocalConversation :: Error ConversationError, Error FederationError, Error InvalidInput, - Error TeamError, + Error NotATeamMember, ExternalAccess, FederatorAccess, GundeckAccess, @@ -678,7 +675,7 @@ joinConversationByReusableCodeH :: Error ConversationError, Error FederationError, Error InvalidInput, - Error TeamError, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -701,7 +698,7 @@ joinConversationByReusableCode :: Error ConversationError, Error FederationError, Error InvalidInput, - Error TeamError, + Error NotATeamMember, FederatorAccess, ExternalAccess, GundeckAccess, @@ -726,7 +723,7 @@ joinConversationByIdH :: Error ConversationError, Error FederationError, Error InvalidInput, - Error TeamError, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -747,7 +744,7 @@ joinConversationById :: Error ConversationError, Error FederationError, Error InvalidInput, - Error TeamError, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -770,7 +767,7 @@ joinConversation :: Error ConversationError, Error FederationError, Error InvalidInput, - Error TeamError, + Error NotATeamMember, ExternalAccess, GundeckAccess, MemberStore, @@ -813,7 +810,7 @@ addMembersUnqualified :: Error FederationError, Error InvalidInput, Error LegalHoldError, - Error TeamError, + Error NotATeamMember, ExternalAccess, FederatorAccess, GundeckAccess, @@ -840,7 +837,7 @@ addMembers :: Error FederationError, Error InvalidInput, Error LegalHoldError, - Error TeamError, + Error NotATeamMember, ExternalAccess, FederatorAccess, GundeckAccess, @@ -1112,8 +1109,8 @@ removeMemberFromLocalConv lcnv lusr con victim = data OtrResult = OtrSent !Public.ClientMismatch | OtrMissingRecipients !Public.ClientMismatch - | OtrUnknownClient !Public.UnknownClient - | OtrConversationNotFound !Public.ConvNotFound + | OtrUnknownClient !UnknownClient + | OtrConversationNotFound !ConvNotFound handleOtrResult :: Members @@ -1256,6 +1253,7 @@ postProtoOtrBroadcastH :: Error ConversationError, Error LegalHoldError, Error InvalidInput, + Error NotATeamMember, Error TeamError, GundeckAccess, TeamStore @@ -1277,6 +1275,7 @@ postOtrBroadcastH :: Error ConversationError, Error LegalHoldError, Error InvalidInput, + Error NotATeamMember, Error TeamError, GundeckAccess, TeamStore @@ -1295,6 +1294,7 @@ postOtrBroadcast :: ClientStore, Error ActionError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, GundeckAccess, TeamStore @@ -1324,6 +1324,7 @@ postNewOtrBroadcast :: ClientStore, Error ActionError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, GundeckAccess, TeamStore @@ -1724,6 +1725,7 @@ withValidOtrBroadcastRecipients :: ClientStore, Error ActionError, Error LegalHoldError, + Error NotATeamMember, Error TeamError, TeamStore ] diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index f13f643b9b9..f76e4ff748b 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -65,13 +65,14 @@ import qualified Network.Wai.Utilities as Wai import Polysemy import Polysemy.Error import qualified Wire.API.Conversation as Public +import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley as FederatedGalley import Wire.API.Federation.Client type JSON = Media "application" "json" ensureAccessRole :: - Members '[BrigAccess, Error TeamError, Error ConversationError] r => + Members '[BrigAccess, Error NotATeamMember, Error ConversationError] r => AccessRole -> [(UserId, Maybe TeamMember)] -> Galley r () @@ -79,7 +80,7 @@ ensureAccessRole role users = liftSem $ case role of PrivateAccessRole -> throw ConvAccessDenied TeamAccessRole -> when (any (isNothing . snd) users) $ - throw NotATeamMember + throwED @NotATeamMember ActivatedAccessRole -> do activated <- lookupActivatedUsers $ map fst users when (length activated /= length users) $ @@ -197,7 +198,7 @@ ensureConvRoleNotElevated origMember targetRole = liftSem $ do -- member does not have the given permission, throw 'operationDenied'. -- Otherwise, return the team member. permissionCheck :: - (IsPerm perm, Show perm, Members '[Error ActionError, Error TeamError] r) => + (IsPerm perm, Show perm, Members '[Error ActionError, Error NotATeamMember] r) => perm -> Maybe TeamMember -> Galley r TeamMember @@ -207,7 +208,7 @@ permissionCheck p = if m `hasPermission` p then pure m else throw (OperationDenied (show p)) - Nothing -> throw NotATeamMember + Nothing -> throwED @NotATeamMember assertTeamExists :: Members '[Error TeamError, TeamStore] r => TeamId -> Galley r () assertTeamExists tid = liftSem $ do @@ -216,11 +217,11 @@ assertTeamExists tid = liftSem $ do then pure () else throw TeamNotFound -assertOnTeam :: Members '[Error TeamError, TeamStore] r => UserId -> TeamId -> Galley r () +assertOnTeam :: Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r () assertOnTeam uid tid = liftSem $ getTeamMember tid uid >>= \case - Nothing -> throw NotATeamMember + Nothing -> throwED @NotATeamMember Just _ -> return () -- | If the conversation is in a team, throw iff zusr is a team member and does not have named @@ -230,7 +231,7 @@ permissionCheckTeamConv :: '[ ConversationStore, Error ActionError, Error ConversationError, - Error TeamError, + Error NotATeamMember, TeamStore ] r => @@ -585,7 +586,7 @@ ensureConversationAccess :: Error ActionError, Error ConversationError, Error FederationError, - Error TeamError, + Error NotATeamMember, TeamStore ] r => From 66e821a5b492c9f2eff850b6a024d4fa39d2badd Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 9 Nov 2021 07:51:21 +0100 Subject: [PATCH 08/10] Add CHANGELOG entry --- changelog.d/5-internal/polysemy-errors | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/polysemy-errors 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. From ee24dc86610776b6e0f471b1dafcb0558179ec20 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 9 Nov 2021 23:08:42 +0100 Subject: [PATCH 09/10] Remove an unnecessary ActionError data constructor --- services/galley/src/Galley/API/Create.hs | 2 +- services/galley/src/Galley/API/Error.hs | 2 -- services/galley/src/Galley/API/Update.hs | 3 +-- 3 files changed, 2 insertions(+), 5 deletions(-) diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index f86aa170df0..8c4b698bf38 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -318,7 +318,7 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do let allUsers = newConvMembers lusr j other <- liftSem $ ensureOne (ulAll lusr allUsers) liftSem . when (qUntagged lusr == other) $ - throw (InvalidOpGeneral "Cannot create a 1-1 with yourself") + throw . InvalidOp $ One2OneConv mtid <- case newConvTeam j of Just ti | cnvManaged ti -> liftSem $ throw NoManagedTeamConv diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index daab5fe29d1..ab555dcff61 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -67,7 +67,6 @@ data ActionError | ActionDenied Action | AccessDenied | InvalidOp ConvType - | InvalidOpGeneral LText | OperationDenied String | NotConnected | NoAddToManaged @@ -84,7 +83,6 @@ instance APIError ActionError where toWai (InvalidOp SelfConv) = invalidSelfOp toWai (InvalidOp One2OneConv) = invalidOne2OneOp toWai (InvalidOp ConnectConv) = invalidConnectOp - toWai (InvalidOpGeneral t) = invalidOp t toWai (OperationDenied p) = errorDescriptionToWai $ operationDeniedSpecialized p toWai NotConnected = errorDescriptionTypeToWai @NotConnected toWai InvalidTargetUserOp = invalidTargetUserOp diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 7e67b316029..98344a35462 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -192,8 +192,7 @@ blockConv :: blockConv zusr cnv = do conv <- liftSem $ E.getConversation cnv >>= note ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - liftSem . throw $ - InvalidOpGeneral "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] []) From b9162d7f0c313d3a74af5efe5c545a5d5d3d7f4f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 9 Nov 2021 23:11:14 +0100 Subject: [PATCH 10/10] Update services/galley/src/Galley/API/Query.hs Remove a commented out function signature --- services/galley/src/Galley/API/Query.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 89b71ff3f41..e8983fc1ff3 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -156,7 +156,6 @@ data FailedGetConversationReason = FailedGetConversationLocally | FailedGetConversationRemotely FederationError --- fgcrError :: FailedGetConversationReason -> Wai.Error throwFgcrError :: Members '[Error ConversationError, Error FederationError] r => FailedGetConversationReason -> Sem r a throwFgcrError FailedGetConversationLocally = throw ConvNotFound