diff --git a/changelog.d/5-internal/polysemy-monad b/changelog.d/5-internal/polysemy-monad new file mode 100644 index 00000000000..eb00757ba05 --- /dev/null +++ b/changelog.d/5-internal/polysemy-monad @@ -0,0 +1 @@ +Replace Galley monad with polysemy's Sem throughout Galley diff --git a/hack/bin/split-member-constraints.py b/hack/bin/split-member-constraints.py new file mode 100644 index 00000000000..28a54e688cc --- /dev/null +++ b/hack/bin/split-member-constraints.py @@ -0,0 +1,33 @@ +#!/usr/bin/env python3 + +# This script splits all polysemy `Members` constraints into multiple `Member` +# constraints. The intended usage is to find redundant effects in function +# signatures. +# +# Example usage: +# +# $ git status # make sure working directory is clean +# $ fd -ehs services/galley/src -x hack/bin/split-member-constraints.py '{}' '{}' +# $ WIRE_STACK_OPTIONS="$WIRE_STACK_OPTIONS --ghc-options='-Wredundant-constraints -Wwarn'" make +# $ git reset --hard +# +# Now you can scroll back to find a list of redundant constraint warnings and +# fix them, but note that the line numbers are no longer accurate. + +import re +import sys + +def make_constraint(e): + e = e.strip() + if ' ' in e: + e = '(' + e + ')' + return f'Member {e} r' + +def f(m): + effects = re.split(r'\s*,\s*', m.group(1)) + constraints = ', '.join(make_constraint(e) for e in effects) + return f'({constraints})' + +code = open(sys.argv[1]).read() +print(re.sub(r"Members\s+'\[\s*([^\]]*)\s*\]\s+r", f, code, flags=re.MULTILINE), + file=open(sys.argv[2], 'w'), end='') diff --git a/libs/wire-api/src/Wire/API/Routes/Public.hs b/libs/wire-api/src/Wire/API/Routes/Public.hs index f52a0cc0fe9..9fd26ba7fe5 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public.hs @@ -18,43 +18,105 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Routes.Public where +module Wire.API.Routes.Public + ( -- * nginz combinators + ZUser, + ZLocalUser, + ZConn, + ZOptUser, + ZOptConn, + + -- * Swagger combinators + OmitDocs, + ) +where import Control.Lens ((<>~)) +import Data.Domain import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Id as Id +import Data.Kind import Data.Metrics.Servant +import Data.Qualified import Data.Swagger import GHC.Base (Symbol) import GHC.TypeLits (KnownSymbol) import Imports hiding (All, head) import Servant hiding (Handler, JSON, addHeader, respond) -import Servant.API.Modifiers (FoldLenient, FoldRequired) +import Servant.API.Modifiers import Servant.Swagger (HasSwagger (toSwagger)) +mapRequestArgument :: + forall mods a b. + (SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) => + (a -> b) -> + RequestArgument mods a -> + RequestArgument mods b +mapRequestArgument f x = + case (sbool :: SBool (FoldRequired mods), sbool :: SBool (FoldLenient mods)) of + (STrue, STrue) -> fmap f x + (STrue, SFalse) -> f x + (SFalse, STrue) -> (fmap . fmap) f x + (SFalse, SFalse) -> fmap f x + -- This type exists for the special 'HasSwagger' and 'HasServer' instances. It -- shows the "Authorization" header in the swagger docs, but expects the -- "Z-Auth" header in the server. This helps keep the swagger docs usable -- through nginz. -data ZUserType = ZAuthUser | ZAuthConn +data ZType + = -- | Get a 'UserID' from the Z-Auth header + ZAuthUser + | -- | Same as 'ZAuthUser', but return a 'Local UserId' using the domain in the context + ZLocalAuthUser + | -- | Get a 'ConnId' from the Z-Conn header + ZAuthConn + +class + (KnownSymbol (ZHeader ztype), FromHttpApiData (ZParam ztype)) => + IsZType (ztype :: ZType) + where + type ZHeader ztype :: Symbol + type ZParam ztype :: * + type ZQualifiedParam ztype :: * + type ZConstraint ztype (ctx :: [*]) :: Constraint + + qualifyZParam :: ZConstraint ztype ctx => Context ctx -> ZParam ztype -> ZQualifiedParam ztype + +instance IsZType 'ZLocalAuthUser where + type ZHeader 'ZLocalAuthUser = "Z-User" + type ZParam 'ZLocalAuthUser = UserId + type ZQualifiedParam 'ZLocalAuthUser = Local UserId + type ZConstraint 'ZLocalAuthUser ctx = HasContextEntry ctx Domain + + qualifyZParam ctx = toLocalUnsafe (getContextEntry ctx) + +instance IsZType 'ZAuthUser where + type ZHeader 'ZAuthUser = "Z-User" + type ZParam 'ZAuthUser = UserId + type ZQualifiedParam 'ZAuthUser = UserId + type ZConstraint 'ZAuthUser ctx = () -type family ZUserHeader (ztype :: ZUserType) :: Symbol where - ZUserHeader 'ZAuthUser = "Z-User" - ZUserHeader 'ZAuthConn = "Z-Connection" + qualifyZParam _ = id -type family ZUserParam (ztype :: ZUserType) :: * where - ZUserParam 'ZAuthUser = UserId - ZUserParam 'ZAuthConn = ConnId +instance IsZType 'ZAuthConn where + type ZHeader 'ZAuthConn = "Z-Connection" + type ZParam 'ZAuthConn = ConnId + type ZQualifiedParam 'ZAuthConn = ConnId + type ZConstraint 'ZAuthConn ctx = () -data ZAuthServant (ztype :: ZUserType) (opts :: [*]) + qualifyZParam _ = id + +data ZAuthServant (ztype :: ZType) (opts :: [*]) type InternalAuthDefOpts = '[Servant.Required, Servant.Strict] type InternalAuth ztype opts = Header' opts - (ZUserHeader ztype) - (ZUserParam ztype) + (ZHeader ztype) + (ZParam ztype) + +type ZLocalUser = ZAuthServant 'ZLocalAuthUser InternalAuthDefOpts type ZUser = ZAuthServant 'ZAuthUser InternalAuthDefOpts @@ -76,24 +138,33 @@ instance HasSwagger api => HasSwagger (ZAuthServant 'ZAuthUser _opts :> api) whe _securitySchemeDescription = Just "Must be a token retrieved by calling 'POST /login' or 'POST /access'. It must be presented in this format: 'Bearer \\'." } +instance HasSwagger api => HasSwagger (ZAuthServant 'ZLocalAuthUser opts :> api) where + toSwagger _ = toSwagger (Proxy @(ZAuthServant 'ZAuthUser opts :> api)) + instance HasSwagger api => HasSwagger (ZAuthServant 'ZAuthConn _opts :> api) where toSwagger _ = toSwagger (Proxy @api) instance - ( HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters, + ( IsZType ztype, + HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters, + ZConstraint ztype ctx, SBoolI (FoldLenient opts), SBoolI (FoldRequired opts), - HasServer api ctx, - KnownSymbol (ZUserHeader ztype), - FromHttpApiData (ZUserParam ztype) + HasServer api ctx ) => HasServer (ZAuthServant ztype opts :> api) ctx where - type ServerT (ZAuthServant ztype opts :> api) m = ServerT (InternalAuth ztype opts :> api) m + type + ServerT (ZAuthServant ztype opts :> api) m = + RequestArgument opts (ZQualifiedParam ztype) -> ServerT api m - route _ = Servant.route (Proxy @(InternalAuth ztype opts :> api)) - hoistServerWithContext _ pc nt s = - Servant.hoistServerWithContext (Proxy @(InternalAuth ztype opts :> api)) pc nt s + route _ ctx subserver = + Servant.route + (Proxy @(InternalAuth ztype opts :> api)) + ctx + (fmap (. mapRequestArgument @opts (qualifyZParam @ztype ctx)) subserver) + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s instance RoutesToPaths api => RoutesToPaths (ZAuthServant ztype opts :> api) where getRoutes = getRoutes @api diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 136c82de3a9..20e2e00db2b 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -38,7 +38,7 @@ import Wire.API.ErrorDescription import Wire.API.Event.Conversation import Wire.API.Message import Wire.API.Routes.MultiVerb -import Wire.API.Routes.Public (ZConn, ZUser) +import Wire.API.Routes.Public import Wire.API.Routes.Public.Galley.Responses import Wire.API.Routes.Public.Util import Wire.API.Routes.QualifiedCapture @@ -78,21 +78,21 @@ data Api routes = Api getUnqualifiedConversation :: routes :- Summary "Get a conversation by ID" - :> ZUser + :> ZLocalUser :> "conversations" :> Capture "cnv" ConvId :> Get '[Servant.JSON] Conversation, getConversation :: routes :- Summary "Get a conversation by ID" - :> ZUser + :> ZLocalUser :> "conversations" :> QualifiedCapture "cnv" ConvId :> Get '[Servant.JSON] Conversation, getConversationRoles :: routes :- Summary "Get existing roles available for the given conversation" - :> ZUser + :> ZLocalUser :> "conversations" :> Capture "cnv" ConvId :> "roles" @@ -101,7 +101,7 @@ data Api routes = Api routes :- Summary "[deprecated] Get all local conversation IDs." -- FUTUREWORK: add bounds to swagger schema for Range - :> ZUser + :> ZLocalUser :> "conversations" :> "ids" :> QueryParam' @@ -133,7 +133,7 @@ data Api routes = Api \ `has_more` being `false`. Note that `paging_state` should be\ \ considered an opaque token. It should not be inspected, or stored, or\ \ reused across multiple unrelated invokations of the endpoint." - :> ZUser + :> ZLocalUser :> "conversations" :> "list-ids" :> ReqBody '[Servant.JSON] GetPaginatedConversationIds @@ -145,7 +145,7 @@ data Api routes = Api "Will not return remote conversations.\n\n\ \Use `POST /conversations/list-ids` followed by \ \`POST /conversations/list/v2` instead." - :> ZUser + :> ZLocalUser :> "conversations" :> QueryParam' [ Optional, @@ -172,7 +172,7 @@ data Api routes = Api listConversations :: routes :- Summary "Get conversation metadata for a list of conversation ids" - :> ZUser + :> ZLocalUser :> "conversations" :> "list" :> "v2" @@ -187,7 +187,7 @@ data Api routes = Api :> CanThrow CodeNotFound :> CanThrow ConvNotFound :> CanThrow ConvAccessDenied - :> ZUser + :> ZLocalUser :> "conversations" :> "join" :> QueryParam' [Required, Strict] "key" Code.Key @@ -200,7 +200,7 @@ data Api routes = Api :> CanThrow OperationDenied :> CanThrow NotATeamMember :> Description "This returns 201 when a new conversation is created, and 200 when the conversation already existed" - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> ReqBody '[Servant.JSON] NewConvUnmanaged @@ -208,7 +208,7 @@ data Api routes = Api createSelfConversation :: routes :- Summary "Create a self-conversation" - :> ZUser + :> ZLocalUser :> "conversations" :> "self" :> ConversationVerb, @@ -218,7 +218,7 @@ data Api routes = Api createOne2OneConversation :: routes :- Summary "Create a 1:1 conversation" - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> "one2one" @@ -233,7 +233,7 @@ data Api routes = Api :> CanThrow NotConnected :> CanThrow ConvAccessDenied :> CanThrow (InvalidOp "Invalid operation") - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture "cnv" ConvId @@ -243,7 +243,7 @@ data Api routes = Api addMembersToConversation :: routes :- Summary "Add qualified members to an existing conversation." - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture "cnv" ConvId @@ -256,7 +256,7 @@ data Api routes = Api removeMemberUnqualified :: routes :- Summary "Remove a member from a conversation (deprecated)" - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture' '[Description "Conversation ID"] "cnv" ConvId @@ -272,7 +272,7 @@ data Api routes = Api removeMember :: routes :- Summary "Remove a member from a conversation" - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId @@ -289,7 +289,7 @@ data Api routes = Api routes :- Summary "Update membership of the specified user (deprecated)" :> Description "Use `PUT /conversations/:cnv_domain/:cnv/members/:usr_domain/:usr` instead" - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvNotFound :> CanThrow ConvMemberNotFound @@ -308,7 +308,7 @@ data Api routes = Api routes :- Summary "Update membership of the specified user" :> Description "**Note**: at least one field has to be provided." - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvNotFound :> CanThrow ConvMemberNotFound @@ -329,7 +329,7 @@ data Api routes = Api routes :- Summary "Update conversation name (deprecated)" :> Description "Use `/conversations/:domain/:conv/name` instead." - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture' '[Description "Conversation ID"] "cnv" ConvId @@ -345,7 +345,7 @@ data Api routes = Api routes :- Summary "Update conversation name (deprecated)" :> Description "Use `/conversations/:domain/:conv/name` instead." - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture' '[Description "Conversation ID"] "cnv" ConvId @@ -361,7 +361,7 @@ data Api routes = Api updateConversationName :: routes :- Summary "Update conversation name" - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId @@ -380,7 +380,7 @@ data Api routes = Api routes :- Summary "Update the message timer for a conversation (deprecated)" :> Description "Use `/conversations/:domain/:cnv/message-timer` instead." - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -397,7 +397,7 @@ data Api routes = Api updateConversationMessageTimer :: routes :- Summary "Update the message timer for a conversation" - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -417,7 +417,7 @@ data Api routes = Api routes :- Summary "Update receipt mode for a conversation (deprecated)" :> Description "Use `PUT /conversations/:domain/:cnv/receipt-mode` instead." - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -433,7 +433,7 @@ data Api routes = Api updateConversationReceiptMode :: routes :- Summary "Update receipt mode for a conversation" - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -453,7 +453,7 @@ data Api routes = Api routes :- Summary "Update access modes for a conversation (deprecated)" :> Description "Use PUT `/conversations/:domain/:cnv/access` instead." - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -470,7 +470,7 @@ data Api routes = Api updateConversationAccess :: routes :- Summary "Update access modes for a conversation" - :> ZUser + :> ZLocalUser :> ZConn :> CanThrow ConvAccessDenied :> CanThrow ConvNotFound @@ -487,7 +487,7 @@ data Api routes = Api getConversationSelfUnqualified :: routes :- Summary "Get self membership properties (deprecated)" - :> ZUser + :> ZLocalUser :> "conversations" :> Capture' '[Description "Conversation ID"] "cnv" ConvId :> "self" @@ -497,7 +497,7 @@ data Api routes = Api :- Summary "Update self membership properties (deprecated)" :> Description "Use `/conversations/:domain/:conv/self` instead." :> CanThrow ConvNotFound - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture' '[Description "Conversation ID"] "cnv" ConvId @@ -513,7 +513,7 @@ data Api routes = Api :- Summary "Update self membership properties" :> Description "**Note**: at least one field has to be provided." :> CanThrow ConvNotFound - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> QualifiedCapture' '[Description "Conversation ID"] "cnv" ConvId @@ -560,7 +560,7 @@ data Api routes = Api :- Summary "Remove a team conversation" :> CanThrow NotATeamMember :> CanThrow ActionDenied - :> ZUser + :> ZLocalUser :> ZConn :> "teams" :> Capture "tid" TeamId @@ -571,7 +571,7 @@ data Api routes = Api routes :- Summary "Post an encrypted message to a conversation (accepts JSON or Protobuf)" :> Description PostOtrDescriptionUnqualified - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> Capture "cnv" ConvId @@ -589,7 +589,7 @@ data Api routes = Api routes :- Summary "Post an encrypted message to a conversation (accepts only Protobuf)" :> Description PostOtrDescription - :> ZUser + :> ZLocalUser :> ZConn :> "conversations" :> QualifiedCapture "cnv" ConvId diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 7eeb2c3d6b9..b1f68193ca3 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: 6f378c75d7938aa5f221f136049c8ca98f63e7ae682e0035fb912f3917cfd1b1 +-- hash: 955ba4e571c8a43aab5b78d001425cbc40f17e59b95bfabb8ab5d42bae6500b5 name: galley version: 0.83.0 @@ -87,6 +87,7 @@ library Galley.Effects.ListItems Galley.Effects.MemberStore Galley.Effects.Paging + Galley.Effects.Queue Galley.Effects.RemoteConversationListStore Galley.Effects.SearchVisibilityStore Galley.Effects.ServiceStore @@ -95,9 +96,12 @@ library Galley.Effects.TeamMemberStore Galley.Effects.TeamNotificationStore Galley.Effects.TeamStore + Galley.Effects.WaiRoutes + Galley.Effects.WaiRoutes.IO Galley.Env Galley.External Galley.External.LegalHoldService + Galley.External.LegalHoldService.Internal Galley.External.LegalHoldService.Types Galley.Intra.Client Galley.Intra.Effects @@ -110,6 +114,7 @@ library Galley.Intra.Team Galley.Intra.User Galley.Intra.Util + Galley.Monad Galley.Options Galley.Queue Galley.Run @@ -123,7 +128,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -fplugin=Polysemy.Plugin + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path build-depends: HsOpenSSL >=0.11 , HsOpenSSL-x509-system >=0.1 @@ -169,7 +174,6 @@ library , optparse-applicative >=0.10 , pem , polysemy - , polysemy-plugin , polysemy-wire-zoo , proto-lens >=0.2 , protobuf >=0.2 diff --git a/services/galley/package.yaml b/services/galley/package.yaml index c7c5a15ff8c..c97f956613d 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -26,7 +26,6 @@ dependencies: library: source-dirs: src - ghc-options: -fplugin=Polysemy.Plugin dependencies: - aeson >=0.11 - amazonka >=1.4.5 @@ -67,7 +66,6 @@ library: - optparse-applicative >=0.10 - pem - polysemy - - polysemy-plugin - polysemy-wire-zoo - protobuf >=0.2 - proto-lens >=0.2 diff --git a/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index 122c06859f1..1ae9c9a234d 100644 --- a/services/galley/src/Galley/API.hs +++ b/services/galley/src/Galley/API.hs @@ -24,10 +24,11 @@ where import qualified Data.Swagger.Build.Api as Doc import qualified Galley.API.Internal as Internal import qualified Galley.API.Public as Public -import Galley.App (Galley, GalleyEffects) +import Galley.App (GalleyEffects) import Network.Wai.Routing (Routes) +import Polysemy -sitemap :: Routes Doc.ApiBuilder (Galley GalleyEffects) () +sitemap :: Routes Doc.ApiBuilder (Sem GalleyEffects) () sitemap = do Public.sitemap Public.apiDocs diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 4f3e508b11e..957ccea7821 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -27,6 +27,7 @@ module Galley.API.Action -- * Performing actions updateLocalConversation, + NoChanges, -- * Utilities ensureConversationActionAllowed, @@ -37,7 +38,6 @@ 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) @@ -47,7 +47,6 @@ 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 @@ -57,14 +56,17 @@ 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.FireAndForget as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.TeamStore as E +import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.UserList import Galley.Validation import Imports import Polysemy import Polysemy.Error +import Polysemy.Input import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.Conversation.Action import Wire.API.Conversation.Role @@ -75,6 +77,11 @@ import Wire.API.Federation.Client import Wire.API.Team.LegalHold import Wire.API.Team.Member +data NoChanges = NoChanges + +noChanges :: Member (Error NoChanges) r => Sem r a +noChanges = throw NoChanges + -- | 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 @@ -87,18 +94,18 @@ class IsConversationAction a where a -> Conversation -> mem -> - Galley r () + Sem r () ensureAllowed _ _ _ _ = pure () conversationActionTag' :: Qualified UserId -> a -> Action performAction :: ( HasConversationActionEffects a r, - Members '[ConversationStore] r + Members '[ConversationStore, Error NoChanges] r ) => Qualified UserId -> Local ConvId -> Conversation -> a -> - MaybeT (Galley r) (BotsAndMembers, a) + Sem r (BotsAndMembers, a) -- | The action of some users joining a conversation. data ConversationJoin = ConversationJoin @@ -133,6 +140,8 @@ instance IsConversationAction ConversationJoin where ExternalAccess, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, TeamStore @@ -145,14 +154,13 @@ instance IsConversationAction ConversationJoin where 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)) + lusr <- ensureLocal lcnv qusr + ensureMemberLimit (toList (convLocalMembers conv)) newMembers + 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 @@ -170,9 +178,9 @@ instance IsConversationAction ConversationJoin where Local UserId -> Maybe TeamId -> [UserId] -> - Galley r () + Sem r () checkLocals lusr (Just tid) newUsers = do - tms <- liftSem $ E.selectTeamMembers tid newUsers + tms <- E.selectTeamMembers tid newUsers let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers ensureAccessRole (convAccessRole conv) userMembershipMap ensureConnectedOrSameTeam lusr newUsers @@ -181,16 +189,21 @@ instance IsConversationAction ConversationJoin where ensureConnectedOrSameTeam lusr newUsers checkRemotes :: - Members '[BrigAccess, Error ActionError, Error FederationError, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error FederationError, + FederatorAccess + ] + r => Local UserId -> [Remote UserId] -> - Galley r () + Sem 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) $ + unless (null remotes) $ + unlessM E.isFederationConfigured $ throw FederationNotConfigured ensureConnectedToRemotes lusr remotes @@ -204,13 +217,15 @@ instance IsConversationAction ConversationJoin where ExternalAccess, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, TeamStore ] r => [UserId] -> - Galley r () + Sem r () checkLHPolicyConflictsLocal newUsers = do let convUsers = convLocalMembers conv @@ -218,11 +233,11 @@ instance IsConversationAction ConversationJoin where whenM (anyLegalholdActivated (lmId <$> convUsers)) $ unless allNewUsersGaveConsent $ - liftSem $ throw MissingLegalholdConsent + throw MissingLegalholdConsent whenM (anyLegalholdActivated newUsers) $ do unless allNewUsersGaveConsent $ - liftSem $ throw MissingLegalholdConsent + throw MissingLegalholdConsent convUsersLHStatus <- do uidsStatus <- getLHStatusForUsers (lmId <$> convUsers) @@ -237,15 +252,15 @@ instance IsConversationAction ConversationJoin where then do for_ convUsersLHStatus $ \(mem, status) -> when (consentGiven status == ConsentNotGiven) $ do - qvictim <- qUntagged <$> qualifyLocal (lmId mem) - void . runMaybeT $ + let qvictim = qUntagged (qualifyAs lcnv (lmId mem)) + void . runError @NoChanges $ updateLocalConversation lcnv qvictim Nothing $ ConversationLeave (pure qvictim) - else liftSem $ throw MissingLegalholdConsent + else throw MissingLegalholdConsent checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> - Galley r () + Sem r () checkLHPolicyConflictsRemote _remotes = pure () instance IsConversationAction ConversationLeave where @@ -258,8 +273,8 @@ instance IsConversationAction ConversationLeave where | 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) + when (null presentVictims) noChanges + E.deleteMembers (convId conv) (toUserList lcnv presentVictims) pure (mempty, action) -- FUTUREWORK: should we return the filtered action here? instance IsConversationAction ConversationMemberUpdate where @@ -268,7 +283,7 @@ instance IsConversationAction ConversationMemberUpdate where (Members '[MemberStore, Error ConversationError] r) conversationAction cmu = ConversationActionMemberUpdate (cmuTarget cmu) (cmuUpdate cmu) conversationActionTag' _ _ = ModifyOtherConversationMember - performAction _qusr lcnv conv action = lift . liftSem $ do + performAction _qusr lcnv conv action = do void $ ensureOtherMember lcnv (cmuTarget action) conv E.setOtherMember lcnv (cmuTarget action) (cmuUpdate action) pure (mempty, action) @@ -279,11 +294,11 @@ instance IsConversationAction ConversationDelete where Members '[Error FederationError, Error NotATeamMember, CodeStore, TeamStore] r conversationAction ConversationDelete = ConversationActionDelete ensureAllowed loc ConversationDelete conv self = - liftSem . for_ (convTeam conv) $ \tid -> do + for_ (convTeam conv) $ \tid -> do lusr <- ensureLocal loc (convMemberId loc self) void $ E.getTeamMember tid (tUnqualified lusr) >>= noteED @NotATeamMember conversationActionTag' _ _ = DeleteConversation - performAction _ lcnv conv action = lift . liftSem $ do + performAction _ lcnv conv action = do key <- E.makeKey (tUnqualified lcnv) E.deleteCode key ReusableCode case convTeam conv of @@ -298,7 +313,7 @@ instance IsConversationAction ConversationRename where conversationAction = ConversationActionRename conversationActionTag' _ _ = ModifyConversationName - performAction _ lcnv _ action = lift . liftSem $ do + performAction _ lcnv _ action = do cn <- rangeChecked (cupName action) E.setConversationName (tUnqualified lcnv) cn pure (mempty, action) @@ -308,8 +323,8 @@ instance IsConversationAction ConversationMessageTimerUpdate where conversationAction = ConversationActionMessageTimerUpdate conversationActionTag' _ _ = ModifyConversationMessageTimer performAction _ lcnv conv action = do - guard $ convMessageTimer conv /= cupMessageTimer action - lift . liftSem $ E.setConversationMessageTimer (tUnqualified lcnv) (cupMessageTimer action) + when (convMessageTimer conv == cupMessageTimer action) noChanges + E.setConversationMessageTimer (tUnqualified lcnv) (cupMessageTimer action) pure (mempty, action) instance IsConversationAction ConversationReceiptModeUpdate where @@ -317,8 +332,8 @@ instance IsConversationAction ConversationReceiptModeUpdate where conversationAction = ConversationActionReceiptModeUpdate conversationActionTag' _ _ = ModifyConversationReceiptMode performAction _ lcnv conv action = do - guard $ convReceiptMode conv /= Just (cruReceiptMode action) - lift . liftSem $ E.setConversationReceiptMode (tUnqualified lcnv) (cruReceiptMode action) + when (convReceiptMode conv == Just (cruReceiptMode action)) noChanges + E.setConversationReceiptMode (tUnqualified lcnv) (cruReceiptMode action) pure (mempty, action) instance IsConversationAction ConversationAccessData where @@ -335,7 +350,8 @@ instance IsConversationAction ConversationAccessData where FireAndForget, GundeckAccess, MemberStore, - TeamStore + TeamStore, + Input UTCTime ] r conversationAction = ConversationActionAccessUpdate @@ -343,12 +359,11 @@ instance IsConversationAction ConversationAccessData where -- '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 + when + ( PrivateAccess `elem` cupAccess target + || PrivateAccessRole == cupAccessRole target + ) + $ throw InvalidTargetAccess -- Team conversations incur another round of checks case convTeam conv of Just _ -> do @@ -356,32 +371,31 @@ instance IsConversationAction ConversationAccessData where -- conversation, so the user must have the necessary permission flag ensureActionAllowed RemoveConversationMember self Nothing -> - liftSem $ - when (cupAccessRole target == TeamAccessRole) $ - throw InvalidTargetAccess + when (cupAccessRole target == TeamAccessRole) $ + throw InvalidTargetAccess conversationActionTag' _ _ = ModifyConversationAccess performAction qusr lcnv conv action = do - guard $ convAccessData conv /= action + when (convAccessData conv == action) noChanges -- 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 + $ do + key <- E.makeKey (tUnqualified lcnv) + 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 + desired <- 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 + E.setConversationAccess (tUnqualified lcnv) action + E.fireAndForget $ do -- Remove bots - traverse_ (liftSem . E.deleteBot (tUnqualified lcnv) . botMemId) (bmBots toRemove) + traverse_ (E.deleteBot (tUnqualified lcnv) . botMemId) (bmBots toRemove) -- Update current bots and members let current' = current {bmBots = bmBots desired} @@ -389,7 +403,7 @@ instance IsConversationAction ConversationAccessData where -- Remove users and notify everyone void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do let rAction = ConversationLeave usersToRemove - void . runMaybeT $ performAction qusr lcnv conv rAction + void . runError @NoChanges $ performAction qusr lcnv conv rAction notifyConversationAction qusr Nothing lcnv current' (conversationAction rAction) pure (mempty, action) where @@ -425,9 +439,11 @@ updateLocalConversation :: Error ActionError, Error ConversationError, Error InvalidInput, + Error NoChanges, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r, HasConversationActionEffects a r @@ -436,27 +452,24 @@ updateLocalConversation :: Qualified UserId -> Maybe ConnId -> a -> - MaybeT (Galley r) Event + Sem r Event updateLocalConversation lcnv qusr con action = do -- retrieve conversation - (conv, self) <- - lift $ - getConversationAndMemberWithError ConvNotFound qusr (tUnqualified lcnv) + (conv, self) <- getConversationAndMemberWithError ConvNotFound qusr lcnv -- perform checks - lift $ ensureConversationActionAllowed lcnv action conv self + 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') + notifyConversationAction + qusr + con + lcnv + (convBotsAndMembers conv <> extraTargets) + (conversationAction action') -------------------------------------------------------------------------------- -- Utilities @@ -471,49 +484,47 @@ ensureConversationActionAllowed :: a -> Conversation -> mem -> - Galley r () + Sem 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 + 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 => + Members '[MemberStore, Error NoChanges] r => Local ConvId -> UserList UserId -> RoleName -> - MaybeT (Galley r) (BotsAndMembers, ConversationJoin) + Sem 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 + (lmems, rmems) <- E.createMembers (tUnqualified lcnv) (fmap (,role) users) + neUsers <- note NoChanges $ nonEmpty (ulAll lcnv users) let action = ConversationJoin neUsers role pure (bmFromMembers lmems rmems, action) notifyConversationAction :: - Members '[FederatorAccess, ExternalAccess, GundeckAccess] r => + Members '[FederatorAccess, ExternalAccess, GundeckAccess, Input UTCTime] 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 + Sem r Event +notifyConversationAction quid con lcnv targets action = do + now <- input + let e = conversationActionToEvent now quid (qUntagged lcnv) 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 + E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> + F.onConversationUpdated F.clientRoutes (tDomain lcnv) $ + F.ConversationUpdate now quid (tUnqualified lcnv) (tUnqualified ruids) action -- notify local participants and bots - pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e + pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) $> e diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 8d209b5765f..ec2ede0a808 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -22,51 +22,48 @@ module Galley.API.Clients ) where -import Control.Lens (view) import Data.Id -import Galley.App import Galley.Effects import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ClientStore as E -import Galley.Options import Galley.Types.Clients (clientIds, fromUserClients) import Imports import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities +import Polysemy getClientsH :: Members '[BrigAccess, ClientStore] r => UserId -> - Galley r Response + Sem r Response getClientsH usr = do json <$> getClients usr getClients :: Members '[BrigAccess, ClientStore] r => UserId -> - Galley r [ClientId] + Sem r [ClientId] getClients usr = do - isInternal <- view $ options . optSettings . setIntraListing + isInternal <- E.useIntraClientListing clts <- - liftSem $ - if isInternal - then fromUserClients <$> E.lookupClients [usr] - else E.getClients [usr] + if isInternal + then fromUserClients <$> E.lookupClients [usr] + else E.getClients [usr] return $ clientIds usr clts addClientH :: Member ClientStore r => UserId ::: ClientId -> - Galley r Response -addClientH (usr ::: clt) = liftSem $ do + Sem r Response +addClientH (usr ::: clt) = do E.createClient usr clt return empty rmClientH :: Member ClientStore r => UserId ::: ClientId -> - Galley r Response -rmClientH (usr ::: clt) = liftSem $ do + Sem r Response +rmClientH (usr ::: clt) = do E.deleteClient usr clt return empty diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 8c4b698bf38..4e8df3936b4 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -36,7 +36,6 @@ import Galley.API.Error import Galley.API.Mapping import Galley.API.One2One import Galley.API.Util -import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Data.Conversation.Types import Galley.Effects @@ -44,7 +43,9 @@ import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.GundeckAccess as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.TeamStore as E +import Galley.Effects.WaiRoutes import Galley.Intra.Push +import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.Teams (ListType (..), Perm (..), TeamBinding (Binding), notTeamMember) import Galley.Types.UserList @@ -56,6 +57,8 @@ import Network.Wai.Predicate hiding (Error, setStatus) import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import Wire.API.Conversation hiding (Conversation, Member) import qualified Wire.API.Conversation as Public import Wire.API.ErrorDescription @@ -81,17 +84,19 @@ createGroupConversation :: Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, - TeamStore + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> Public.NewConvUnmanaged -> - Galley r ConversationResponse + Sem r ConversationResponse createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = case newConvTeam body of Nothing -> createRegularGroupConv user conn wrapped @@ -109,18 +114,23 @@ internalCreateManagedConversationH :: Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, FederatorAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, LegalHoldStore, - TeamStore + TeamStore, + P.TinyLog, + WaiRoutes ] r => UserId ::: ConnId ::: JsonRequest NewConvManaged -> - Galley r Response + Sem r Response internalCreateManagedConversationH (zusr ::: zcon ::: req) = do + lusr <- qualifyLocal zusr newConv <- fromJsonBody req - handleConversationResponse <$> internalCreateManagedConversation zusr zcon newConv + handleConversationResponse <$> internalCreateManagedConversation lusr zcon newConv internalCreateManagedConversation :: Members @@ -132,31 +142,33 @@ internalCreateManagedConversation :: Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, FederatorAccess, GundeckAccess, + Input Opts, LegalHoldStore, - TeamStore + Input UTCTime, + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> NewConvManaged -> - Galley r ConversationResponse -internalCreateManagedConversation zusr zcon (NewConvManaged body) = do - tinfo <- liftSem $ note CannotCreateManagedConv (newConvTeam body) - createTeamGroupConv zusr zcon tinfo body + Sem r ConversationResponse +internalCreateManagedConversation lusr zcon (NewConvManaged body) = do + tinfo <- note CannotCreateManagedConv (newConvTeam body) + createTeamGroupConv lusr zcon tinfo body ensureNoLegalholdConflicts :: - Members '[Error LegalHoldError, LegalHoldStore, TeamStore] r => + Members '[Error LegalHoldError, Input Opts, LegalHoldStore, TeamStore] r => [Remote UserId] -> [UserId] -> - Galley r () + Sem r () ensureNoLegalholdConflicts remotes locals = do let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes whenM (anyLegalholdActivated locals) $ unlessM (allLegalholdConsentGiven locals) $ - liftSem $ throw MissingLegalholdConsent + throw MissingLegalholdConsent -- | A helper for creating a regular (non-team) group conversation. createRegularGroupConv :: @@ -169,39 +181,40 @@ createRegularGroupConv :: Error InvalidInput, Error LegalHoldError, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, - TeamStore + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> NewConvUnmanaged -> - Galley r ConversationResponse -createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do - lusr <- qualifyLocal zusr - name <- liftSem $ rangeCheckedMaybe (newConvName body) + Sem r ConversationResponse +createRegularGroupConv lusr zcon (NewConvUnmanaged body) = do + name <- rangeCheckedMaybe (newConvName body) let allUsers = newConvMembers lusr body - o <- view options - checkedUsers <- liftSem $ checkedConvSize o allUsers + o <- input + checkedUsers <- checkedConvSize o allUsers ensureConnected lusr allUsers ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) c <- - liftSem $ - E.createConversation - NewConversation - { ncType = RegularConv, - ncCreator = tUnqualified lusr, - ncAccess = access body, - ncAccessRole = accessRole body, - ncName = name, - ncTeam = fmap cnvTeamId (newConvTeam body), - ncMessageTimer = newConvMessageTimer body, - ncReceiptMode = newConvReceiptMode body, - ncUsers = checkedUsers, - ncRole = newConvUsersRole body - } - notifyCreatedConversation Nothing zusr (Just zcon) c - conversationCreated zusr c + E.createConversation + NewConversation + { ncType = RegularConv, + ncCreator = tUnqualified lusr, + ncAccess = access body, + ncAccessRole = accessRole body, + ncName = name, + ncTeam = fmap cnvTeamId (newConvTeam body), + ncMessageTimer = newConvMessageTimer body, + ncReceiptMode = newConvReceiptMode body, + ncUsers = checkedUsers, + ncRole = newConvUsersRole body + } + notifyCreatedConversation Nothing lusr (Just zcon) c + conversationCreated lusr c -- | A helper for creating a team group conversation, used by the endpoint -- handlers above. Only supports unmanaged conversations. @@ -215,29 +228,30 @@ createTeamGroupConv :: Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, - TeamStore + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> Public.ConvTeamInfo -> Public.NewConv -> - Galley r ConversationResponse -createTeamGroupConv zusr zcon tinfo body = do - lusr <- qualifyLocal zusr - name <- liftSem $ rangeCheckedMaybe (newConvName body) + Sem r ConversationResponse +createTeamGroupConv lusr zcon tinfo body = do + name <- rangeCheckedMaybe (newConvName body) let allUsers = newConvMembers lusr body convTeam = cnvTeamId tinfo - zusrMembership <- liftSem $ E.getTeamMember convTeam zusr + zusrMembership <- E.getTeamMember convTeam (tUnqualified lusr) void $ permissionCheck CreateConversation zusrMembership - o <- view options - checkedUsers <- liftSem $ checkedConvSize o allUsers - convLocalMemberships <- mapM (liftSem . E.getTeamMember convTeam) (ulLocals allUsers) + o <- input + checkedUsers <- checkedConvSize o allUsers + convLocalMemberships <- mapM (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 -- users without the 'AddRemoveConvMember' permission to still be able to create @@ -253,44 +267,44 @@ createTeamGroupConv zusr zcon tinfo body = do void $ permissionCheck DoNotUseDeprecatedAddRemoveConvMember zusrMembership -- Team members are always considered to be connected, so we only check -- 'ensureConnected' for non-team-members. - ensureConnectedToLocals zusr (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) + ensureConnectedToLocals (tUnqualified lusr) (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) ensureConnectedToRemotes lusr (ulRemotes allUsers) ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) conv <- - liftSem $ - E.createConversation - NewConversation - { ncType = RegularConv, - ncCreator = tUnqualified lusr, - ncAccess = access body, - ncAccessRole = accessRole body, - ncName = name, - ncTeam = fmap cnvTeamId (newConvTeam body), - ncMessageTimer = newConvMessageTimer body, - ncReceiptMode = newConvReceiptMode body, - ncUsers = checkedUsers, - ncRole = newConvUsersRole body - } - now <- liftIO getCurrentTime + E.createConversation + NewConversation + { ncType = RegularConv, + ncCreator = tUnqualified lusr, + ncAccess = access body, + ncAccessRole = accessRole body, + ncName = name, + ncTeam = fmap cnvTeamId (newConvTeam body), + ncMessageTimer = newConvMessageTimer body, + ncReceiptMode = newConvReceiptMode body, + ncUsers = checkedUsers, + ncRole = newConvUsersRole body + } + now <- input -- NOTE: We only send (conversation) events to members of the conversation - notifyCreatedConversation (Just now) zusr (Just zcon) conv - conversationCreated zusr conv + notifyCreatedConversation (Just now) lusr (Just zcon) conv + conversationCreated lusr conv ---------------------------------------------------------------------------- -- Other kinds of conversations createSelfConversation :: - Members '[ConversationStore, Error InternalError] r => - UserId -> - Galley r ConversationResponse -createSelfConversation zusr = do - lusr <- qualifyLocal zusr - c <- liftSem $ E.getConversation (Id . toUUID $ zusr) - maybe (create lusr) (conversationExisted zusr) c + forall r. + Members '[ConversationStore, Error InternalError, P.TinyLog] r => + Local UserId -> + Sem r ConversationResponse +createSelfConversation lusr = do + c <- E.getConversation (Id . toUUID . tUnqualified $ lusr) + maybe create (conversationExisted lusr) c where - create lusr = do - c <- liftSem $ E.createSelfConversation lusr Nothing - conversationCreated zusr c + create :: Sem r ConversationResponse + create = do + c <- E.createSelfConversation lusr Nothing + conversationCreated lusr c createOne2OneConversation :: forall r. @@ -306,65 +320,66 @@ createOne2OneConversation :: Error TeamError, FederatorAccess, GundeckAccess, - TeamStore + Input UTCTime, + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> NewConvUnmanaged -> - Galley r ConversationResponse -createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do - lusr <- qualifyLocal zusr + Sem r ConversationResponse +createOne2OneConversation lusr zcon (NewConvUnmanaged j) = do let allUsers = newConvMembers lusr j - other <- liftSem $ ensureOne (ulAll lusr allUsers) - liftSem . when (qUntagged lusr == other) $ + other <- ensureOne (ulAll lusr allUsers) + when (qUntagged lusr == other) $ throw . InvalidOp $ One2OneConv mtid <- case newConvTeam j of Just ti - | cnvManaged ti -> liftSem $ throw NoManagedTeamConv + | cnvManaged ti -> throw NoManagedTeamConv | otherwise -> do foldQualified lusr - (\lother -> checkBindingTeamPermissions lusr lother (cnvTeamId ti)) + (\lother -> checkBindingTeamPermissions lother (cnvTeamId ti)) (const (pure Nothing)) other Nothing -> ensureConnected lusr allUsers $> Nothing - n <- liftSem $ rangeCheckedMaybe (newConvName j) + n <- rangeCheckedMaybe (newConvName j) foldQualified lusr (createLegacyOne2OneConversationUnchecked lusr zcon n mtid) (createOne2OneConversationUnchecked lusr zcon n mtid . qUntagged) other where - verifyMembership :: TeamId -> UserId -> Galley r () + verifyMembership :: TeamId -> UserId -> Sem r () verifyMembership tid u = do - membership <- liftSem $ E.getTeamMember tid u - liftSem . when (isNothing membership) $ + membership <- E.getTeamMember tid u + when (isNothing membership) $ throw NoBindingTeamMembers checkBindingTeamPermissions :: - Local UserId -> Local UserId -> TeamId -> - Galley r (Maybe TeamId) - checkBindingTeamPermissions lusr lother tid = do - zusrMembership <- liftSem $ E.getTeamMember tid (tUnqualified lusr) + Sem r (Maybe TeamId) + checkBindingTeamPermissions lother tid = do + zusrMembership <- E.getTeamMember tid (tUnqualified lusr) void $ permissionCheck CreateConversation zusrMembership - liftSem (E.getTeamBinding tid) >>= \case + E.getTeamBinding tid >>= \case Just Binding -> do verifyMembership tid (tUnqualified lusr) verifyMembership tid (tUnqualified lother) pure (Just tid) - Just _ -> liftSem $ throw NotABindingTeamMember - Nothing -> liftSem $ throw TeamNotFound + Just _ -> throw NotABindingTeamMember + Nothing -> throw TeamNotFound createLegacyOne2OneConversationUnchecked :: Members '[ ConversationStore, - Error ActionError, Error InternalError, Error InvalidInput, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime, + P.TinyLog ] r => Local UserId -> @@ -372,17 +387,17 @@ createLegacyOne2OneConversationUnchecked :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Local UserId -> - Galley r ConversationResponse + Sem r ConversationResponse createLegacyOne2OneConversationUnchecked self zcon name mtid other = do lcnv <- localOne2OneConvId self other - mc <- liftSem $ E.getConversation (tUnqualified lcnv) + mc <- E.getConversation (tUnqualified lcnv) case mc of - Just c -> conversationExisted (tUnqualified self) c + Just c -> conversationExisted self c Nothing -> do (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) - c <- liftSem $ E.createLegacyOne2OneConversation self x y name mtid - notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c - conversationCreated (tUnqualified self) c + c <- E.createLegacyOne2OneConversation self x y name mtid + notifyCreatedConversation Nothing self (Just zcon) c + conversationCreated self c createOne2OneConversationUnchecked :: Members @@ -390,7 +405,9 @@ createOne2OneConversationUnchecked :: Error FederationError, Error InternalError, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime, + P.TinyLog ] r => Local UserId -> @@ -398,7 +415,7 @@ createOne2OneConversationUnchecked :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley r ConversationResponse + Sem r ConversationResponse createOne2OneConversationUnchecked self zcon name mtid other = do let create = foldQualified @@ -408,22 +425,30 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId (qUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: - Members '[ConversationStore, Error InternalError, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + Error InternalError, + FederatorAccess, + GundeckAccess, + Input UTCTime, + P.TinyLog + ] + r => Local ConvId -> Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley r ConversationResponse + Sem r ConversationResponse createOne2OneConversationLocally lcnv self zcon name mtid other = do - mc <- liftSem $ E.getConversation (tUnqualified lcnv) + mc <- E.getConversation (tUnqualified lcnv) case mc of - Just c -> conversationExisted (tUnqualified self) c + Just c -> conversationExisted self c Nothing -> do - c <- liftSem $ E.createOne2OneConversation (tUnqualified lcnv) self other name mtid - notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c - conversationCreated (tUnqualified self) c + c <- E.createOne2OneConversation (tUnqualified lcnv) self other name mtid + notifyCreatedConversation Nothing self (Just zcon) c + conversationCreated self c createOne2OneConversationRemotely :: Member (Error FederationError) r => @@ -433,10 +458,9 @@ createOne2OneConversationRemotely :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley r ConversationResponse + Sem r ConversationResponse createOne2OneConversationRemotely _ _ _ _ _ _ = - liftSem $ - throw FederationNotImplemented + throw FederationNotImplemented createConnectConversation :: Members @@ -448,15 +472,16 @@ createConnectConversation :: Error InvalidInput, FederatorAccess, GundeckAccess, - MemberStore + Input UTCTime, + MemberStore, + P.TinyLog ] r => - UserId -> + Local UserId -> Maybe ConnId -> Connect -> - Galley r ConversationResponse -createConnectConversation usr conn j = do - lusr <- qualifyLocal usr + Sem r ConversationResponse +createConnectConversation lusr conn j = do foldQualified lusr (\lrcpt -> createLegacyConnectConversation lusr conn lrcpt j) @@ -468,10 +493,9 @@ createConnectConversationWithRemote :: Local UserId -> Maybe ConnId -> Remote UserId -> - Galley r ConversationResponse + Sem r ConversationResponse createConnectConversationWithRemote _ _ _ = - liftSem $ - throw FederationNotImplemented + throw FederationNotImplemented createLegacyConnectConversation :: Members @@ -482,42 +506,44 @@ createLegacyConnectConversation :: Error InternalError, FederatorAccess, GundeckAccess, - MemberStore + Input UTCTime, + MemberStore, + P.TinyLog ] r => Local UserId -> Maybe ConnId -> Local UserId -> Connect -> - Galley r ConversationResponse + Sem r ConversationResponse createLegacyConnectConversation lusr conn lrecipient j = do (x, y) <- toUUIDs (tUnqualified lusr) (tUnqualified lrecipient) - n <- liftSem $ rangeCheckedMaybe (cName j) - conv <- liftSem $ E.getConversation (Data.localOne2OneConvId x y) + n <- rangeCheckedMaybe (cName j) + conv <- E.getConversation (Data.localOne2OneConvId x y) maybe (create x y n) (update n) conv where create x y n = do - c <- liftSem $ E.createConnectConversation x y n - now <- liftIO getCurrentTime + c <- E.createConnectConversation x y n + now <- input let lcid = qualifyAs lusr (Data.convId c) e = Event ConvConnect (qUntagged lcid) (qUntagged lusr) now (EdConnect j) - notifyCreatedConversation Nothing (tUnqualified lusr) conn c + notifyCreatedConversation Nothing lusr conn c for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> - liftSem . E.push1 $ + E.push1 $ p & pushRoute .~ RouteDirect & pushConn .~ conn - conversationCreated (tUnqualified lusr) c + conversationCreated lusr c update n conv = do let mems = Data.convLocalMembers conv - in conversationExisted (tUnqualified lusr) + in conversationExisted lusr =<< if | (tUnqualified lusr) `isMember` mems -> -- we already were in the conversation, maybe also other connect n conv | otherwise -> do - lcid <- qualifyLocal (Data.convId conv) - mm <- liftSem $ E.createMember lcid lusr + let lcid = qualifyAs lusr (Data.convId conv) + mm <- E.createMember lcid lusr let conv' = conv { Data.convLocalMembers = Data.convLocalMembers conv <> toList mm @@ -528,23 +554,22 @@ createLegacyConnectConversation lusr conn lrecipient j = do connect n conv' else do -- we were not in the conversation, but someone else - conv'' <- acceptOne2One (tUnqualified lusr) conv' conn + conv'' <- acceptOne2One lusr conv' conn if Data.convType conv'' == ConnectConv then connect n conv'' else return conv'' connect n conv | Data.convType conv == ConnectConv = do - localDomain <- viewFederationDomain - let qconv = Qualified (Data.convId conv) localDomain + let lcnv = qualifyAs lusr (Data.convId conv) n' <- case n of - Just x -> liftSem $ do + Just x -> do E.setConversationName (Data.convId conv) x return . Just $ fromRange x Nothing -> return $ Data.convName conv - t <- liftIO getCurrentTime - let e = Event ConvConnect qconv (qUntagged lusr) t (EdConnect j) + t <- input + let e = Event ConvConnect (qUntagged lcnv) (qUntagged lusr) t (EdConnect j) for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers conv)) $ \p -> - liftSem . E.push1 $ + E.push1 $ p & pushRoute .~ RouteDirect & pushConn .~ conn @@ -555,18 +580,18 @@ createLegacyConnectConversation lusr conn lrecipient j = do -- Helpers conversationCreated :: - Member (Error InternalError) r => - UserId -> + Members '[Error InternalError, P.TinyLog] r => + Local UserId -> Data.Conversation -> - Galley r ConversationResponse -conversationCreated usr cnv = Created <$> conversationView usr cnv + Sem r ConversationResponse +conversationCreated lusr cnv = Created <$> conversationView lusr cnv conversationExisted :: - Member (Error InternalError) r => - UserId -> + Members '[Error InternalError, P.TinyLog] r => + Local UserId -> Data.Conversation -> - Galley r ConversationResponse -conversationExisted usr cnv = Existed <$> conversationView usr cnv + Sem r ConversationResponse +conversationExisted lusr cnv = Existed <$> conversationView lusr cnv handleConversationResponse :: ConversationResponse -> Response handleConversationResponse = \case @@ -574,34 +599,32 @@ handleConversationResponse = \case Existed cnv -> json cnv & setStatus status200 . location (qUnqualified . cnvQualifiedId $ cnv) notifyCreatedConversation :: - Members '[Error InternalError, FederatorAccess, GundeckAccess] r => + Members '[Error InternalError, FederatorAccess, GundeckAccess, Input UTCTime, P.TinyLog] r => Maybe UTCTime -> - UserId -> + Local UserId -> Maybe ConnId -> Data.Conversation -> - Galley r () -notifyCreatedConversation dtime usr conn c = do - localDomain <- viewFederationDomain - now <- maybe (liftIO getCurrentTime) pure dtime + Sem r () +notifyCreatedConversation dtime lusr conn c = do + now <- maybe (input) pure dtime -- FUTUREWORK: Handle failures in notifying so it does not abort half way -- through (either when notifying remotes or locals) -- -- Ask remote server to store conversation membership and notify remote users -- of being added to a conversation - registerRemoteConversationMemberships now localDomain c + registerRemoteConversationMemberships now (tDomain lusr) c -- Notify local users - liftSem . E.push =<< mapM (toPush localDomain now) (Data.convLocalMembers c) + E.push =<< mapM (toPush now) (Data.convLocalMembers c) where route | Data.convType c == RegularConv = RouteAny | otherwise = RouteDirect - toPush dom t m = do - let qconv = Qualified (Data.convId c) dom - qusr = Qualified usr dom - c' <- conversationView (lmId m) c - let e = Event ConvCreate qconv qusr t (EdConversation c') + toPush t m = do + let lconv = qualifyAs lusr (Data.convId c) + c' <- conversationView (qualifyAs lusr (lmId m)) c + let e = Event ConvCreate (qUntagged lconv) (qUntagged lusr) t (EdConversation c') return $ - newPushLocal1 ListComplete usr (ConvEvent e) (list1 (recipient m) []) + newPushLocal1 ListComplete (tUnqualified lusr) (ConvEvent e) (list1 (recipient m) []) & pushConn .~ conn & pushRoute .~ route @@ -609,7 +632,7 @@ localOne2OneConvId :: Member (Error InvalidInput) r => Local UserId -> Local UserId -> - Galley r (Local ConvId) + Sem r (Local ConvId) localOne2OneConvId self other = do (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) pure . qualifyAs self $ Data.localOne2OneConvId x y @@ -618,10 +641,10 @@ toUUIDs :: Member (Error InvalidInput) r => UserId -> UserId -> - Galley r (U.UUID U.V4, U.UUID U.V4) + Sem r (U.UUID U.V4, U.UUID U.V4) toUUIDs a b = do - a' <- U.fromUUID (toUUID a) & note InvalidUUID4 & liftSem - b' <- U.fromUUID (toUUID b) & note InvalidUUID4 & liftSem + a' <- U.fromUUID (toUUID a) & note InvalidUUID4 + b' <- U.fromUUID (toUUID b) & note InvalidUUID4 return (a', b') accessRole :: NewConv -> AccessRole diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index 52cfd656b5d..ebcff2b55e2 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -25,8 +25,8 @@ where import Data.Domain (Domain) import Galley.API.Error import Galley.API.Util -import Galley.App import Galley.Effects.CustomBackendStore +import Galley.Effects.WaiRoutes import Galley.Types import Imports hiding ((\\)) import Network.HTTP.Types @@ -46,33 +46,32 @@ getCustomBackendByDomainH :: ] r => Domain ::: JSON -> - Galley r Response + Sem r Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain getCustomBackendByDomain :: Members '[CustomBackendStore, Error CustomBackendError] r => Domain -> - Galley r Public.CustomBackend + Sem r Public.CustomBackend getCustomBackendByDomain domain = - liftSem $ - getCustomBackend domain >>= \case - Nothing -> throw (CustomBackendNotFound domain) - Just customBackend -> pure customBackend + getCustomBackend domain >>= \case + Nothing -> throw (CustomBackendNotFound domain) + Just customBackend -> pure customBackend -- INTERNAL ------------------------------------------------------------------- internalPutCustomBackendByDomainH :: - Members '[CustomBackendStore, Error InvalidInput] r => + Members '[CustomBackendStore, WaiRoutes] r => Domain ::: JsonRequest CustomBackend -> - Galley r Response + Sem r Response internalPutCustomBackendByDomainH (domain ::: req) = do customBackend <- fromJsonBody req -- simple enough to not need a separate function - liftSem $ setCustomBackend domain customBackend + setCustomBackend domain customBackend pure (empty & setStatus status201) -internalDeleteCustomBackendByDomainH :: Member CustomBackendStore r => Domain ::: JSON -> Galley r Response +internalDeleteCustomBackendByDomainH :: Member CustomBackendStore r => Domain ::: JSON -> Sem r Response internalDeleteCustomBackendByDomainH (domain ::: _) = do - liftSem $ deleteCustomBackend domain + deleteCustomBackend domain pure (empty & setStatus status200) diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index ab555dcff61..34c6ec0d3c8 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -218,12 +218,13 @@ instance APIError ClientError where toWai UnknownClient = errorDescriptionTypeToWai @UnknownClient throwED :: + forall e code label desc r a. ( e ~ ErrorDescription code label desc, KnownSymbol desc, Member (P.Error e) r ) => Sem r a -throwED = P.throw mkErrorDescription +throwED = P.throw @e mkErrorDescription noteED :: forall e code label desc r a. diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 348bec3dec9..f1527638646 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.Trans.Maybe (runMaybeT) import Data.ByteString.Conversion (toByteString') import Data.Containers.ListUtils (nubOrd) import Data.Domain (Domain) @@ -31,6 +30,7 @@ import Data.Qualified import Data.Range (Range (fromRange)) import qualified Data.Set as Set import qualified Data.Text.Lazy as LT +import Data.Time.Clock import Galley.API.Action import Galley.API.Error import qualified Galley.API.Mapping as Mapping @@ -41,11 +41,16 @@ import qualified Galley.Data.Conversation as Data import Galley.Effects import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.FireAndForget as E import qualified Galley.Effects.MemberStore as E +import Galley.Options import Galley.Types.Conversations.Members import Galley.Types.UserList (UserList (UserList)) import Imports -import Polysemy.Error (Error, throw) +import Polysemy +import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) @@ -57,13 +62,12 @@ import qualified Wire.API.Conversation.Role as Public import Wire.API.Event.Conversation 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 import Wire.API.ServantProto import Wire.API.User.Client (userClientMap) -federationSitemap :: ServerT (ToServantApi F.Api) (Galley GalleyEffects) +federationSitemap :: ServerT (ToServantApi F.Api) (Sem GalleyEffects) federationSitemap = genericServerT $ F.Api @@ -77,10 +81,10 @@ federationSitemap = } onConversationCreated :: - Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => + Members '[BrigAccess, GundeckAccess, ExternalAccess, Input (Local ()), MemberStore, P.TinyLog] r => Domain -> F.NewRemoteConversation ConvId -> - Galley r () + Sem r () onConversationCreated domain rc = do let qrc = fmap (toRemoteUnsafe domain) rc loc <- qualifyLocal () @@ -112,20 +116,19 @@ onConversationCreated domain rc = do (qUntagged (F.rcRemoteOrigUserId qrcConnected)) (F.rcTime qrcConnected) (EdConversation c) - pushConversationEvent Nothing event [qUnqualified . Public.memId $ mem] [] + pushConversationEvent Nothing event (qualifyAs loc [qUnqualified . Public.memId $ mem]) [] getConversations :: - Member ConversationStore r => + Members '[ConversationStore, Input (Local ())] r => Domain -> F.GetConversationsRequest -> - Galley r F.GetConversationsResponse + Sem r F.GetConversationsResponse getConversations domain (F.GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid - localDomain <- viewFederationDomain - liftSem $ - F.GetConversationsResponse - . mapMaybe (Mapping.conversationToRemote localDomain ruid) - <$> E.getConversations cids + loc <- qualifyLocal () + F.GetConversationsResponse + . mapMaybe (Mapping.conversationToRemote (tDomain loc) ruid) + <$> E.getConversations cids getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomain) . toList @@ -133,12 +136,19 @@ getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomai -- | Update the local database with information on conversation members joining -- or leaving. Finally, push out notifications to local users. onConversationUpdated :: - Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => + Members + '[ BrigAccess, + GundeckAccess, + ExternalAccess, + Input (Local ()), + MemberStore, + P.TinyLog + ] + r => Domain -> F.ConversationUpdate -> - Galley r () + Sem r () onConversationUpdated requestingDomain cu = do - localDomain <- viewFederationDomain loc <- qualifyLocal () let rconvId = toRemoteUnsafe requestingDomain (F.cuConvId cu) qconvId = qUntagged rconvId @@ -147,8 +157,7 @@ onConversationUpdated requestingDomain cu = do -- the conversation (from our point of view), to prevent spam from the remote -- backend. See also the comment below. (presentUsers, allUsersArePresent) <- - liftSem $ - E.selectRemoteMembers (F.cuAlreadyPresentUsers cu) rconvId + E.selectRemoteMembers (F.cuAlreadyPresentUsers cu) rconvId -- Perform action, and determine extra notification targets. -- @@ -166,8 +175,8 @@ onConversationUpdated requestingDomain cu = do case allAddedUsers of [] -> pure (Nothing, []) -- If no users get added, its like no action was performed. (u : us) -> pure (Just $ ConversationActionAddMembers (u :| us) role, addedLocalUsers) - ConversationActionRemoveMembers toRemove -> liftSem $ do - let localUsers = getLocalUsers localDomain toRemove + ConversationActionRemoveMembers toRemove -> do + let localUsers = getLocalUsers (tDomain loc) toRemove E.deleteMembersInRemoteConversation rconvId localUsers pure (Just $ F.cuAction cu, []) ConversationActionRename _ -> pure (Just $ F.cuAction cu, []) @@ -175,12 +184,12 @@ onConversationUpdated requestingDomain cu = do ConversationActionMemberUpdate _ _ -> pure (Just $ F.cuAction cu, []) ConversationActionReceiptModeUpdate _ -> pure (Just $ F.cuAction cu, []) ConversationActionAccessUpdate _ -> pure (Just $ F.cuAction cu, []) - ConversationActionDelete -> liftSem $ do + ConversationActionDelete -> do E.deleteMembersInRemoteConversation rconvId presentUsers pure (Just $ F.cuAction cu, []) unless allUsersArePresent $ - Log.warn $ + P.warn $ Log.field "conversation" (toByteString' (F.cuConvId cu)) . Log.field "domain" (toByteString' requestingDomain) . Log.msg @@ -195,16 +204,16 @@ onConversationUpdated requestingDomain cu = do targets = nubOrd $ presentUsers <> extraTargets -- FUTUREWORK: support bots? - pushConversationEvent Nothing event targets [] + pushConversationEvent Nothing event (qualifyAs loc targets) [] addLocalUsersToRemoteConv :: - Members '[BrigAccess, MemberStore] r => + Members '[BrigAccess, MemberStore, P.TinyLog] r => Remote ConvId -> Qualified UserId -> [UserId] -> - Galley r (Set UserId) + Sem r (Set UserId) addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do - connStatus <- liftSem $ E.getConnections localUsers (Just [qAdder]) (Just Accepted) + connStatus <- E.getConnections localUsers (Just [qAdder]) (Just Accepted) let localUserIdsSet = Set.fromList localUsers connected = Set.fromList $ fmap csv2From connStatus unconnected = Set.difference localUserIdsSet connected @@ -213,48 +222,40 @@ addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do -- FUTUREWORK: Consider handling the discrepancy between the views of the -- conversation-owning backend and the local backend unless (Set.null unconnected) $ - Log.warn $ + P.warn $ Log.msg ("A remote user is trying to add unconnected local users to a remote conversation" :: Text) . Log.field "remote_user" (show qAdder) . Log.field "local_unconnected_users" (show unconnected) -- Update the local view of the remote conversation by adding only those local -- users that are connected to the adder - liftSem $ E.createMembersInRemoteConversation remoteConvId connectedList + E.createMembersInRemoteConversation remoteConvId connectedList pure connected -- FUTUREWORK: actually return errors as part of the response instead of throwing leaveConversation :: Members - '[ BotAccess, - BrigAccess, - CodeStore, - ConversationStore, + '[ ConversationStore, Error ActionError, Error ConversationError, - Error FederationError, Error InvalidInput, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, - LegalHoldStore, - MemberStore, - TeamStore + Input (Local ()), + Input UTCTime, + MemberStore ] r => Domain -> F.LeaveConversationRequest -> - Galley r F.LeaveConversationResponse + Sem r F.LeaveConversationResponse leaveConversation requestingDomain lc = do let leaver = Qualified (F.lcLeaver lc) requestingDomain lcnv <- qualifyLocal (F.lcConvId lc) - fmap - ( F.LeaveConversationResponse - . maybe (Left RemoveFromConversationErrorUnchanged) Right - ) - . runMaybeT + fmap F.LeaveConversationResponse + . runError + . mapError @NoChanges (const RemoveFromConversationErrorUnchanged) . void . updateLocalConversation lcnv leaver Nothing . ConversationLeave @@ -264,10 +265,10 @@ leaveConversation requestingDomain lc = do -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients onMessageSent :: - Members '[BotAccess, GundeckAccess, ExternalAccess, MemberStore] r => + Members '[GundeckAccess, ExternalAccess, MemberStore, Input (Local ()), P.TinyLog] r => Domain -> F.RemoteMessage ConvId -> - Galley r () + Sem r () onMessageSent domain rmUnqualified = do let rm = fmap (toRemoteUnsafe domain) rmUnqualified convId = qUntagged $ F.rmConversation rm @@ -281,10 +282,9 @@ onMessageSent domain rmUnqualified = do recipientMap = userClientMap $ F.rmRecipients rm msgs = toMapOf (itraversed <.> itraversed) recipientMap (members, allMembers) <- - liftSem $ - E.selectRemoteMembers (Map.keys recipientMap) (F.rmConversation rm) + E.selectRemoteMembers (Map.keys recipientMap) (F.rmConversation rm) unless allMembers $ - Log.warn $ + P.warn $ Log.field "conversation" (toByteString' (qUnqualified convId)) Log.~~ Log.field "domain" (toByteString' (qDomain convId)) Log.~~ Log.msg @@ -305,7 +305,7 @@ onMessageSent domain rmUnqualified = do msgs where -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-875 - mkLocalMember :: UserId -> Galley r LocalMember + mkLocalMember :: UserId -> Sem r LocalMember mkLocalMember m = pure $ LocalMember @@ -317,27 +317,31 @@ onMessageSent domain rmUnqualified = do sendMessage :: Members - '[ BotAccess, - BrigAccess, + '[ BrigAccess, ClientStore, ConversationStore, Error InvalidInput, FederatorAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, ExternalAccess, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => Domain -> F.MessageSendRequest -> - Galley r F.MessageSendResponse + Sem r F.MessageSendResponse sendMessage originDomain msr = do 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 + msg <- either throwErr pure (fromProto (fromBase64ByteString (F.msrRawMessage msr))) + lcnv <- qualifyLocal (F.msrConvId msr) + F.MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing lcnv msg where - err = liftSem . throw . InvalidPayload . LT.pack + throwErr = throw . InvalidPayload . LT.pack onUserDeleted :: Members @@ -346,22 +350,24 @@ onUserDeleted :: FireAndForget, ExternalAccess, GundeckAccess, + Input (Local ()), + Input UTCTime, MemberStore ] r => Domain -> F.UserDeletedConversationsNotification -> - Galley r EmptyResponse + Sem r EmptyResponse onUserDeleted origDomain udcn = do let deletedUser = toRemoteUnsafe origDomain (F.udcnUser udcn) untaggedDeletedUser = qUntagged deletedUser convIds = F.udcnConversations udcn - spawnMany $ + E.spawnMany $ fromRange convIds <&> \c -> do lc <- qualifyLocal c - mconv <- liftSem $ E.getConversation c - liftSem $ E.deleteMembers c (UserList [] [deletedUser]) + mconv <- E.getConversation c + E.deleteMembers c (UserList [] [deletedUser]) for_ mconv $ \conv -> do when (isRemoteMember deletedUser (Data.convRemoteMembers conv)) $ case Data.convType conv of diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index e37590085ea..5c5a555b927 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -40,7 +40,7 @@ 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 Galley.API.LegalHold.Conflicts import qualified Galley.API.One2One as One2One import qualified Galley.API.Query as Query import Galley.API.Teams (uncheckedDeleteTeamMember) @@ -60,7 +60,10 @@ import Galley.Effects.GundeckAccess import Galley.Effects.MemberStore import Galley.Effects.Paging import Galley.Effects.TeamStore +import Galley.Effects.WaiRoutes import qualified Galley.Intra.Push as Intra +import Galley.Monad +import Galley.Options import qualified Galley.Queue as Q import Galley.Types import Galley.Types.Bot (AddBot, RemoveBot) @@ -74,11 +77,14 @@ import Imports hiding (head) import Network.HTTP.Types (status200) import Network.Wai import Network.Wai.Predicate hiding (Error, err) -import qualified Network.Wai.Predicate as P -import Network.Wai.Routing hiding (route, toList) +import qualified Network.Wai.Predicate as Predicate +import Network.Wai.Routing hiding (App, route, toList) import Network.Wai.Utilities hiding (Error) import Network.Wai.Utilities.ZAuth +import Polysemy import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import Servant.API hiding (JSON) import qualified Servant.API as Servant import Servant.API.Generic @@ -94,7 +100,7 @@ import qualified Wire.API.Federation.API.Galley as FedGalley import Wire.API.Federation.Client (FederationError) import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiVerb (MultiVerb, RespondEmpty) -import Wire.API.Routes.Public (ZOptConn, ZUser) +import Wire.API.Routes.Public (ZLocalUser, ZOptConn) import Wire.API.Routes.Public.Galley (ConversationVerb) import qualified Wire.API.Team.Feature as Public @@ -194,7 +200,7 @@ data InternalApi routes = InternalApi routes :- Summary "Remove a user from their teams and conversations and erase their clients" - :> ZUser + :> ZLocalUser :> ZOptConn :> "i" :> "user" @@ -205,7 +211,7 @@ data InternalApi routes = InternalApi iConnect :: routes :- Summary "Create a connect conversation (deprecated)" - :> ZUser + :> ZLocalUser :> ZOptConn :> "i" :> "conversations" @@ -266,7 +272,7 @@ type IFeatureStatusDeprecatedPut featureName = :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus featureName) :> Put '[Servant.JSON] (Public.TeamFeatureStatus featureName) -servantSitemap :: ServerT ServantAPI (Galley GalleyEffects) +servantSitemap :: ServerT ServantAPI (Sem GalleyEffects) servantSitemap = genericServerT $ InternalApi @@ -275,7 +281,7 @@ servantSitemap = iTeamFeatureStatusSSOGet = iGetTeamFeature @'Public.TeamFeatureSSO Features.getSSOStatusInternal, iTeamFeatureStatusSSOPut = iPutTeamFeature @'Public.TeamFeatureSSO Features.setSSOStatusInternal, iTeamFeatureStatusLegalHoldGet = iGetTeamFeature @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, - iTeamFeatureStatusLegalHoldPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setLegalholdStatusInternal, + iTeamFeatureStatusLegalHoldPut = iPutTeamFeature @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging), iTeamFeatureStatusSearchVisibilityGet = iGetTeamFeature @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, iTeamFeatureStatusSearchVisibilityPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setTeamSearchVisibilityAvailableInternal, iTeamFeatureStatusSearchVisibilityDeprecatedGet = iGetTeamFeature @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, @@ -313,9 +319,9 @@ iGetTeamFeature :: ] r ) => - (Features.GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + (Features.GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> TeamId -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: @@ -329,19 +335,19 @@ iPutTeamFeature :: ] r ) => - (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Sem r (Public.TeamFeatureStatus a)) -> TeamId -> Public.TeamFeatureStatus a -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) iPutTeamFeature setter = Features.setFeatureStatus @a setter DontDoAuth -sitemap :: Routes a (Galley GalleyEffects) () +sitemap :: Routes a (Sem GalleyEffects) () sitemap = do -- Conversation API (internal) ---------------------------------------- put "/i/conversations/:cnv/channel" (continue $ const (return empty)) $ zauthUserId - .&. (capture "cnv" :: HasCaptures r => Predicate r P.Error ConvId) + .&. (capture "cnv" :: HasCaptures r => Predicate r Predicate.Error ConvId) .&. request get "/i/conversations/:cnv/members/:usr" (continue Query.internalGetMemberH) $ @@ -508,83 +514,81 @@ rmUser :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, ListItems p1 ConvId, ListItems p1 (Remote ConvId), ListItems p2 TeamId, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r ) => - UserId -> + Local UserId -> Maybe ConnId -> - Galley r () -rmUser user conn = do + Sem r () +rmUser lusr conn = do let nRange1000 = toRange (Proxy @1000) :: Range 1 1000 Int32 - tids <- liftSem $ listTeams user Nothing maxBound + tids <- listTeams (tUnqualified lusr) Nothing maxBound leaveTeams tids - allConvIds <- Query.conversationIdsPageFrom user (GetPaginatedConversationIds Nothing nRange1000) - lusr <- qualifyLocal user - goConvPages lusr nRange1000 allConvIds + allConvIds <- Query.conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000) + goConvPages nRange1000 allConvIds - liftSem $ deleteClients user + deleteClients (tUnqualified lusr) where - goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley r () - goConvPages lusr range page = do + goConvPages :: Range 1 1000 Int32 -> ConvIdsPage -> Sem r () + goConvPages range page = do let (localConvs, remoteConvs) = partitionQualified lusr (mtpResults page) leaveLocalConversations localConvs - for_ (rangedChunks remoteConvs) (leaveRemoteConversations lusr) + traverse_ leaveRemoteConversations (rangedChunks remoteConvs) when (mtpHasMore page) $ do let nextState = mtpPagingState page - usr = tUnqualified lusr nextQuery = GetPaginatedConversationIds (Just nextState) range - newCids <- Query.conversationIdsPageFrom usr nextQuery - goConvPages lusr range newCids + newCids <- Query.conversationIdsPageFrom lusr nextQuery + goConvPages range newCids leaveTeams page = for_ (pageItems page) $ \tid -> do mems <- getTeamMembersForFanout tid - uncheckedDeleteTeamMember user conn tid user mems - page' <- liftSem $ listTeams user (Just (pageState page)) maxBound + uncheckedDeleteTeamMember lusr conn tid (tUnqualified lusr) mems + page' <- listTeams @p2 (tUnqualified lusr) (Just (pageState page)) maxBound leaveTeams page' - leaveLocalConversations :: Member MemberStore r => [ConvId] -> Galley r () + leaveLocalConversations :: [ConvId] -> Sem r () leaveLocalConversations ids = do - localDomain <- viewFederationDomain - let qUser = Qualified user localDomain - cc <- liftSem $ getConversations ids - now <- liftIO getCurrentTime + let qUser = qUntagged lusr + cc <- getConversations ids + now <- input pp <- for cc $ \c -> case Data.convType c of SelfConv -> return Nothing - One2OneConv -> liftSem $ deleteMembers (Data.convId c) (UserList [user] []) $> Nothing - ConnectConv -> liftSem $ deleteMembers (Data.convId c) (UserList [user] []) $> Nothing + One2OneConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing + ConnectConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing RegularConv - | user `isMember` Data.convLocalMembers c -> do - liftSem $ deleteMembers (Data.convId c) (UserList [user] []) + | tUnqualified lusr `isMember` Data.convLocalMembers c -> do + deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) let e = Event MemberLeave - (Qualified (Data.convId c) localDomain) - (Qualified user localDomain) + (qUntagged (qualifyAs lusr (Data.convId c))) + (qUntagged lusr) now (EdMembersLeave (QualifiedUserIdList [qUser])) for_ (bucketRemote (fmap rmId (Data.convRemoteMembers c))) $ notifyRemoteMembers now qUser (Data.convId c) pure $ - Intra.newPushLocal ListComplete user (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) + Intra.newPushLocal ListComplete (tUnqualified lusr) (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) <&> set Intra.pushConn conn . set Intra.pushRoute Intra.RouteDirect | otherwise -> return Nothing for_ (maybeList1 (catMaybes pp)) - (liftSem . push) + (push) -- FUTUREWORK: This could be optimized to reduce the number of RPCs -- made. When a team is deleted the burst of RPCs created here could -- lead to performance issues. We should cover this in a performance -- test. - notifyRemoteMembers :: UTCTime -> Qualified UserId -> ConvId -> Remote [UserId] -> Galley r () + notifyRemoteMembers :: UTCTime -> Qualified UserId -> ConvId -> Remote [UserId] -> Sem r () notifyRemoteMembers now qUser cid remotes = do - localDomain <- viewFederationDomain let convUpdate = ConversationUpdate { cuTime = now, @@ -593,25 +597,25 @@ rmUser user conn = do cuAlreadyPresentUsers = tUnqualified remotes, cuAction = ConversationActionRemoveMembers (pure qUser) } - let rpc = FedGalley.onConversationUpdated FedGalley.clientRoutes localDomain convUpdate - liftSem (runFederatedEither remotes rpc) + let rpc = FedGalley.onConversationUpdated FedGalley.clientRoutes (tDomain lusr) convUpdate + runFederatedEither remotes rpc >>= logAndIgnoreError "Error in onConversationUpdated call" (qUnqualified qUser) - leaveRemoteConversations :: Local UserId -> Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Galley r () - leaveRemoteConversations lusr cids = do + leaveRemoteConversations :: Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Sem r () + leaveRemoteConversations cids = do for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) let rpc = FedGalley.onUserDeleted FedGalley.clientRoutes (tDomain lusr) userDelete - liftSem (runFederatedEither remoteConvs rpc) + runFederatedEither remoteConvs rpc >>= logAndIgnoreError "Error in onUserDeleted call" (tUnqualified lusr) -- FUTUREWORK: Add a retry mechanism if there are federation errrors. -- See https://wearezeta.atlassian.net/browse/SQCORE-1091 - logAndIgnoreError :: Text -> UserId -> Either FederationError a -> Galley r () + logAndIgnoreError :: Text -> UserId -> Either FederationError a -> Sem r () logAndIgnoreError message usr res = do case res of - Left federationError -> do - Log.err + Left federationError -> + P.err ( Log.msg ( "Federation error while notifying remote backends of a user deletion (Galley). " <> message @@ -622,12 +626,13 @@ rmUser user conn = do ) Right _ -> pure () -deleteLoop :: Galley r () -deleteLoop = liftGalley0 $ do +deleteLoop :: App () +deleteLoop = do q <- view deleteQueue safeForever "deleteLoop" $ do i@(TeamItem tid usr con) <- Q.pop q - interpretGalleyToGalley0 (Teams.uncheckedDeleteTeam usr con tid) + env <- ask + liftIO (evalGalley env (doDelete usr con tid)) `catchAny` someError q i where someError q i x = do @@ -637,7 +642,11 @@ deleteLoop = liftGalley0 $ do err (msg (val "delete queue is full, dropping item") ~~ "item" .= show i) liftIO $ threadDelay 1000000 -safeForever :: String -> Galley0 () -> Galley0 () + doDelete usr con tid = do + lusr <- qualifyLocal usr + Teams.uncheckedDeleteTeam lusr con tid + +safeForever :: String -> App () -> App () safeForever funName action = forever $ action `catchAny` \exc -> do @@ -648,14 +657,16 @@ guardLegalholdPolicyConflictsH :: Members '[ BrigAccess, Error LegalHoldError, - Error InvalidInput, - TeamStore + Input Opts, + TeamStore, + P.TinyLog, + WaiRoutes ] r => (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> - Galley r Response + Sem r Response guardLegalholdPolicyConflictsH (req ::: _) = do glh <- fromJsonBody req - guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) - >>= either (const (liftSem (throw MissingLegalholdConsent))) pure + mapError @LegalholdConflicts (const MissingLegalholdConsent) $ + guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) 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 998ea8ed751..5bbe62a2362 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -44,24 +44,25 @@ import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Split (chunksOf) import Data.Misc import Data.Proxy (Proxy (Proxy)) -import Data.Qualified (qUntagged) +import Data.Qualified import Data.Range (toRange) +import Data.Time.Clock import Galley.API.Error import Galley.API.Query (iterateConversations) import Galley.API.Update (removeMemberFromLocalConv) import Galley.API.Util -import Galley.App import Galley.Cassandra.Paging import qualified Galley.Data.Conversation as Data import Galley.Effects import Galley.Effects.BrigAccess +import Galley.Effects.FireAndForget import qualified Galley.Effects.LegalHoldStore as LegalHoldData import Galley.Effects.Paging import qualified Galley.Effects.TeamFeatureStore as TeamFeatures import Galley.Effects.TeamMemberStore import Galley.Effects.TeamStore +import Galley.Effects.WaiRoutes import qualified Galley.External.LegalHoldService as LHService -import qualified Galley.Options as Opts import Galley.Types (LocalMember, lmConvRoleName, lmId) import Galley.Types.Teams as Team import Imports @@ -70,7 +71,10 @@ import Network.HTTP.Types.Status (status201, status204) import Network.Wai import Network.Wai.Predicate hiding (Error, or, result, setStatus, _3) import Network.Wai.Utilities as Wai hiding (Error) +import Polysemy import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) @@ -82,46 +86,45 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotIm import qualified Wire.API.Team.LegalHold as Public assertLegalHoldEnabledForTeam :: - Members '[Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamFeatureStore] r => + Members '[Error LegalHoldError, LegalHoldStore, TeamStore, TeamFeatureStore] r => TeamId -> - Galley r () + Sem r () assertLegalHoldEnabledForTeam tid = unlessM (isLegalHoldEnabledForTeam tid) $ - liftSem $ throw LegalHoldNotEnabled + throw LegalHoldNotEnabled isLegalHoldEnabledForTeam :: - Members '[LegalHoldStore, TeamFeatureStore] r => + Members '[LegalHoldStore, TeamStore, TeamFeatureStore] r => TeamId -> - Galley r Bool + Sem r Bool isLegalHoldEnabledForTeam tid = do - view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case + getLegalHoldFlag >>= \case FeatureLegalHoldDisabledPermanently -> do pure False FeatureLegalHoldDisabledByDefault -> do statusValue <- - liftSem $ - Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid + Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid return $ case statusValue of Just Public.TeamFeatureEnabled -> True Just Public.TeamFeatureDisabled -> False Nothing -> False FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> - liftSem $ LegalHoldData.isTeamLegalholdWhitelisted tid + LegalHoldData.isTeamLegalholdWhitelisted tid createSettingsH :: Members '[ Error ActionError, - Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, LegalHoldStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog, + WaiRoutes ] r => UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> - Galley r Response + Sem r Response createSettingsH (zusr ::: tid ::: req ::: _) = do newService <- fromJsonBody req setStatus status201 . json <$> createSettings zusr tid newService @@ -129,40 +132,37 @@ createSettingsH (zusr ::: tid ::: req ::: _) = do createSettings :: Members '[ Error ActionError, - Error InvalidInput, Error LegalHoldError, Error NotATeamMember, - Error TeamError, LegalHoldStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId -> TeamId -> Public.NewLegalHoldService -> - Galley r Public.ViewLegalHoldService + Sem r Public.ViewLegalHoldService createSettings zusr tid newService = do assertLegalHoldEnabledForTeam tid - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "LegalHold.createSettings") void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership (key :: ServiceKey, fpr :: Fingerprint Rsa) <- - LHService.validateServiceKey (newLegalHoldServiceKey newService) - >>= liftSem . note LegalHoldServiceInvalidKey + LegalHoldData.validateServiceKey (newLegalHoldServiceKey newService) + >>= note LegalHoldServiceInvalidKey LHService.checkLegalHoldServiceStatus fpr (newLegalHoldServiceUrl newService) let service = legalHoldService tid fpr newService key - liftSem $ LegalHoldData.createSettings service + LegalHoldData.createSettings service pure . viewLegalHoldService $ service getSettingsH :: Members '[ Error ActionError, - Error InvalidInput, - Error TeamError, Error NotATeamMember, LegalHoldStore, TeamFeatureStore, @@ -170,15 +170,13 @@ getSettingsH :: ] r => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid getSettings :: Members '[ Error ActionError, - Error InvalidInput, - Error TeamError, Error NotATeamMember, LegalHoldStore, TeamFeatureStore, @@ -187,12 +185,12 @@ getSettings :: r => UserId -> TeamId -> - Galley r Public.ViewLegalHoldService + Sem r Public.ViewLegalHoldService getSettings zusr tid = do - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr void $ permissionCheck (ViewTeamFeature Public.TeamFeatureLegalHold) zusrMembership isenabled <- isLegalHoldEnabledForTeam tid - mresult <- liftSem $ LegalHoldData.getSettings tid + mresult <- LegalHoldData.getSettings tid pure $ case (isenabled, mresult) of (False, _) -> Public.ViewLegalHoldServiceDisabled (True, Nothing) -> Public.ViewLegalHoldServiceNotConfigured @@ -216,22 +214,27 @@ removeSettingsH :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore, TeamFeatureStore, - TeamMemberStore InternalPaging + TeamMemberStore InternalPaging, + TeamStore, + P.TinyLog, + WaiRoutes ] r => UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> - Galley r Response + Sem r Response removeSettingsH (zusr ::: tid ::: req ::: _) = do removeSettingsRequest <- fromJsonBody req - removeSettings zusr tid removeSettingsRequest + removeSettings @InternalPaging zusr tid removeSettingsRequest pure noContent removeSettings :: + forall p r. ( Paging p, Bounded (PagingBounds p TeamMember), Members @@ -251,38 +254,41 @@ removeSettings :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, + TeamMemberStore p, TeamStore, - TeamMemberStore p + P.TinyLog ] r ) => UserId -> TeamId -> Public.RemoveLegalHoldSettingsRequest -> - Galley r () + Sem r () removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do assertNotWhitelisting assertLegalHoldEnabledForTeam tid - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "LegalHold.removeSettings") void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership ensureReAuthorised zusr mPassword - removeSettings' tid + removeSettings' @p tid where - assertNotWhitelisting :: Member (Error LegalHoldError) r => Galley r () + assertNotWhitelisting :: Sem r () assertNotWhitelisting = do - view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case + getLegalHoldFlag >>= \case FeatureLegalHoldDisabledPermanently -> pure () FeatureLegalHoldDisabledByDefault -> pure () - FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do - liftSem $ throw LegalHoldDisableUnimplemented + FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> + throw LegalHoldDisableUnimplemented -- | Remove legal hold settings from team; also disabling for all users and removing LH devices removeSettings' :: @@ -306,53 +312,56 @@ removeSettings' :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, + TeamMemberStore p, TeamStore, - TeamMemberStore p + P.TinyLog ] r ) => TeamId -> - Galley r () + Sem r () removeSettings' tid = withChunks - (\mps -> liftSem (listTeamMembers tid mps maxBound)) + (\mps -> listTeamMembers @p tid mps maxBound) action where - action :: [TeamMember] -> Galley r () + action :: [TeamMember] -> Sem r () action membs = do let zothers = map (view userId) membs let lhMembers = filter ((== UserLegalHoldEnabled) . view legalHoldStatus) membs - Log.debug $ + P.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "LegalHold.removeSettings'") spawnMany (map removeLHForUser lhMembers) - removeLHForUser :: TeamMember -> Galley r () + removeLHForUser :: TeamMember -> Sem r () removeLHForUser member = do - let uid = member ^. Team.userId - liftSem $ removeLegalHoldClientFromUser uid - LHService.removeLegalHold tid uid - changeLegalholdStatus tid uid (member ^. legalHoldStatus) UserLegalHoldDisabled -- (support for withdrawing consent is not planned yet.) + luid <- qualifyLocal (member ^. Team.userId) + removeLegalHoldClientFromUser (tUnqualified luid) + LHService.removeLegalHold tid (tUnqualified luid) + changeLegalholdStatus tid luid (member ^. legalHoldStatus) UserLegalHoldDisabled -- (support for withdrawing consent is not planned yet.) -- | 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 '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore, P.TinyLog] r => UserId ::: TeamId ::: UserId ::: JSON -> - Galley r Response + Sem r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do json <$> getUserStatus tid uid getUserStatus :: forall r. - Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore, P.TinyLog] r => TeamId -> UserId -> - Galley r Public.UserLegalHoldStatusResponse + Sem r Public.UserLegalHoldStatusResponse getUserStatus tid uid = do - teamMember <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid + teamMember <- note TeamMemberNotFound =<< getTeamMember tid uid let status = view legalHoldStatus teamMember (mlk, lcid) <- case status of UserLegalHoldNoConsent -> pure (Nothing, Nothing) @@ -361,16 +370,16 @@ getUserStatus tid uid = do UserLegalHoldEnabled -> makeResponseDetails pure $ UserLegalHoldStatusResponse status mlk lcid where - makeResponseDetails :: Galley r (Maybe LastPrekey, Maybe ClientId) + makeResponseDetails :: Sem r (Maybe LastPrekey, Maybe ClientId) makeResponseDetails = do - mLastKey <- liftSem $ fmap snd <$> LegalHoldData.selectPendingPrekeys uid + mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid lastKey <- case mLastKey of Nothing -> do - Log.err . Log.msg $ + P.err . Log.msg $ "expected to find a prekey for user: " <> toByteString' uid <> " but none was found" - liftSem $ throw NoPrekeyForUser + throw NoPrekeyForUser Just lstKey -> pure lstKey let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey pure (Just lastKey, Just clientId) @@ -380,31 +389,30 @@ getUserStatus tid uid = do -- out). grantConsentH :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response grantConsentH (zusr ::: tid ::: _) = do - grantConsent zusr tid >>= \case + lusr <- qualifyLocal zusr + grantConsent lusr tid >>= \case GrantConsentSuccess -> pure $ empty & setStatus status201 GrantConsentAlreadyGranted -> pure $ empty & setStatus status204 @@ -414,38 +422,34 @@ data GrantConsentResult grantConsent :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> TeamId -> - Galley r GrantConsentResult -grantConsent zusr tid = do + Sem r GrantConsentResult +grantConsent lusr tid = do userLHStatus <- - liftSem $ - note TeamMemberNotFound - =<< fmap (view legalHoldStatus) <$> getTeamMember tid zusr + note TeamMemberNotFound + =<< fmap (view legalHoldStatus) <$> getTeamMember tid (tUnqualified lusr) case userLHStatus of lhs@UserLegalHoldNoConsent -> - changeLegalholdStatus tid zusr lhs UserLegalHoldDisabled $> GrantConsentSuccess + changeLegalholdStatus tid lusr lhs UserLegalHoldDisabled $> GrantConsentSuccess UserLegalHoldEnabled -> pure GrantConsentAlreadyGranted UserLegalHoldPending -> pure GrantConsentAlreadyGranted UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted @@ -453,32 +457,32 @@ grantConsent zusr tid = do -- | Request to provision a device on the legal hold service for a user requestDeviceH :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, + Error NotATeamMember, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId ::: TeamId ::: UserId ::: JSON -> - Galley r Response + Sem r Response requestDeviceH (zusr ::: tid ::: uid ::: _) = do - requestDevice zusr tid uid <&> \case + luid <- qualifyLocal uid + requestDevice zusr tid luid <&> \case RequestDeviceSuccess -> empty & setStatus status201 RequestDeviceAlreadyPending -> empty & setStatus status204 @@ -489,45 +493,43 @@ data RequestDeviceResult requestDevice :: forall r. Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, + Error NotATeamMember, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId -> TeamId -> - UserId -> - Galley r RequestDeviceResult -requestDevice zusr tid uid = do + Local UserId -> + Sem r RequestDeviceResult +requestDevice zusr tid luid = do assertLegalHoldEnabledForTeam tid - Log.debug $ - Log.field "targets" (toByteString uid) + P.debug $ + Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.requestDevice") - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership - member <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid + member <- note TeamMemberNotFound =<< getTeamMember tid (tUnqualified luid) case member ^. legalHoldStatus of - UserLegalHoldEnabled -> liftSem $ throw UserLegalHoldAlreadyEnabled + UserLegalHoldEnabled -> throw UserLegalHoldAlreadyEnabled lhs@UserLegalHoldPending -> RequestDeviceAlreadyPending <$ provisionLHDevice lhs lhs@UserLegalHoldDisabled -> RequestDeviceSuccess <$ provisionLHDevice lhs - UserLegalHoldNoConsent -> liftSem $ throw NoUserLegalHoldConsent + UserLegalHoldNoConsent -> 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: @@ -536,18 +538,18 @@ requestDevice zusr tid uid = do -- This will still work if the LH service creates two new device on two consecutive calls -- to `/init`, but there may be race conditions, eg. when updating and enabling a pending -- device at (almost) the same time. - provisionLHDevice :: UserLegalHoldStatus -> Galley r () + provisionLHDevice :: UserLegalHoldStatus -> Sem r () provisionLHDevice userLHStatus = do (lastPrekey', prekeys) <- requestDeviceFromService -- We don't distinguish the last key here; brig will do so when the device is added - liftSem $ LegalHoldData.insertPendingPrekeys uid (unpackLastPrekey lastPrekey' : prekeys) - changeLegalholdStatus tid uid userLHStatus UserLegalHoldPending - liftSem $ notifyClientsAboutLegalHoldRequest zusr uid lastPrekey' + LegalHoldData.insertPendingPrekeys (tUnqualified luid) (unpackLastPrekey lastPrekey' : prekeys) + changeLegalholdStatus tid luid userLHStatus UserLegalHoldPending + notifyClientsAboutLegalHoldRequest zusr (tUnqualified luid) lastPrekey' - requestDeviceFromService :: Galley r (LastPrekey, [Prekey]) + requestDeviceFromService :: Sem r (LastPrekey, [Prekey]) requestDeviceFromService = do - liftSem $ LegalHoldData.dropPendingPrekeys uid - lhDevice <- LHService.requestNewDevice tid uid + LegalHoldData.dropPendingPrekeys (tUnqualified luid) + lhDevice <- LHService.requestNewDevice tid (tUnqualified luid) let NewLegalHoldClient prekeys lastKey = lhDevice return (lastKey, prekeys) @@ -558,99 +560,95 @@ requestDevice zusr tid uid = do -- since they are replaced if needed when registering new LH devices. approveDeviceH :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error AuthenticationError, Error ConversationError, - Error FederationError, Error LegalHoldError, Error NotATeamMember, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog, + WaiRoutes ] r => UserId ::: TeamId ::: UserId ::: ConnId ::: JsonRequest Public.ApproveLegalHoldForUserRequest ::: JSON -> - Galley r Response + Sem r Response approveDeviceH (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do + luid <- qualifyLocal uid approve <- fromJsonBody req - approveDevice zusr tid uid connId approve + approveDevice zusr tid luid connId approve pure empty approveDevice :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error AuthenticationError, Error ConversationError, - Error FederationError, Error LegalHoldError, Error NotATeamMember, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId -> TeamId -> - UserId -> + Local UserId -> ConnId -> Public.ApproveLegalHoldForUserRequest -> - Galley r () -approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPassword) = do + Sem r () +approveDevice zusr tid luid connId (Public.ApproveLegalHoldForUserRequest mPassword) = do assertLegalHoldEnabledForTeam tid - Log.debug $ - Log.field "targets" (toByteString uid) + P.debug $ + Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.approveDevice") - liftSem . unless (zusr == uid) $ throw AccessDenied - assertOnTeam uid tid + unless (zusr == tUnqualified luid) $ throw AccessDenied + assertOnTeam (tUnqualified luid) tid ensureReAuthorised zusr mPassword userLHStatus <- - liftSem $ - maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid uid + maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid (tUnqualified luid) assertUserLHPending userLHStatus - mPreKeys <- liftSem $ LegalHoldData.selectPendingPrekeys uid + mPreKeys <- LegalHoldData.selectPendingPrekeys (tUnqualified luid) (prekeys, lastPrekey') <- case mPreKeys of Nothing -> do - Log.info $ Log.msg @Text "No prekeys found" - liftSem $ throw NoLegalHoldDeviceAllocated + P.info $ Log.msg @Text "No prekeys found" + throw NoLegalHoldDeviceAllocated Just keys -> pure keys - clientId <- liftSem $ addLegalHoldClientToUser uid connId prekeys lastPrekey' + clientId <- addLegalHoldClientToUser (tUnqualified luid) connId prekeys lastPrekey' -- Note: teamId could be passed in the getLegalHoldAuthToken request instead of lookup up again -- Note: both 'getLegalHoldToken' and 'ensureReAuthorized' check the password -- Note: both 'getLegalHoldToken' and this function in 'assertOnTeam' above -- checks that the user is part of a binding team -- FUTUREWORK: reduce double checks - legalHoldAuthToken <- liftSem $ getLegalHoldAuthToken uid mPassword - LHService.confirmLegalHold clientId tid uid legalHoldAuthToken + legalHoldAuthToken <- getLegalHoldAuthToken (tUnqualified luid) mPassword + LHService.confirmLegalHold clientId tid (tUnqualified luid) legalHoldAuthToken -- TODO: send event at this point (see also: -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) - changeLegalholdStatus tid uid userLHStatus UserLegalHoldEnabled + changeLegalholdStatus tid luid userLHStatus UserLegalHoldEnabled where - assertUserLHPending :: Member (Error LegalHoldError) r => UserLegalHoldStatus -> Galley r () - assertUserLHPending userLHStatus = liftSem $ do + assertUserLHPending :: Member (Error LegalHoldError) r => UserLegalHoldStatus -> Sem r () + assertUserLHPending userLHStatus = do case userLHStatus of UserLegalHoldEnabled -> throw UserLegalHoldAlreadyEnabled UserLegalHoldPending -> pure () @@ -659,33 +657,33 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo disableForUserH :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error AuthenticationError, Error ConversationError, - Error FederationError, Error LegalHoldError, Error NotATeamMember, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, + Input (Local ()), LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + P.TinyLog, + WaiRoutes ] r => UserId ::: TeamId ::: UserId ::: JsonRequest Public.DisableLegalHoldForUserRequest ::: JSON -> - Galley r Response + Sem r Response disableForUserH (zusr ::: tid ::: uid ::: req ::: _) = do + luid <- qualifyLocal uid disable <- fromJsonBody req - disableForUser zusr tid uid disable <&> \case + disableForUser zusr tid luid disable <&> \case DisableLegalHoldSuccess -> empty DisableLegalHoldWasNotEnabled -> noContent @@ -696,168 +694,162 @@ data DisableLegalHoldForUserResponse disableForUser :: forall r. Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error AuthenticationError, Error ConversationError, - Error FederationError, Error LegalHoldError, Error NotATeamMember, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId -> TeamId -> - UserId -> + Local UserId -> Public.DisableLegalHoldForUserRequest -> - Galley r DisableLegalHoldForUserResponse -disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = do - Log.debug $ - Log.field "targets" (toByteString uid) + Sem r DisableLegalHoldForUserResponse +disableForUser zusr tid luid (Public.DisableLegalHoldForUserRequest mPassword) = do + P.debug $ + Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.disableForUser") - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership userLHStatus <- - liftSem $ - maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid uid + maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid (tUnqualified luid) if not $ userLHEnabled userLHStatus then pure DisableLegalHoldWasNotEnabled else disableLH userLHStatus $> DisableLegalHoldSuccess where - disableLH :: UserLegalHoldStatus -> Galley r () + disableLH :: UserLegalHoldStatus -> Sem r () disableLH userLHStatus = do ensureReAuthorised zusr mPassword - liftSem $ removeLegalHoldClientFromUser uid - LHService.removeLegalHold tid uid + removeLegalHoldClientFromUser (tUnqualified luid) + LHService.removeLegalHold tid (tUnqualified luid) -- TODO: send event at this point (see also: related TODO in this module in -- 'approveDevice' and -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) - changeLegalholdStatus tid uid userLHStatus UserLegalHoldDisabled + changeLegalholdStatus tid luid userLHStatus UserLegalHoldDisabled -- | Allow no-consent => consent without further changes. If LH device is requested, enabled, -- or disabled, make sure the affected connections are screened for policy conflict (anybody -- with no-consent), and put those connections in the appropriate blocked state. changeLegalholdStatus :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ BrigAccess, ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, Error LegalHoldError, - Error NotATeamMember, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => TeamId -> - UserId -> + Local UserId -> UserLegalHoldStatus -> UserLegalHoldStatus -> - Galley r () -changeLegalholdStatus tid uid old new = do + Sem r () +changeLegalholdStatus tid luid old new = do case old of UserLegalHoldEnabled -> case new of UserLegalHoldEnabled -> noop UserLegalHoldPending -> illegal - UserLegalHoldDisabled -> liftSem update >> removeblocks + UserLegalHoldDisabled -> update >> removeblocks UserLegalHoldNoConsent -> illegal -- UserLegalHoldPending -> case new of - UserLegalHoldEnabled -> liftSem update + UserLegalHoldEnabled -> update UserLegalHoldPending -> noop - UserLegalHoldDisabled -> liftSem update >> removeblocks + UserLegalHoldDisabled -> update >> removeblocks UserLegalHoldNoConsent -> illegal -- UserLegalHoldDisabled -> case new of UserLegalHoldEnabled -> illegal - UserLegalHoldPending -> addblocks >> liftSem update + UserLegalHoldPending -> addblocks >> update UserLegalHoldDisabled -> {- in case the last attempt crashed -} removeblocks UserLegalHoldNoConsent -> {- withdrawing consent is not (yet?) implemented -} illegal -- UserLegalHoldNoConsent -> case new of UserLegalHoldEnabled -> illegal UserLegalHoldPending -> illegal - UserLegalHoldDisabled -> liftSem update + UserLegalHoldDisabled -> update UserLegalHoldNoConsent -> noop where - update = LegalHoldData.setUserLegalHoldStatus tid uid new - removeblocks = void . liftSem $ putConnectionInternal (RemoveLHBlocksInvolving uid) + update = LegalHoldData.setUserLegalHoldStatus tid (tUnqualified luid) new + removeblocks = void $ putConnectionInternal (RemoveLHBlocksInvolving (tUnqualified luid)) addblocks = do - blockNonConsentingConnections uid - handleGroupConvPolicyConflicts uid new + blockNonConsentingConnections (tUnqualified luid) + handleGroupConvPolicyConflicts luid new noop = pure () - illegal = liftSem $ throw UserLegalHoldIllegalOperation + illegal = throw UserLegalHoldIllegalOperation -- FUTUREWORK: make this async? blockNonConsentingConnections :: forall r. - Members '[BrigAccess, Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamStore] r => + Members + '[ BrigAccess, + Error LegalHoldError, + TeamStore, + P.TinyLog + ] + r => UserId -> - Galley r () + Sem r () blockNonConsentingConnections uid = do - conns <- liftSem $ getConnectionsUnqualified [uid] Nothing Nothing + conns <- getConnectionsUnqualified [uid] Nothing Nothing errmsgs <- do conflicts <- mconcat <$> findConflicts conns blockConflicts uid conflicts case mconcat errmsgs of [] -> pure () msgs@(_ : _) -> do - Log.warn $ Log.msg @String msgs - liftSem $ throw LegalHoldCouldNotBlockConnections + P.warn $ Log.msg @String msgs + throw LegalHoldCouldNotBlockConnections where - findConflicts :: [ConnectionStatus] -> Galley r [[UserId]] + findConflicts :: [ConnectionStatus] -> Sem r [[UserId]] findConflicts conns = do let (FutureWork @'Public.LegalholdPlusFederationNotImplemented -> _remoteUids, localUids) = (undefined, csTo <$> conns) -- FUTUREWORK: Handle remoteUsers here when federation is implemented for (chunksOf 32 localUids) $ \others -> do - teamsOfUsers <- liftSem $ getUsersTeams others + teamsOfUsers <- getUsersTeams others filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others - blockConflicts :: UserId -> [UserId] -> Galley r [String] + blockConflicts :: UserId -> [UserId] -> Sem r [String] blockConflicts _ [] = pure [] blockConflicts userLegalhold othersToBlock@(_ : _) = do - status <- liftSem $ putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) + status <- putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) pure $ ["blocking users failed: " <> show (status, othersToBlock) | status /= status200] -setTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Galley r () -setTeamLegalholdWhitelisted tid = - liftSem $ - LegalHoldData.setTeamLegalholdWhitelisted tid +setTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Sem r () +setTeamLegalholdWhitelisted tid = LegalHoldData.setTeamLegalholdWhitelisted tid -setTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response +setTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Sem r Response setTeamLegalholdWhitelistedH tid = do empty <$ setTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Galley r () -unsetTeamLegalholdWhitelisted tid = - liftSem $ - LegalHoldData.unsetTeamLegalholdWhitelisted tid +unsetTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Sem r () +unsetTeamLegalholdWhitelisted tid = LegalHoldData.unsetTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response +unsetTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Sem r Response unsetTeamLegalholdWhitelistedH tid = do () <- error @@ -866,8 +858,8 @@ unsetTeamLegalholdWhitelistedH tid = do \before you enable the end-point." setStatus status204 empty <$ unsetTeamLegalholdWhitelisted tid -getTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response -getTeamLegalholdWhitelistedH tid = liftSem $ do +getTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Sem r Response +getTeamLegalholdWhitelistedH tid = do lhEnabled <- LegalHoldData.isTeamLegalholdWhitelisted tid pure $ if lhEnabled @@ -890,31 +882,25 @@ getTeamLegalholdWhitelistedH tid = liftSem $ do -- one from the database. handleGroupConvPolicyConflicts :: Members - '[ BotAccess, - BrigAccess, - CodeStore, - ConversationStore, + '[ ConversationStore, Error ActionError, Error InvalidInput, Error ConversationError, - Error FederationError, - Error TeamError, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, - LegalHoldStore, + Input UTCTime, ListItems LegacyPaging ConvId, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> UserLegalHoldStatus -> - Galley r () -handleGroupConvPolicyConflicts uid hypotheticalLHStatus = + Sem r () +handleGroupConvPolicyConflicts luid hypotheticalLHStatus = do void $ - iterateConversations uid (toRange (Proxy @500)) $ \convs -> do + iterateConversations luid (toRange (Proxy @500)) $ \convs -> do for_ (filter ((== RegularConv) . Data.convType) convs) $ \conv -> do let FutureWork _convRemoteMembers' = FutureWork @'LegalholdPlusFederationNotImplemented Data.convRemoteMembers @@ -925,22 +911,22 @@ handleGroupConvPolicyConflicts uid hypotheticalLHStatus = zipWith ( \mem (mid, status) -> assert (lmId mem == mid) $ - if lmId mem == uid + if lmId mem == tUnqualified luid then (mem, hypotheticalLHStatus) else (mem, status) ) mems uidsLHStatus - lcnv <- qualifyLocal (Data.convId conv) + let lcnv = qualifyAs luid (Data.convId conv) if any ((== ConsentGiven) . consentGiven . snd) (filter ((== roleNameWireAdmin) . lmConvRoleName . fst) membersAndLHStatus) then do for_ (filter ((== ConsentNotGiven) . consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do - lusr <- qualifyLocal (lmId memberNoConsent) + let lusr = qualifyAs luid (lmId memberNoConsent) removeMemberFromLocalConv lcnv lusr Nothing (qUntagged lusr) else do for_ (filter (userLHEnabled . snd) membersAndLHStatus) $ \(legalholder, _) -> do - lusr <- qualifyLocal (lmId legalholder) + let lusr = qualifyAs luid (lmId legalholder) removeMemberFromLocalConv lcnv lusr Nothing (qUntagged lusr) diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index 11995a36faf..e70937ccd72 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -19,22 +19,24 @@ module Galley.API.LegalHold.Conflicts where import Brig.Types.Intra (accountUser) import Control.Lens (view) -import Control.Monad.Error.Class (throwError) -import Control.Monad.Trans.Except (runExceptT) import Data.ByteString.Conversion (toByteString') import Data.Id import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import qualified Data.Map as Map import Data.Misc +import Data.Qualified import qualified Data.Set as Set import Galley.API.Util -import Galley.App import Galley.Effects import Galley.Effects.BrigAccess import Galley.Effects.TeamStore import Galley.Options import Galley.Types.Teams hiding (self) import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Log import Wire.API.Team.LegalHold import Wire.API.User @@ -43,12 +45,20 @@ import Wire.API.User.Client as Client data LegalholdConflicts = LegalholdConflicts guardQualifiedLegalholdPolicyConflicts :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error LegalholdConflicts, + Input (Local ()), + Input Opts, + TeamStore, + P.TinyLog + ] + r => LegalholdProtectee -> QualifiedUserClients -> - Galley r (Either LegalholdConflicts ()) + Sem r () guardQualifiedLegalholdPolicyConflicts protectee qclients = do - localDomain <- viewFederationDomain + localDomain <- tDomain <$> qualifyLocal () guardLegalholdPolicyConflicts protectee . UserClients . Map.findWithDefault mempty localDomain @@ -62,26 +72,40 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do -- This is a fallback safeguard that shouldn't get triggered if backend and clients work as -- intended. guardLegalholdPolicyConflicts :: - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error LegalholdConflicts, + Input Opts, + TeamStore, + P.TinyLog + ] + r => LegalholdProtectee -> UserClients -> - Galley r (Either LegalholdConflicts ()) -guardLegalholdPolicyConflicts LegalholdPlusFederationNotImplemented _otherClients = pure . pure $ () -guardLegalholdPolicyConflicts UnprotectedBot _otherClients = pure . pure $ () + Sem r () +guardLegalholdPolicyConflicts LegalholdPlusFederationNotImplemented _otherClients = pure () +guardLegalholdPolicyConflicts UnprotectedBot _otherClients = pure () guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do - view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case + opts <- input + case view (optSettings . setFeatureFlags . flagLegalHold) opts of FeatureLegalHoldDisabledPermanently -> case FutureWork @'LegalholdPlusFederationNotImplemented () of - FutureWork () -> pure . pure $ () -- FUTUREWORK: if federation is enabled, we still need to run the guard! + FutureWork () -> pure () -- FUTUREWORK: if federation is enabled, we still need to run the guard! FeatureLegalHoldDisabledByDefault -> guardLegalholdPolicyConflictsUid self otherClients FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> guardLegalholdPolicyConflictsUid self otherClients guardLegalholdPolicyConflictsUid :: forall r. - Members '[BrigAccess, TeamStore] r => + Members + '[ BrigAccess, + Error LegalholdConflicts, + TeamStore, + P.TinyLog + ] + r => UserId -> UserClients -> - Galley r (Either LegalholdConflicts ()) -guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do + Sem r () +guardLegalholdPolicyConflictsUid self otherClients = do let otherCids :: [ClientId] otherCids = Set.toList . Set.unions . Map.elems . userClients $ otherClients @@ -89,7 +113,7 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do otherUids = nub $ Map.keys . userClients $ otherClients when (nub otherUids /= [self {- if all other clients belong to us, there can be no conflict -}]) $ do - allClients :: UserClientsFull <- lift . liftSem $ lookupClientsFull (nub $ self : otherUids) + allClients :: UserClientsFull <- lookupClientsFull (nub $ self : otherUids) let selfClients :: [Client.Client] = allClients @@ -124,8 +148,8 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do . Client.fromClientCapabilityList . Client.clientCapabilities - checkConsentMissing :: Galley r Bool - checkConsentMissing = liftSem $ do + checkConsentMissing :: Sem r Bool + checkConsentMissing = do -- (we could also get the profile from brig. would make the code slightly more -- concise, but not really help with the rpc back-and-forth, so, like, why?) mbUser <- accountUser <$$> getUser self @@ -133,25 +157,24 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do let lhStatus = maybe defUserLegalHoldStatus (view legalHoldStatus) mbTeamMember pure (lhStatus == UserLegalHoldNoConsent) - lift $ - Log.debug $ - Log.field "self" (toByteString' self) - Log.~~ Log.field "otherClients" (toByteString' $ show otherClients) - Log.~~ Log.field "otherClientHasLH" (toByteString' otherClientHasLH) - Log.~~ Log.field "checkSelfHasOldClients" (toByteString' checkSelfHasOldClients) - Log.~~ Log.field "checkSelfHasLHClients" (toByteString' checkSelfHasLHClients) - Log.~~ Log.msg ("guardLegalholdPolicyConflicts[1]" :: Text) + P.debug $ + Log.field "self" (toByteString' self) + Log.~~ Log.field "otherClients" (toByteString' $ show otherClients) + Log.~~ Log.field "otherClientHasLH" (toByteString' otherClientHasLH) + Log.~~ Log.field "checkSelfHasOldClients" (toByteString' checkSelfHasOldClients) + Log.~~ Log.field "checkSelfHasLHClients" (toByteString' checkSelfHasLHClients) + Log.~~ Log.msg ("guardLegalholdPolicyConflicts[1]" :: Text) -- (I've tried to order the following checks for minimum IO; did it work? ~~fisx) when otherClientHasLH $ do when checkSelfHasOldClients $ do - lift $ Log.debug $ Log.msg ("guardLegalholdPolicyConflicts[2]: old clients" :: Text) - throwError LegalholdConflicts + P.debug $ Log.msg ("guardLegalholdPolicyConflicts[2]: old clients" :: Text) + throw LegalholdConflicts unless checkSelfHasLHClients {- carrying a LH device implies having granted LH consent -} $ do - whenM (lift checkConsentMissing) $ do + whenM checkConsentMissing $ do -- We assume this is impossible, since conversations are automatically -- blocked if LH consent is missing of any participant. -- We add this check here as an extra failsafe. - lift $ Log.debug $ Log.msg ("guardLegalholdPolicyConflicts[3]: consent missing" :: Text) - throwError LegalholdConflicts + P.debug $ Log.msg ("guardLegalholdPolicyConflicts[3]: consent missing" :: Text) + throw LegalholdConflicts diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index 3d193b2f6c8..e972a092041 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -30,15 +30,13 @@ 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 Polysemy import Polysemy.Error -import qualified System.Logger.Class as Log +import qualified Polysemy.TinyLog as P import System.Logger.Message (msg, val, (+++)) import Wire.API.Conversation hiding (Member (..)) import qualified Wire.API.Conversation as Conversation @@ -48,22 +46,21 @@ import Wire.API.Federation.API.Galley -- -- Throws "bad-state" when the user is not part of the conversation. conversationView :: - Member (Error InternalError) r => - UserId -> + Members '[Error InternalError, P.TinyLog] r => + Local UserId -> Data.Conversation -> - Galley r Conversation -conversationView uid conv = do - luid <- qualifyLocal uid + Sem r Conversation +conversationView luid conv = do let mbConv = conversationViewMaybe luid conv maybe memberNotFound pure mbConv where memberNotFound = do - Log.err . msg $ + P.err . msg $ val "User " - +++ idToText uid + +++ idToText (tUnqualified luid) +++ val " is not a member of conv " +++ idToText (convId conv) - liftSem $ throw BadMemberState + throw BadMemberState -- | View for a given user of a stored conversation. -- @@ -83,16 +80,12 @@ conversationViewMaybe luid conv = do (ConvMembers self others) -- | View for a local user of a remote conversation. --- --- If the local user is not actually present in the conversation, simply --- discard the conversation altogether. This should only happen if the remote --- backend is misbehaving. remoteConversationView :: Local UserId -> MemberStatus -> Remote RemoteConversation -> - Maybe Conversation -remoteConversationView uid status (qUntagged -> Qualified rconv rDomain) = do + Conversation +remoteConversationView uid status (qUntagged -> Qualified rconv rDomain) = let mems = rcnvMembers rconv others = rcmOthers mems self = @@ -104,7 +97,7 @@ remoteConversationView uid status (qUntagged -> Qualified rconv rDomain) = do lmStatus = status, lmConvRoleName = rcmSelfRole mems } - pure $ Conversation (Qualified (rcnvId rconv) rDomain) (rcnvMetadata rconv) (ConvMembers self others) + in Conversation (Qualified (rcnvId rconv) rDomain) (rcnvMetadata rconv) (ConvMembers self others) -- | Convert a local conversation to a structure to be returned to a remote -- backend. diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 4bd82de30d7..4d32905836d 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -20,10 +20,9 @@ import Data.Map.Lens (toMapOf) import Data.Qualified import qualified Data.Set as Set import Data.Set.Lens -import Data.Time.Clock (UTCTime, getCurrentTime) -import Galley.API.LegalHold.Conflicts (guardQualifiedLegalholdPolicyConflicts) +import Data.Time.Clock (UTCTime) +import Galley.API.LegalHold.Conflicts import Galley.API.Util -import Galley.App import Galley.Data.Services as Data import Galley.Effects import Galley.Effects.BrigAccess @@ -34,11 +33,15 @@ import Galley.Effects.FederatorAccess import Galley.Effects.GundeckAccess hiding (Push) import Galley.Effects.MemberStore import Galley.Intra.Push -import Galley.Options (optSettings, setIntraListing) +import Galley.Options import qualified Galley.Types.Clients as Clients import Galley.Types.Conversations.Members import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports hiding (forkIO) +import Polysemy +import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Log import Wire.API.Event.Conversation import qualified Wire.API.Federation.API.Brig as FederatedBrig @@ -181,23 +184,22 @@ checkMessageClients sender participantMap recipientMap mismatchStrat = getRemoteClients :: Member FederatorAccess r => [RemoteMember] -> - Galley r (Map (Domain, UserId) (Set ClientId)) + Sem r (Map (Domain, UserId) (Set ClientId)) getRemoteClients remoteMembers = -- concatenating maps is correct here, because their sets of keys are disjoint - liftSem $ - mconcat . map tUnqualified - <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain + mconcat . map tUnqualified + <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain where getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap <$> FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) postRemoteOtrMessage :: - Members '[ConversationStore, FederatorAccess] r => + Members '[FederatorAccess] r => Qualified UserId -> Remote ConvId -> LByteString -> - Galley r (PostOtrResponse MessageSendingStatus) + Sem r (PostOtrResponse MessageSendingStatus) postRemoteOtrMessage sender conv rawMsg = do let msr = FederatedGalley.MessageSendRequest @@ -206,42 +208,45 @@ postRemoteOtrMessage sender conv rawMsg = do FederatedGalley.msrRawMessage = Base64ByteString rawMsg } rpc = FederatedGalley.sendMessage FederatedGalley.clientRoutes (qDomain sender) msr - liftSem $ FederatedGalley.msResponse <$> runFederated conv rpc + FederatedGalley.msResponse <$> runFederated conv rpc postQualifiedOtrMessage :: Members - '[ BotAccess, - BrigAccess, + '[ BrigAccess, ClientStore, ConversationStore, FederatorAccess, GundeckAccess, ExternalAccess, + Input (Local ()), -- FUTUREWORK: remove this + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserType -> Qualified UserId -> Maybe ConnId -> - ConvId -> + Local ConvId -> QualifiedNewOtrMessage -> - Galley r (PostOtrResponse MessageSendingStatus) -postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do - alive <- lift . liftSem $ isConversationAlive convId - localDomain <- viewFederationDomain - now <- liftIO getCurrentTime + Sem r (PostOtrResponse MessageSendingStatus) +postQualifiedOtrMessage senderType sender mconn lcnv msg = runExceptT $ do + alive <- lift $ isConversationAlive (tUnqualified lcnv) + let localDomain = tDomain lcnv + now <- lift $ input let nowMillis = toUTCTimeMillis now let senderDomain = qDomain sender senderUser = qUnqualified sender let senderClient = qualifiedNewOtrSender msg unless alive $ do - lift . liftSem $ deleteConversation convId + lift $ deleteConversation (tUnqualified lcnv) throwError MessageNotSentConversationNotFound -- conversation members - localMembers <- lift . liftSem $ getLocalMembers convId - remoteMembers <- lift . liftSem $ getRemoteMembers convId + localMembers <- lift $ getLocalMembers (tUnqualified lcnv) + remoteMembers <- lift $ getRemoteMembers (tUnqualified lcnv) let localMemberIds = lmId <$> localMembers localMemberMap :: Map UserId LocalMember @@ -250,7 +255,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do members = Set.map (`Qualified` localDomain) (Map.keysSet localMemberMap) <> Set.fromList (map (qUntagged . rmId) remoteMembers) - isInternal <- view $ options . optSettings . setIntraListing + isInternal <- lift $ view (optSettings . setIntraListing) <$> input -- check if the sender is part of the conversation unless (Set.member sender members) $ @@ -258,7 +263,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- get local clients localClients <- - lift . liftSem $ + lift $ if isInternal then Clients.fromUserClients <$> lookupClients localMemberIds else getClients localMemberIds @@ -292,10 +297,13 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do missingClients = qmMissing mismatch legalholdErr = pure MessageNotSentLegalhold clientMissingErr = pure $ MessageNotSentClientMissing otrResult - guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients - & eitherM (const legalholdErr) (const clientMissingErr) - & lift - >>= throwError + e <- + lift + . runLocalInput lcnv + . eitherM (const legalholdErr) (const clientMissingErr) + . runError @LegalholdConflicts + $ guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients + throwError e failedToSend <- lift $ @@ -304,7 +312,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do sender senderClient mconn - convId + lcnv localMemberMap (qualifiedNewOtrMetadata msg) validMessages @@ -316,24 +324,25 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- | Send both local and remote messages, return the set of clients for which -- sending has failed. sendMessages :: - Members '[BotAccess, GundeckAccess, ExternalAccess, FederatorAccess] r => + Members '[GundeckAccess, ExternalAccess, FederatorAccess, Input (Local ()), P.TinyLog] r => + -- FUTUREWORK: remove Input (Local ()) effect UTCTime -> Qualified UserId -> ClientId -> Maybe ConnId -> - ConvId -> + Local ConvId -> Map UserId LocalMember -> MessageMetadata -> Map (Domain, UserId, ClientId) ByteString -> - Galley r QualifiedUserClients -sendMessages now sender senderClient mconn conv localMemberMap metadata messages = do - localDomain <- viewFederationDomain + Sem r QualifiedUserClients +sendMessages now sender senderClient mconn lcnv localMemberMap metadata messages = do let messageMap = byDomain $ fmap toBase64Text messages - let send dom - | localDomain == dom = - sendLocalMessages now sender senderClient mconn (Qualified conv localDomain) localMemberMap metadata - | otherwise = - sendRemoteMessages (toRemoteUnsafe dom ()) now sender senderClient conv metadata + let send dom = + foldQualified + lcnv + (\_ -> sendLocalMessages now sender senderClient mconn (qUntagged lcnv) localMemberMap metadata) + (\r -> sendRemoteMessages r now sender senderClient lcnv metadata) + (Qualified () dom) mkQualifiedUserClientsByDomain <$> Map.traverseWithKey send messageMap where @@ -344,7 +353,7 @@ sendMessages now sender senderClient mconn conv localMemberMap metadata messages mempty sendLocalMessages :: - Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Members '[GundeckAccess, ExternalAccess, Input (Local ()), P.TinyLog] r => UTCTime -> Qualified UserId -> ClientId -> @@ -353,35 +362,35 @@ sendLocalMessages :: Map UserId LocalMember -> MessageMetadata -> Map (UserId, ClientId) Text -> - Galley r (Set (UserId, ClientId)) -sendLocalMessages now sender senderClient mconn conv localMemberMap metadata localMessages = do - localDomain <- viewFederationDomain + Sem r (Set (UserId, ClientId)) +sendLocalMessages now sender senderClient mconn qcnv localMemberMap metadata localMessages = do + loc <- qualifyLocal () let events = localMessages & reindexed snd itraversed %@~ newMessageEvent - conv + qcnv sender senderClient (mmData metadata) now pushes = events & itraversed - %@~ newMessagePush localDomain localMemberMap mconn metadata - runMessagePush conv (pushes ^. traversed) + %@~ newMessagePush loc localMemberMap mconn metadata + runMessagePush qcnv (pushes ^. traversed) pure mempty sendRemoteMessages :: forall r x. - Member FederatorAccess r => + Members '[FederatorAccess, P.TinyLog] r => Remote x -> UTCTime -> Qualified UserId -> ClientId -> - ConvId -> + Local ConvId -> MessageMetadata -> Map (UserId, ClientId) Text -> - Galley r (Set (UserId, ClientId)) -sendRemoteMessages domain now sender senderClient conv metadata messages = (handle =<<) $ do + Sem r (Set (UserId, ClientId)) +sendRemoteMessages domain now sender senderClient lcnv metadata messages = (handle =<<) $ do let rcpts = foldr (\((u, c), t) -> Map.insertWith (<>) u (Map.singleton c t)) @@ -393,23 +402,20 @@ sendRemoteMessages domain now sender senderClient conv metadata messages = (hand FederatedGalley.rmData = mmData metadata, FederatedGalley.rmSender = sender, FederatedGalley.rmSenderClient = senderClient, - FederatedGalley.rmConversation = conv, + FederatedGalley.rmConversation = tUnqualified lcnv, FederatedGalley.rmPriority = mmNativePriority metadata, FederatedGalley.rmPush = mmNativePush metadata, FederatedGalley.rmTransient = mmTransient metadata, FederatedGalley.rmRecipients = UserClientMap rcpts } - -- Semantically, the origin domain should be the converation domain. Here one - -- backend has only one domain so we just pick it from the environment. - originDomain <- viewFederationDomain - let rpc = FederatedGalley.onMessageSent FederatedGalley.clientRoutes originDomain rm - liftSem $ runFederatedEither domain rpc + let rpc = FederatedGalley.onMessageSent FederatedGalley.clientRoutes (tDomain lcnv) rm + runFederatedEither domain rpc where - handle :: Either FederationError a -> Galley r (Set (UserId, ClientId)) + handle :: Either FederationError a -> Sem r (Set (UserId, ClientId)) handle (Right _) = pure mempty handle (Left e) = do - Log.warn $ - Log.field "conversation" (toByteString' conv) + P.warn $ + Log.field "conversation" (toByteString' (tUnqualified lcnv)) Log.~~ Log.field "domain" (toByteString' (tDomain domain)) Log.~~ Log.field "exception" (encode (federationErrorToWai e)) Log.~~ Log.msg ("Remote message sending failed" :: Text) @@ -445,21 +451,21 @@ newBotPush b e = MessagePush {userPushes = mempty, botPushes = pure (b, e)} runMessagePush :: forall r. - Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Members '[GundeckAccess, ExternalAccess, Input (Local ()), P.TinyLog] r => Qualified ConvId -> MessagePush -> - Galley r () -runMessagePush cnv mp = do - liftSem $ push (userPushes mp) + Sem r () +runMessagePush qcnv mp = do + push (userPushes mp) pushToBots (botPushes mp) where - pushToBots :: [(BotMember, Event)] -> Galley r () + pushToBots :: [(BotMember, Event)] -> Sem r () pushToBots pushes = do - localDomain <- viewFederationDomain - if localDomain /= qDomain cnv + localDomain <- tDomain <$> qualifyLocal () + if localDomain /= qDomain qcnv then unless (null pushes) $ do - Log.warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show cnv) - else liftSem $ deliverAndDeleteAsync (qUnqualified cnv) pushes + P.warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show qcnv) + else deliverAndDeleteAsync (qUnqualified qcnv) pushes newMessageEvent :: Qualified ConvId -> Qualified UserId -> ClientId -> Maybe Text -> UTCTime -> ClientId -> Text -> Event newMessageEvent convId sender senderClient dat time receiverClient cipherText = @@ -473,14 +479,14 @@ newMessageEvent convId sender senderClient dat time receiverClient cipherText = newMessagePush :: Ord k => - Domain -> + Local x -> Map k LocalMember -> Maybe ConnId -> MessageMetadata -> (k, ClientId) -> Event -> MessagePush -newMessagePush localDomain members mconn mm (k, client) e = fromMaybe mempty $ do +newMessagePush loc members mconn mm (k, client) e = fromMaybe mempty $ do member <- Map.lookup k members newBotMessagePush member <|> newUserMessagePush member where @@ -489,7 +495,7 @@ newMessagePush localDomain members mconn mm (k, client) e = fromMaybe mempty $ d newUserMessagePush :: LocalMember -> Maybe MessagePush newUserMessagePush member = fmap newUserPush $ - newConversationEventPush localDomain e [lmId member] + newConversationEventPush e (qualifyAs loc [lmId member]) <&> set pushConn mconn . set pushNativePriority (mmNativePriority mm) . set pushRoute (bool RouteDirect RouteAny (mmNativePush mm)) diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs index 1458e9c464c..348da8c1d05 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/services/galley/src/Galley/API/One2One.hs @@ -24,7 +24,6 @@ where import Data.Id import Data.Qualified -import Galley.App (Galley, liftSem) import Galley.Data.Conversation import Galley.Effects.ConversationStore import Galley.Effects.MemberStore @@ -38,8 +37,8 @@ iUpsertOne2OneConversation :: forall r. Members '[ConversationStore, MemberStore] r => UpsertOne2OneConversationRequest -> - Galley r UpsertOne2OneConversationResponse -iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = liftSem $ do + Sem r UpsertOne2OneConversationResponse +iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do let convId = fromMaybe (one2OneConvId (qUntagged uooLocalUser) (qUntagged uooRemoteUser)) uooConvId let dolocal :: Local ConvId -> Sem r () diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index e4213142718..3027ba070ab 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -41,6 +41,7 @@ import Galley.API.Teams.Features (DoAuth (..), getFeatureStatus, setFeatureStatu import qualified Galley.API.Teams.Features as Features import qualified Galley.API.Update as Update import Galley.App +import Galley.Cassandra.Paging import Imports hiding (head) import Network.HTTP.Types import Network.Wai @@ -51,6 +52,7 @@ import Network.Wai.Routing hiding (route) import Network.Wai.Utilities import Network.Wai.Utilities.Swagger import Network.Wai.Utilities.ZAuth hiding (ZAuthUser) +import Polysemy import Servant hiding (Handler, JSON, addHeader, contentType, respond) import Servant.Server.Generic (genericServerT) import Servant.Swagger.Internal.Orphans () @@ -72,7 +74,7 @@ import qualified Wire.API.Team.SearchVisibility as Public import qualified Wire.API.User as Public (UserIdList, modelUserIdList) import Wire.Swagger (int32Between) -servantSitemap :: ServerT GalleyAPI.ServantAPI (Galley GalleyEffects) +servantSitemap :: ServerT GalleyAPI.ServantAPI (Sem GalleyEffects) servantSitemap = genericServerT $ GalleyAPI.Api @@ -121,7 +123,7 @@ servantSitemap = getFeatureStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal . DoAuth, GalleyAPI.teamFeatureStatusLegalHoldPut = - setFeatureStatus @'Public.TeamFeatureLegalHold Features.setLegalholdStatusInternal . DoAuth, + setFeatureStatus @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging) . DoAuth, GalleyAPI.teamFeatureStatusSearchVisibilityGet = getFeatureStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal . DoAuth, @@ -181,7 +183,7 @@ servantSitemap = GalleyAPI.featureConfigSelfDeletingMessagesGet = Features.getFeatureConfig @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal } -sitemap :: Routes ApiBuilder (Galley GalleyEffects) () +sitemap :: Routes ApiBuilder (Sem GalleyEffects) () sitemap = do -- Team API ----------------------------------------------------------- @@ -738,7 +740,7 @@ sitemap = do errorResponse (Error.errorDescriptionTypeToWai @Error.UnknownClient) errorResponse Error.broadcastLimitExceeded -apiDocs :: Routes ApiBuilder (Galley r) () +apiDocs :: Routes ApiBuilder (Sem r) () apiDocs = get "/conversations/api-docs" (continue docs) $ accept "application" "json" @@ -746,7 +748,7 @@ apiDocs = type JSON = Media "application" "json" -docs :: JSON ::: ByteString -> Galley r Response +docs :: JSON ::: ByteString -> Sem r Response docs (_ ::: url) = do let models = Public.Swagger.models let apidoc = encode $ mkSwaggerApi (decodeLatin1 url) models sitemap diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index e8983fc1ff3..40e3653ec80 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -34,8 +34,6 @@ module Galley.API.Query where import qualified Cassandra as C -import Control.Lens (sequenceAOf) -import Control.Monad.Trans.Except import qualified Data.ByteString.Lazy as LBS import Data.Code import Data.CommaSeparatedList @@ -49,11 +47,11 @@ import qualified Data.Set as Set import Galley.API.Error import qualified Galley.API.Mapping as Mapping import Galley.API.Util -import Galley.App import Galley.Cassandra.Paging import qualified Galley.Data.Types as Data import Galley.Effects import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.FederatorAccess as E import qualified Galley.Effects.ListItems as E import qualified Galley.Effects.MemberStore as E import Galley.Types @@ -66,35 +64,37 @@ import Network.Wai.Predicate hiding (Error, result, setStatus) import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error +import Polysemy.Input +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Logger -import UnliftIO (pooledForConcurrentlyN) import Wire.API.Conversation (ConversationCoverView (..)) import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Role as Public import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley (gcresConvs) import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (FederationError (FederationUnexpectedBody), executeFederated) +import Wire.API.Federation.Client (FederationError (..)) import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public getBotConversationH :: - Members '[ConversationStore, Error ConversationError] r => + Members '[ConversationStore, Error ConversationError, Input (Local ())] r => BotId ::: ConvId ::: JSON -> - Galley r Response + Sem r Response getBotConversationH (zbot ::: zcnv ::: _) = do - json <$> getBotConversation zbot zcnv + lcnv <- qualifyLocal zcnv + json <$> getBotConversation zbot lcnv getBotConversation :: Members '[ConversationStore, Error ConversationError] r => BotId -> - ConvId -> - Galley r Public.BotConvView -getBotConversation zbot zcnv = do - (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 + Local ConvId -> + Sem r Public.BotConvView +getBotConversation zbot lcnv = do + (c, _) <- getConversationAndMemberWithError ConvNotFound (botUserId zbot) lcnv + let domain = tDomain lcnv + cmems = mapMaybe (mkMember domain) (toList (Data.convLocalMembers c)) + pure $ Public.botConvView (tUnqualified lcnv) (Data.convName c) cmems where mkMember :: Domain -> LocalMember -> Maybe OtherMember mkMember domain m @@ -104,13 +104,13 @@ getBotConversation zbot zcnv = do Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) getUnqualifiedConversation :: - Members '[ConversationStore, Error ConversationError, Error InternalError] r => - UserId -> + Members '[ConversationStore, Error ConversationError, Error InternalError, P.TinyLog] r => + Local UserId -> ConvId -> - Galley r Public.Conversation -getUnqualifiedConversation zusr cnv = do - c <- getConversationAndCheckMembership zusr cnv - Mapping.conversationView zusr c + Sem r Public.Conversation +getUnqualifiedConversation lusr cnv = do + c <- getConversationAndCheckMembership (tUnqualified lusr) (qualifyAs lusr cnv) + Mapping.conversationView lusr c getConversation :: forall r. @@ -118,38 +118,46 @@ getConversation :: '[ ConversationStore, Error ConversationError, Error FederationError, - Error InternalError + Error InternalError, + FederatorAccess, + P.TinyLog ] r => - UserId -> + Local UserId -> Qualified ConvId -> - Galley r Public.Conversation -getConversation zusr cnv = do - lusr <- qualifyLocal zusr + Sem r Public.Conversation +getConversation lusr cnv = do foldQualified lusr - (getUnqualifiedConversation zusr . tUnqualified) + (getUnqualifiedConversation lusr . tUnqualified) getRemoteConversation cnv where - getRemoteConversation :: Remote ConvId -> Galley r Public.Conversation + getRemoteConversation :: Remote ConvId -> Sem r Public.Conversation getRemoteConversation remoteConvId = do - conversations <- getRemoteConversations zusr [remoteConvId] - liftSem $ case conversations of + conversations <- getRemoteConversations lusr [remoteConvId] + case conversations of [] -> throw ConvNotFound [conv] -> pure conv -- _convs -> throw (federationUnexpectedBody "expected one conversation, got multiple") _convs -> throw $ FederationUnexpectedBody "expected one conversation, got multiple" getRemoteConversations :: - Members '[ConversationStore, Error ConversationError, Error FederationError] r => - UserId -> + Members + '[ ConversationStore, + Error ConversationError, + Error FederationError, + FederatorAccess, + P.TinyLog + ] + r => + Local UserId -> [Remote ConvId] -> - Galley r [Public.Conversation] -getRemoteConversations zusr remoteConvs = - getRemoteConversationsWithFailures zusr remoteConvs >>= \case + Sem r [Public.Conversation] +getRemoteConversations lusr remoteConvs = + getRemoteConversationsWithFailures lusr remoteConvs >>= \case -- throw first error - (failed : _, _) -> liftSem . throwFgcError $ failed + (failed : _, _) -> throwFgcError $ failed ([], result) -> pure result data FailedGetConversationReason @@ -188,17 +196,14 @@ partitionGetConversationFailures = bimap concat concat . partitionEithers . map split (FailedGetConversation convs (FailedGetConversationRemotely _)) = Right convs getRemoteConversationsWithFailures :: - Member ConversationStore r => - UserId -> + Members '[ConversationStore, FederatorAccess, P.TinyLog] r => + Local UserId -> [Remote ConvId] -> - Galley r ([FailedGetConversation], [Public.Conversation]) -getRemoteConversationsWithFailures zusr convs = do - localDomain <- viewFederationDomain - lusr <- qualifyLocal zusr - + Sem r ([FailedGetConversation], [Public.Conversation]) +getRemoteConversationsWithFailures lusr convs = do -- get self member statuses from the database - statusMap <- liftSem $ E.getRemoteConversationStatus zusr convs - let remoteView :: Remote FederatedGalley.RemoteConversation -> Maybe Conversation + statusMap <- E.getRemoteConversationStatus (tUnqualified lusr) convs + let remoteView :: Remote FederatedGalley.RemoteConversation -> Conversation remoteView rconv = Mapping.remoteConversationView lusr @@ -214,49 +219,45 @@ getRemoteConversationsWithFailures zusr convs = do | otherwise = [failedGetConversationLocally (map qUntagged locallyNotFound)] -- request conversations from remote backends - liftGalley0 - . fmap (bimap (localFailures <>) concat . partitionEithers) - . pooledForConcurrentlyN 8 (bucketRemote locallyFound) - $ \someConvs -> do - let req = FederatedGalley.GetConversationsRequest zusr (tUnqualified someConvs) - rpc = FederatedGalley.getConversations FederatedGalley.clientRoutes localDomain req - handleFailures (sequenceAOf tUnqualifiedL someConvs) $ do - rconvs <- gcresConvs <$> executeFederated (tDomain someConvs) rpc - pure $ mapMaybe (remoteView . qualifyAs someConvs) rconvs + let rpc = FederatedGalley.getConversations FederatedGalley.clientRoutes (tDomain lusr) + resp <- + E.runFederatedConcurrentlyEither locallyFound $ \someConvs -> + rpc $ FederatedGalley.GetConversationsRequest (tUnqualified lusr) (tUnqualified someConvs) + bimap (localFailures <>) (map remoteView . concat) + . partitionEithers + <$> traverse handleFailure resp where - handleFailures :: - [Remote ConvId] -> - ExceptT FederationError Galley0 a -> - Galley0 (Either FailedGetConversation a) - handleFailures rconvs action = runExceptT - . withExceptT (failedGetConversationRemotely rconvs) - . catchE action - $ \e -> do - lift . Logger.warn $ - Logger.msg ("Error occurred while fetching remote conversations" :: ByteString) - . Logger.field "error" (show e) - throwE e + handleFailure :: + Members '[P.TinyLog] r => + Either (Remote [ConvId], FederationError) (Remote FederatedGalley.GetConversationsResponse) -> + Sem r (Either FailedGetConversation [Remote FederatedGalley.RemoteConversation]) + handleFailure (Left (rcids, e)) = do + P.warn $ + Logger.msg ("Error occurred while fetching remote conversations" :: ByteString) + . Logger.field "error" (show e) + pure . Left $ failedGetConversationRemotely (sequenceA rcids) e + handleFailure (Right c) = pure . Right . traverse gcresConvs $ c getConversationRoles :: Members '[ConversationStore, Error ConversationError] r => - UserId -> + Local UserId -> ConvId -> - Galley r Public.ConversationRolesList -getConversationRoles zusr cnv = do - void $ getConversationAndCheckMembership zusr cnv + Sem r Public.ConversationRolesList +getConversationRoles lusr cnv = do + void $ getConversationAndCheckMembership (tUnqualified lusr) (qualifyAs lusr cnv) -- NOTE: If/when custom roles are added, these roles should -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles conversationIdsPageFromUnqualified :: Member (ListItems LegacyPaging ConvId) r => - UserId -> + Local UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> - Galley r (Public.ConversationList ConvId) -conversationIdsPageFromUnqualified zusr start msize = liftSem $ do + Sem r (Public.ConversationList ConvId) +conversationIdsPageFromUnqualified lusr start msize = do let size = fromMaybe (toRange (Proxy @1000)) msize - ids <- E.listItems zusr start size + ids <- E.listItems (tUnqualified lusr) start size pure $ Public.ConversationList (resultSetResult ids) @@ -275,12 +276,12 @@ conversationIdsPageFrom :: ( p ~ CassandraPaging, Members '[ListItems p ConvId, ListItems p (Remote ConvId)] r ) => - UserId -> + Local UserId -> Public.GetPaginatedConversationIds -> - Galley r Public.ConvIdsPage -conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do - localDomain <- viewFederationDomain - liftSem $ case gmtprState of + Sem r Public.ConvIdsPage +conversationIdsPageFrom lusr Public.GetMultiTablePageRequest {..} = do + let localDomain = tDomain lusr + case gmtprState of Just (Public.ConversationPagingState Public.PagingRemotes stateBS) -> remotesOnly (mkState <$> stateBS) gmtprSize _ -> localsAndRemotes localDomain (fmap mkState . Public.mtpsState =<< gmtprState) gmtprSize @@ -296,7 +297,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do localsAndRemotes localDomain pagingState size = do localPage <- pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) - <$> E.listItems zusr pagingState size + <$> E.listItems (tUnqualified lusr) pagingState size let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) if Public.mtpHasMore localPage || remainingSize <= 0 then pure localPage {Public.mtpHasMore = True} -- We haven't checked the remotes yet, so has_more must always be True here. @@ -312,7 +313,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do remotesOnly pagingState size = pageToConvIdPage Public.PagingRemotes . fmap (qUntagged @'QRemote) - <$> E.listItems zusr pagingState size + <$> E.listItems (tUnqualified lusr) pagingState size pageToConvIdPage :: Public.LocalOrRemoteTable -> C.PageWithState (Qualified ConvId) -> Public.ConvIdsPage pageToConvIdPage table page@C.PageWithState {..} = @@ -323,30 +324,30 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do } getConversations :: - Members '[Error InternalError, ListItems LegacyPaging ConvId, ConversationStore] r => - UserId -> + Members '[Error InternalError, ListItems LegacyPaging ConvId, ConversationStore, P.TinyLog] r => + Local UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> - Galley r (Public.ConversationList Public.Conversation) -getConversations user mids mstart msize = do - ConversationList cs more <- getConversationsInternal user mids mstart msize - flip ConversationList more <$> mapM (Mapping.conversationView user) cs + Sem r (Public.ConversationList Public.Conversation) +getConversations luser mids mstart msize = do + ConversationList cs more <- getConversationsInternal luser mids mstart msize + flip ConversationList more <$> mapM (Mapping.conversationView luser) cs getConversationsInternal :: Members '[ConversationStore, ListItems LegacyPaging ConvId] r => - UserId -> + Local UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> - Galley r (Public.ConversationList Data.Conversation) -getConversationsInternal user mids mstart msize = do - (more, ids) <- liftSem $ getIds mids + Sem r (Public.ConversationList Data.Conversation) +getConversationsInternal luser mids mstart msize = do + (more, ids) <- getIds mids let localConvIds = ids cs <- - liftSem (E.getConversations localConvIds) - >>= filterM (liftSem . removeDeleted) - >>= filterM (pure . isMember user . Data.convLocalMembers) + E.getConversations localConvIds + >>= filterM (removeDeleted) + >>= filterM (pure . isMember (tUnqualified luser) . Data.convLocalMembers) pure $ Public.ConversationList cs more where size = fromMaybe (toRange (Proxy @32)) msize @@ -359,10 +360,10 @@ getConversationsInternal user mids mstart msize = do getIds (Just ids) = (False,) <$> E.selectConversations - user + (tUnqualified luser) (fromCommaSeparatedList (fromRange ids)) getIds Nothing = do - r <- E.listItems user mstart (rcast size) + r <- E.listItems (tUnqualified luser) mstart (rcast size) let hasMore = resultSetType r == ResultSetTruncated pure (hasMore, resultSetResult r) @@ -375,25 +376,22 @@ getConversationsInternal user mids mstart msize = do | otherwise = pure True listConversations :: - Members '[ConversationStore, Error InternalError] r => - UserId -> + Members '[ConversationStore, Error InternalError, FederatorAccess, P.TinyLog] r => + Local UserId -> Public.ListConversations -> - Galley r Public.ConversationsResponse -listConversations user (Public.ListConversations ids) = do - luser <- qualifyLocal user - + Sem r Public.ConversationsResponse +listConversations luser (Public.ListConversations ids) = do let (localIds, remoteIds) = partitionQualified luser (fromRange ids) (foundLocalIds, notFoundLocalIds) <- - liftSem $ - foundsAndNotFounds (E.selectConversations user) localIds + foundsAndNotFounds (E.selectConversations (tUnqualified luser)) localIds localInternalConversations <- - liftSem (E.getConversations foundLocalIds) + E.getConversations foundLocalIds >>= filterM removeDeleted - >>= filterM (pure . isMember user . Data.convLocalMembers) - localConversations <- mapM (Mapping.conversationView user) localInternalConversations + >>= filterM (pure . isMember (tUnqualified luser) . Data.convLocalMembers) + localConversations <- mapM (Mapping.conversationView luser) localInternalConversations - (remoteFailures, remoteConversations) <- getRemoteConversationsWithFailures user remoteIds + (remoteFailures, remoteConversations) <- getRemoteConversationsWithFailures luser remoteIds let (failedConvsLocally, failedConvsRemotely) = partitionGetConversationFailures remoteFailures failedConvs = failedConvsLocally <> failedConvsRemotely fetchedOrFailedRemoteIds = Set.fromList $ map Public.cnvQualifiedId remoteConversations <> failedConvs @@ -402,7 +400,7 @@ listConversations user (Public.ListConversations ids) = do -- FUTUREWORK: This implies that the backends are out of sync. Maybe the -- current user should be considered removed from this conversation at this -- point. - Logger.warn $ + P.warn $ Logger.msg ("Some locally found conversation ids were not returned by remotes" :: ByteString) . Logger.field "convIds" (show remoteNotFoundRemoteIds) @@ -420,9 +418,9 @@ listConversations user (Public.ListConversations ids) = do removeDeleted :: Member ConversationStore r => Data.Conversation -> - Galley r Bool + Sem r Bool removeDeleted c - | Data.isConvDeleted c = liftSem $ E.deleteConversation (Data.convId c) >> pure False + | Data.isConvDeleted c = E.deleteConversation (Data.convId c) >> pure False | otherwise = pure True foundsAndNotFounds :: (Monad m, Eq a) => ([a] -> m [a]) -> [a] -> m ([a], [a]) foundsAndNotFounds f xs = do @@ -432,14 +430,14 @@ listConversations user (Public.ListConversations ids) = do iterateConversations :: Members '[ListItems LegacyPaging ConvId, ConversationStore] r => - UserId -> + Local UserId -> Range 1 500 Int32 -> - ([Data.Conversation] -> Galley r a) -> - Galley r [a] -iterateConversations uid pageSize handleConvs = go Nothing + ([Data.Conversation] -> Sem r a) -> + Sem r [a] +iterateConversations luid pageSize handleConvs = go Nothing where go mbConv = do - convResult <- getConversationsInternal uid Nothing mbConv (Just pageSize) + convResult <- getConversationsInternal luid Nothing mbConv (Just pageSize) resultHead <- handleConvs (convList convResult) resultTail <- case convList convResult of (conv : rest) -> @@ -450,29 +448,29 @@ iterateConversations uid pageSize handleConvs = go Nothing pure $ resultHead : resultTail internalGetMemberH :: - Members '[ConversationStore, MemberStore] r => + Members '[ConversationStore, Input (Local ()), MemberStore] r => ConvId ::: UserId -> - Galley r Response + Sem r Response internalGetMemberH (cnv ::: usr) = do - json <$> getLocalSelf usr cnv + lusr <- qualifyLocal usr + json <$> getLocalSelf lusr cnv getLocalSelf :: Members '[ConversationStore, MemberStore] r => - UserId -> + Local UserId -> ConvId -> - Galley r (Maybe Public.Member) -getLocalSelf usr cnv = do - lusr <- qualifyLocal usr - liftSem $ do + Sem r (Maybe Public.Member) +getLocalSelf lusr cnv = do + do alive <- E.isConversationAlive cnv if alive - then Mapping.localMemberToSelf lusr <$$> E.getLocalMember cnv usr + then Mapping.localMemberToSelf lusr <$$> E.getLocalMember cnv (tUnqualified lusr) else Nothing <$ E.deleteConversation cnv getConversationMetaH :: Member ConversationStore r => ConvId -> - Galley r Response + Sem r Response getConversationMetaH cnv = do getConversationMeta cnv <&> \case Nothing -> setStatus status404 empty @@ -481,8 +479,8 @@ getConversationMetaH cnv = do getConversationMeta :: Member ConversationStore r => ConvId -> - Galley r (Maybe ConversationMetadata) -getConversationMeta cnv = liftSem $ do + Sem r (Maybe ConversationMetadata) +getConversationMeta cnv = do alive <- E.isConversationAlive cnv if alive then E.getConversationMetadata cnv @@ -495,21 +493,19 @@ getConversationByReusableCode :: '[ BrigAccess, CodeStore, ConversationStore, - Error ActionError, Error CodeError, Error ConversationError, - Error FederationError, Error NotATeamMember, TeamStore ] r => - UserId -> + Local UserId -> Key -> Value -> - Galley r ConversationCoverView -getConversationByReusableCode zusr key value = do + Sem r ConversationCoverView +getConversationByReusableCode lusr key value = do c <- verifyReusableCode (ConversationCode key value Nothing) - conv <- ensureConversationAccess zusr (Data.codeConversation c) CodeAccess + conv <- ensureConversationAccess (tUnqualified lusr) (Data.codeConversation c) CodeAccess pure $ coverView conv where coverView :: Data.Conversation -> ConversationCoverView diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index f73b5e2ebe2..ce9b1ef65ba 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -76,7 +76,7 @@ import Data.Misc (HttpsUrl, mkHttpsUrl) import Data.Qualified import Data.Range as Range import qualified Data.Set as Set -import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Data.Time.Clock (UTCTime) import qualified Data.UUID as UUID import qualified Data.UUID.Util as UUID import Galley.API.Error as Galley @@ -97,16 +97,16 @@ import qualified Galley.Effects.LegalHoldStore as Data import qualified Galley.Effects.ListItems as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.Paging as E +import qualified Galley.Effects.Queue as E import qualified Galley.Effects.SearchVisibilityStore as SearchVisibilityData import qualified Galley.Effects.SparAccess as Spar import qualified Galley.Effects.TeamFeatureStore as TeamFeatures import qualified Galley.Effects.TeamMemberStore as E import qualified Galley.Effects.TeamStore as E +import Galley.Effects.WaiRoutes import qualified Galley.Intra.Journal as Journal import Galley.Intra.Push import Galley.Options -import qualified Galley.Options as Opts -import qualified Galley.Queue as Q import Galley.Types (UserIdList (UserIdList)) import qualified Galley.Types as Conv import Galley.Types.Conversations.Roles as Roles @@ -121,6 +121,10 @@ import Network.Wai.Predicate hiding (Error, or, result, setStatus) import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error +import Polysemy.Final +import Polysemy.Input +import Polysemy.Output +import qualified Polysemy.TinyLog as P import qualified SAML2.WebSSO as SAML import qualified System.Logger.Class as Log import qualified Wire.API.Conversation.Role as Public @@ -140,58 +144,61 @@ import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) getTeamH :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, Queue DeleteItem, TeamStore] r => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response getTeamH (zusr ::: tid ::: _) = - maybe (liftSem (throw TeamNotFound)) (pure . json) =<< lookupTeam zusr tid + maybe (throw TeamNotFound) (pure . json) =<< lookupTeam zusr tid getTeamInternalH :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, TeamStore] r => TeamId ::: JSON -> - Galley r Response + Sem r Response getTeamInternalH (tid ::: _) = - liftSem . fmap json $ + fmap json $ E.getTeam tid >>= note TeamNotFound getTeamNameInternalH :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, TeamStore] r => TeamId ::: JSON -> - Galley r Response + Sem r Response getTeamNameInternalH (tid ::: _) = - liftSem . fmap json $ + fmap json $ getTeamNameInternal tid >>= note TeamNotFound getTeamNameInternal :: Member TeamStore r => TeamId -> Sem r (Maybe TeamName) getTeamNameInternal = fmap (fmap TeamName) . E.getTeamName getManyTeamsH :: - (Members '[TeamStore, ListItems LegacyPaging TeamId] r) => + (Members '[TeamStore, Queue DeleteItem, ListItems LegacyPaging TeamId] r) => UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> - Galley r Response + Sem r Response getManyTeamsH (zusr ::: range ::: size ::: _) = json <$> getManyTeams zusr range size getManyTeams :: - (Members '[TeamStore, ListItems LegacyPaging TeamId] r) => + (Members '[TeamStore, Queue DeleteItem, ListItems LegacyPaging TeamId] r) => UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> - Galley r Public.TeamList + Sem r Public.TeamList getManyTeams zusr range size = withTeamIds zusr range size $ \more ids -> do teams <- mapM (lookupTeam zusr) ids pure (Public.newTeamList (catMaybes teams) more) -lookupTeam :: Member TeamStore r => UserId -> TeamId -> Galley r (Maybe Public.Team) +lookupTeam :: + Members '[TeamStore, Queue DeleteItem] r => + UserId -> + TeamId -> + Sem r (Maybe Public.Team) lookupTeam zusr tid = do - tm <- liftSem $ E.getTeamMember tid zusr + tm <- E.getTeamMember tid zusr if isJust tm then do - t <- liftSem $ E.getTeam tid + t <- E.getTeam tid when (Just PendingDelete == (tdStatus <$> t)) $ do - q <- view deleteQueue - void $ Q.tryPush q (TeamItem tid zusr Nothing) + void $ E.tryPush (TeamItem tid zusr Nothing) pure (tdTeam <$> t) else pure Nothing @@ -199,15 +206,16 @@ createNonBindingTeamH :: Members '[ BrigAccess, Error ActionError, - Error InvalidInput, Error TeamError, - Error NotATeamMember, GundeckAccess, - TeamStore + Input UTCTime, + P.TinyLog, + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> - Galley r Response + Sem r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do newTeam <- fromJsonBody req newTeamId <- createNonBindingTeam zusr zcon newTeam @@ -218,15 +226,16 @@ createNonBindingTeam :: '[ BrigAccess, Error ActionError, Error TeamError, - Error NotATeamMember, GundeckAccess, - TeamStore + Input UTCTime, + TeamStore, + P.TinyLog ] r => UserId -> ConnId -> Public.NonBindingNewTeam -> - Galley r TeamId + Sem r TeamId createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus let others = @@ -236,41 +245,39 @@ createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do let zothers = map (view userId) others ensureUnboundUsers (zusr : zothers) ensureConnectedToLocals zusr zothers - Log.debug $ + P.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "Teams.createNonBindingTeam") team <- - liftSem $ - E.createTeam - Nothing - zusr - (body ^. newTeamName) - (body ^. newTeamIcon) - (body ^. newTeamIconKey) - NonBinding + E.createTeam + Nothing + zusr + (body ^. newTeamName) + (body ^. newTeamIcon) + (body ^. newTeamIconKey) + NonBinding finishCreateTeam team owner others (Just zcon) pure (team ^. teamId) createBindingTeamH :: - Members '[BrigAccess, Error InvalidInput, GundeckAccess, TeamStore] r => + Members '[GundeckAccess, Input UTCTime, TeamStore, WaiRoutes] r => UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> - Galley r Response + Sem r Response createBindingTeamH (zusr ::: tid ::: req ::: _) = do newTeam <- fromJsonBody req newTeamId <- createBindingTeam zusr tid newTeam pure (empty & setStatus status201 . location newTeamId) createBindingTeam :: - Members '[BrigAccess, GundeckAccess, TeamStore] r => + Members '[GundeckAccess, Input UTCTime, TeamStore] r => UserId -> TeamId -> BindingNewTeam -> - Galley r TeamId + Sem r TeamId createBindingTeam zusr tid (BindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus team <- - liftSem $ - E.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding + E.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding finishCreateTeam team owner [] Nothing pure tid @@ -278,65 +285,76 @@ updateTeamStatusH :: Members '[ BrigAccess, Error ActionError, - Error InvalidInput, Error TeamError, - Error NotATeamMember, - TeamStore + Input Opts, + Input UTCTime, + P.TinyLog, + TeamStore, + WaiRoutes ] r => TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> - Galley r Response + Sem r Response updateTeamStatusH (tid ::: req ::: _) = do teamStatusUpdate <- fromJsonBody req updateTeamStatus tid teamStatusUpdate return empty updateTeamStatus :: - Members '[BrigAccess, Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => + Members + '[ BrigAccess, + Error ActionError, + Error TeamError, + Input Opts, + Input UTCTime, + P.TinyLog, + TeamStore + ] + r => TeamId -> TeamStatusUpdate -> - Galley r () + Sem r () updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do - oldStatus <- tdStatus <$> liftSem (E.getTeam tid >>= note TeamNotFound) + oldStatus <- fmap tdStatus $ E.getTeam tid >>= note TeamNotFound valid <- validateTransition (oldStatus, newStatus) when valid $ do journal newStatus cur - liftSem $ E.setTeamStatus tid newStatus + E.setTeamStatus tid newStatus where journal Suspended _ = Journal.teamSuspend tid journal Active c = do - teamCreationTime <- liftSem $ E.getTeamCreationTime tid + teamCreationTime <- E.getTeamCreationTime tid -- When teams are created, they are activated immediately. In this situation, Brig will -- most likely report team size as 0 due to ES taking some time to index the team creator. -- This is also very difficult to test, so is not tested. - (TeamSize possiblyStaleSize) <- liftSem $ E.getSize tid + (TeamSize possiblyStaleSize) <- E.getSize tid let size = if possiblyStaleSize == 0 then 1 else possiblyStaleSize Journal.teamActivate tid size c teamCreationTime - journal _ _ = liftSem $ throw InvalidTeamStatusUpdate - validateTransition :: Member (Error ActionError) r => (TeamStatus, TeamStatus) -> Galley r Bool + journal _ _ = throw InvalidTeamStatusUpdate + validateTransition :: Member (Error ActionError) r => (TeamStatus, TeamStatus) -> Sem 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 + (_, _) -> throw InvalidTeamStatusUpdate updateTeamH :: Members '[ Error ActionError, - Error InvalidInput, - Error TeamError, Error NotATeamMember, GundeckAccess, - TeamStore + Input UTCTime, + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> - Galley r Response + Sem r Response updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do updateData <- fromJsonBody req updateTeam zusr zcon tid updateData @@ -345,9 +363,9 @@ updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do updateTeam :: Members '[ Error ActionError, - Error TeamError, Error NotATeamMember, GundeckAccess, + Input UTCTime, TeamStore ] r => @@ -355,20 +373,20 @@ updateTeam :: ConnId -> TeamId -> Public.TeamUpdateData -> - Galley r () + Sem r () updateTeam zusr zcon tid updateData = do - zusrMembership <- liftSem $ E.getTeamMember tid zusr + zusrMembership <- E.getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "Teams.updateTeam") void $ permissionCheck SetTeamData zusrMembership - liftSem $ E.setTeamData tid updateData - now <- liftIO getCurrentTime + E.setTeamData tid updateData + now <- input memList <- getTeamMembersForFanout tid let e = newEvent TeamUpdate tid now & eventData .~ Just (EdTeamUpdate updateData) let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) - liftSem . E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon + E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon deleteTeamH :: Members @@ -379,11 +397,13 @@ deleteTeamH :: Error InvalidInput, Error TeamError, Error NotATeamMember, - TeamStore + Queue DeleteItem, + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> - Galley r Response + Sem r Response deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do mBody <- fromOptionalJsonBody req deleteTeam zusr zcon tid mBody @@ -399,6 +419,7 @@ deleteTeam :: Error InvalidInput, Error TeamError, Error NotATeamMember, + Queue DeleteItem, TeamStore ] r => @@ -406,11 +427,11 @@ deleteTeam :: ConnId -> TeamId -> Maybe Public.TeamDeleteData -> - Galley r () + Sem r () deleteTeam zusr zcon tid mBody = do - team <- liftSem $ E.getTeam tid >>= note TeamNotFound + team <- E.getTeam tid >>= note TeamNotFound case tdStatus team of - Deleted -> liftSem $ throw TeamNotFound + Deleted -> throw TeamNotFound PendingDelete -> queueTeamDeletion tid zusr (Just zcon) _ -> do @@ -418,24 +439,30 @@ deleteTeam zusr zcon tid mBody = do queueTeamDeletion tid zusr (Just zcon) where checkPermissions team = do - void $ permissionCheck DeleteTeam =<< liftSem (E.getTeamMember tid zusr) + void $ permissionCheck DeleteTeam =<< E.getTeamMember tid zusr when ((tdTeam team) ^. teamBinding == Binding) $ do - body <- liftSem $ mBody & note (InvalidPayload "missing request body") + body <- mBody & note (InvalidPayload "missing request body") ensureReAuthorised zusr (body ^. tdAuthPassword) -- This can be called by stern internalDeleteBindingTeamWithOneMember :: - Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => + Members + '[ Error InternalError, + Error TeamError, + Queue DeleteItem, + TeamStore + ] + r => TeamId -> - Galley r () + Sem r () internalDeleteBindingTeamWithOneMember tid = do - team <- liftSem (E.getTeam tid) - liftSem . unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ + team <- E.getTeam tid + unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ throw NoBindingTeam - mems <- liftSem $ E.getTeamMembersWithLimit tid (unsafeRange 2) + mems <- E.getTeamMembersWithLimit tid (unsafeRange 2) case mems ^. teamMembers of (mem : []) -> queueTeamDeletion tid (mem ^. userId) Nothing - _ -> liftSem $ throw NotAOneMemberTeam + _ -> throw NotAOneMemberTeam -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. uncheckedDeleteTeam :: @@ -444,167 +471,155 @@ uncheckedDeleteTeam :: '[ BrigAccess, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, SparAccess, TeamStore ] r => - UserId -> + Local UserId -> Maybe ConnId -> TeamId -> - Galley r () -uncheckedDeleteTeam zusr zcon tid = do - team <- liftSem $ E.getTeam tid + Sem r () +uncheckedDeleteTeam lusr zcon tid = do + team <- E.getTeam tid when (isJust team) $ do - liftSem $ Spar.deleteTeam tid - now <- liftIO getCurrentTime + Spar.deleteTeam tid + now <- input convs <- - liftSem $ - filter (not . view managedConversation) <$> E.getTeamConversations tid + filter (not . view managedConversation) <$> E.getTeamConversations tid -- Even for LARGE TEAMS, we _DO_ want to fetch all team members here because we -- want to generate conversation deletion events for non-team users. This should -- be fine as it is done once during the life team of a team and we still do not -- fanout this particular event to all team members anyway. And this is anyway -- done asynchronously - membs <- liftSem $ E.getTeamMembers tid + membs <- E.getTeamMembers tid (ue, be) <- foldrM (createConvDeleteEvents now membs) ([], []) convs let e = newEvent TeamDelete tid now pushDeleteEvents membs e ue - liftSem $ E.deliverAsync be + E.deliverAsync be -- TODO: we don't delete bots here, but we should do that, since -- every bot user can only be in a single conversation. Just -- deleting conversations from the database is not enough. when ((view teamBinding . tdTeam <$> team) == Just Binding) $ do - liftSem $ mapM_ (E.deleteUser . view userId) membs + mapM_ (E.deleteUser . view userId) membs Journal.teamDelete tid - liftSem $ Data.unsetTeamLegalholdWhitelisted tid - liftSem $ E.deleteTeam tid + Data.unsetTeamLegalholdWhitelisted tid + E.deleteTeam tid where - pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley r () + pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Sem r () pushDeleteEvents membs e ue = do - o <- view $ options . optSettings - let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) membs) + o <- inputs (view optSettings) + let r = list1 (userRecipient (tUnqualified lusr)) (membersToRecipients (Just (tUnqualified lusr)) membs) -- To avoid DoS on gundeck, send team deletion events in chunks let chunkSize = fromMaybe defConcurrentDeletionEvents (o ^. setConcurrentDeletionEvents) let chunks = List.chunksOf chunkSize (toList r) - liftSem $ - forM_ chunks $ \chunk -> case chunk of - [] -> return () - -- push TeamDelete events. Note that despite having a complete list, we are guaranteed in the - -- push module to never fan this out to more than the limit - x : xs -> E.push1 (newPushLocal1 ListComplete zusr (TeamEvent e) (list1 x xs) & pushConn .~ zcon) + forM_ chunks $ \chunk -> case chunk of + [] -> return () + -- push TeamDelete events. Note that despite having a complete list, we are guaranteed in the + -- push module to never fan this out to more than the limit + x : xs -> E.push1 (newPushLocal1 ListComplete (tUnqualified lusr) (TeamEvent e) (list1 x xs) & pushConn .~ zcon) -- To avoid DoS on gundeck, send conversation deletion events slowly - -- FUTUREWORK: make this behaviour part of the GundeckAccess effect - let delay = 1000 * (fromMaybe defDeleteConvThrottleMillis (o ^. setDeleteConvThrottleMillis)) - forM_ ue $ \event -> do - -- push ConversationDelete events - liftSem $ E.push1 event - threadDelay delay + E.pushSlowly ue createConvDeleteEvents :: UTCTime -> [TeamMember] -> TeamConversation -> ([Push], [(BotMember, Conv.Event)]) -> - Galley r ([Push], [(BotMember, Conv.Event)]) + Sem r ([Push], [(BotMember, Conv.Event)]) createConvDeleteEvents now teamMembs c (pp, ee) = do - localDomain <- viewFederationDomain - let qconvId = Qualified (c ^. conversationId) localDomain - qorig = Qualified zusr localDomain - (bots, convMembs) <- liftSem $ localBotsAndUsers <$> E.getLocalMembers (c ^. conversationId) + let qconvId = qUntagged $ qualifyAs lusr (c ^. conversationId) + (bots, convMembs) <- localBotsAndUsers <$> E.getLocalMembers (c ^. conversationId) -- Only nonTeamMembers need to get any events, since on team deletion, -- all team users are deleted immediately after these events are sent -- and will thus never be able to see these events in practice. let mm = nonTeamMembers convMembs teamMembs - let e = Conv.Event Conv.ConvDelete qconvId qorig now Conv.EdConvDelete + let e = Conv.Event Conv.ConvDelete qconvId (qUntagged lusr) now Conv.EdConvDelete -- This event always contains all the required recipients - let p = newPushLocal ListComplete zusr (ConvEvent e) (map recipient mm) + let p = newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (map recipient mm) let ee' = bots `zip` repeat e let pp' = maybe pp (\x -> (x & pushConn .~ zcon) : pp) p pure (pp', ee' ++ ee) getTeamConversationRoles :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> - Galley r Public.ConversationRolesList + Sem r Public.ConversationRolesList getTeamConversationRoles zusr tid = do - liftSem . void $ E.getTeamMember tid zusr >>= noteED @NotATeamMember + 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, Error NotATeamMember, TeamStore] r => + Members '[Error NotATeamMember, TeamStore] r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> - Galley r Response + Sem r Response getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do (memberList, withPerms) <- getTeamMembers zusr tid maxResults pure . json $ teamMemberListJson withPerms memberList getTeamMembers :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> - Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) -getTeamMembers zusr tid maxResults = liftSem $ do + Sem r (Public.TeamMemberList, Public.TeamMember -> Bool) +getTeamMembers zusr tid maxResults = do m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember mems <- E.getTeamMembersWithLimit tid maxResults let withPerms = (m `canSeePermsOf`) pure (mems, withPerms) +outputToStreamingBody :: Member (Final IO) r => Sem (Output LByteString ': r) () -> Sem r StreamingBody +outputToStreamingBody action = withWeavingToFinal @IO $ \state weave _inspect -> + pure . (<$ state) $ \write flush -> do + let writeChunk c = embedFinal $ do + write (lazyByteString c) + flush + void . weave . (<$ state) $ runOutputSem writeChunk action + getTeamMembersCSVH :: - (Members '[BrigAccess, Error ActionError, TeamStore] r) => + (Members '[BrigAccess, Error ActionError, TeamMemberStore InternalPaging, TeamStore, Final IO] r) => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response getTeamMembersCSVH (zusr ::: tid ::: _) = do - liftSem $ - E.getTeamMember tid zusr >>= \case - Nothing -> throw AccessDenied - Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throw AccessDenied + 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 -- the response will not contain a correct error message, but rather be an -- http error such as 'InvalidChunkHeaders'. The exception however still -- reaches the middleware and is being tracked in logging and metrics. - -- - -- FUTUREWORK: rewrite this using some streaming primitive (e.g. polysemy's Input) + body <- outputToStreamingBody $ do + output headerLine + E.withChunks (\mps -> E.listTeamMembers @InternalPaging tid mps maxBound) $ + \members -> do + inviters <- lookupInviterHandle members + users <- + lookupUser <$> E.lookupActivatedUsers (fmap (view userId) members) + richInfos <- + lookupRichInfo <$> E.getRichInfoMultiUser (fmap (view userId) members) + output @LByteString + ( encodeDefaultOrderedByNameWith + defaultEncodeOptions + (mapMaybe (teamExportUser users inviters richInfos) members) + ) pure $ responseStream status200 [ (hContentType, "text/csv"), ("Content-Disposition", "attachment; filename=\"wire_team_members.csv\"") ] - $ \write flush -> do - let writeString = write . lazyByteString - writeString headerLine - flush - evalGalley env $ do - E.withChunks pager $ - \members -> do - inviters <- lookupInviterHandle members - users <- - liftSem $ - lookupUser <$> E.lookupActivatedUsers (fmap (view userId) members) - richInfos <- - liftSem $ - lookupRichInfo <$> E.getRichInfoMultiUser (fmap (view userId) members) - liftIO $ do - writeString - ( encodeDefaultOrderedByNameWith - defaultEncodeOptions - (mapMaybe (teamExportUser users inviters richInfos) members) - ) - flush + body where headerLine :: LByteString headerLine = encodeDefaultOrderedByNameWith (defaultEncodeOptions {encIncludeHeader = True}) ([] :: [TeamExportUser]) - pager :: Maybe (InternalPagingState TeamMember) -> Galley GalleyEffects (InternalPage TeamMember) - pager mps = liftSem $ E.listTeamMembers tid mps maxBound - defaultEncodeOptions :: EncodeOptions defaultEncodeOptions = EncodeOptions @@ -639,12 +654,12 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do tExportUserId = U.userId user } - lookupInviterHandle :: Member BrigAccess r => [TeamMember] -> Galley r (UserId -> Maybe Handle.Handle) + lookupInviterHandle :: Member BrigAccess r => [TeamMember] -> Sem r (UserId -> Maybe Handle.Handle) lookupInviterHandle members = do let inviterIds :: [UserId] inviterIds = nub $ catMaybes $ fmap fst . view invitation <$> members - userList :: [User] <- liftSem $ accountUser <$$> E.getUsers inviterIds + userList :: [User] <- accountUser <$$> E.getUsers inviterIds let userMap :: M.Map UserId Handle.Handle userMap = M.fromList . catMaybes $ extract <$> userList @@ -673,15 +688,14 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do bulkGetTeamMembersH :: Members - '[ Error ActionError, - Error InvalidInput, - Error TeamError, + '[ Error InvalidInput, Error NotATeamMember, - TeamStore + TeamStore, + WaiRoutes ] r => UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> - Galley r Response + Sem r Response bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do UserIdList uids <- fromJsonBody body (memberList, withPerms) <- bulkGetTeamMembers zusr tid maxResults uids @@ -689,13 +703,13 @@ 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, Error NotATeamMember, TeamStore] r => + Members '[Error InvalidInput, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> - Galley r (TeamMemberList, TeamMember -> Bool) -bulkGetTeamMembers zusr tid maxResults uids = liftSem $ do + Sem r (TeamMemberList, TeamMember -> Bool) +bulkGetTeamMembers zusr tid maxResults uids = do unless (length uids <= fromIntegral (fromRange maxResults)) $ throw BulkGetMemberLimitExceeded m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember @@ -707,7 +721,7 @@ bulkGetTeamMembers zusr tid maxResults uids = liftSem $ do getTeamMemberH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId ::: TeamId ::: UserId ::: JSON -> - Galley r Response + Sem r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do (member, withPerms) <- getTeamMember zusr tid uid pure . json $ teamMemberJson withPerms member @@ -717,43 +731,48 @@ getTeamMember :: UserId -> TeamId -> UserId -> - Galley r (Public.TeamMember, Public.TeamMember -> Bool) + Sem r (Public.TeamMember, Public.TeamMember -> Bool) getTeamMember zusr tid uid = do m <- - liftSem $ - E.getTeamMember tid zusr - >>= noteED @NotATeamMember + E.getTeamMember tid zusr + >>= noteED @NotATeamMember let withPerms = (m `canSeePermsOf`) - member <- liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound + member <- E.getTeamMember tid uid >>= note TeamMemberNotFound pure (member, withPerms) internalDeleteBindingTeamWithOneMemberH :: - Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => + Members + '[ Error InternalError, + Error TeamError, + Queue DeleteItem, + TeamStore + ] + r => TeamId -> - Galley r Response + Sem r Response internalDeleteBindingTeamWithOneMemberH tid = do internalDeleteBindingTeamWithOneMember tid pure (empty & setStatus status202) uncheckedGetTeamMemberH :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, TeamStore] r => TeamId ::: UserId ::: JSON -> - Galley r Response + Sem r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid uncheckedGetTeamMember :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, TeamStore] r => TeamId -> UserId -> - Galley r TeamMember + Sem r TeamMember uncheckedGetTeamMember tid uid = - liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound + E.getTeamMember tid uid >>= note TeamMemberNotFound uncheckedGetTeamMembersH :: Member TeamStore r => TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> - Galley r Response + Sem r Response uncheckedGetTeamMembersH (tid ::: maxResults ::: _) = do json <$> uncheckedGetTeamMembers tid maxResults @@ -761,8 +780,8 @@ uncheckedGetTeamMembers :: Member TeamStore r => TeamId -> Range 1 HardTruncationLimit Int32 -> - Galley r TeamMemberList -uncheckedGetTeamMembers tid maxResults = liftSem $ E.getTeamMembersWithLimit tid maxResults + Sem r TeamMemberList +uncheckedGetTeamMembers tid maxResults = E.getTeamMembersWithLimit tid maxResults addTeamMemberH :: Members @@ -770,18 +789,22 @@ addTeamMemberH :: GundeckAccess, Error ActionError, Error LegalHoldError, - Error InvalidInput, Error TeamError, Error NotATeamMember, + Input (Local ()), + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, + P.TinyLog, TeamFeatureStore, TeamNotificationStore, - TeamStore + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> - Galley r Response + Sem r Response addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do nmem <- fromJsonBody req addTeamMember zusr zcon tid nmem @@ -795,33 +818,37 @@ addTeamMember :: Error LegalHoldError, Error TeamError, Error NotATeamMember, + Input (Local ()), + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, TeamFeatureStore, TeamNotificationStore, - TeamStore + TeamStore, + P.TinyLog ] r => UserId -> ConnId -> TeamId -> Public.NewTeamMember -> - Galley r () + Sem r () addTeamMember zusr zcon tid nmem = do let uid = nmem ^. ntmNewTeamMember . userId - Log.debug $ + P.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "Teams.addTeamMember") -- verify permissions zusrMembership <- - liftSem (E.getTeamMember tid zusr) + E.getTeamMember tid zusr >>= permissionCheck AddTeamMember let targetPermissions = nmem ^. ntmNewTeamMember . permissions targetPermissions `ensureNotElevated` zusrMembership ensureNonBindingTeam tid ensureUnboundUsers [uid] ensureConnectedToLocals zusr [uid] - (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid + (TeamSize sizeBeforeJoin) <- E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) memList <- getTeamMembersForFanout tid void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem memList @@ -831,19 +858,22 @@ uncheckedAddTeamMemberH :: Members '[ BrigAccess, Error LegalHoldError, - Error InvalidInput, Error TeamError, - Error NotATeamMember, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, + P.TinyLog, TeamFeatureStore, + TeamNotificationStore, TeamStore, - TeamNotificationStore + WaiRoutes ] r => TeamId ::: JsonRequest NewTeamMember ::: JSON -> - Galley r Response + Sem r Response uncheckedAddTeamMemberH (tid ::: req ::: _) = do nmem <- fromJsonBody req uncheckedAddTeamMember tid nmem @@ -855,20 +885,23 @@ uncheckedAddTeamMember :: GundeckAccess, Error LegalHoldError, Error TeamError, - Error NotATeamMember, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, LegalHoldStore, + P.TinyLog, TeamFeatureStore, - TeamStore, - TeamNotificationStore + TeamNotificationStore, + TeamStore ] r => TeamId -> NewTeamMember -> - Galley r () + Sem r () uncheckedAddTeamMember tid nmem = do mems <- getTeamMembersForFanout tid - (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid + (TeamSize sizeBeforeJoin) <- E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) (TeamSize sizeBeforeAdd) <- addTeamMemberInternal tid Nothing Nothing nmem mems billingUserIds <- Journal.getBillingUserIds tid $ Just $ newTeamMemberList ((nmem ^. ntmNewTeamMember) : mems ^. teamMembers) (mems ^. teamMemberListType) @@ -878,18 +911,21 @@ updateTeamMemberH :: Members '[ BrigAccess, Error ActionError, - Error InvalidInput, Error TeamError, Error NotATeamMember, + Input Opts, + Input UTCTime, GundeckAccess, - TeamStore + P.TinyLog, + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> - Galley r Response + Sem r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do -- the team member to be updated - targetMember <- view ntmNewTeamMember <$> fromJsonBody req + targetMember <- view ntmNewTeamMember <$> (fromJsonBody req) updateTeamMember zusr zcon tid targetMember pure empty @@ -901,6 +937,9 @@ updateTeamMember :: Error TeamError, Error NotATeamMember, GundeckAccess, + Input Opts, + Input UTCTime, + P.TinyLog, TeamStore ] r => @@ -908,33 +947,32 @@ updateTeamMember :: ConnId -> TeamId -> TeamMember -> - Galley r () + Sem r () updateTeamMember zusr zcon tid targetMember = do let targetId = targetMember ^. userId targetPermissions = targetMember ^. permissions - Log.debug $ + P.debug $ Log.field "targets" (toByteString targetId) . Log.field "action" (Log.val "Teams.updateTeamMember") -- get the team and verify permissions - team <- liftSem . fmap tdTeam $ E.getTeam tid >>= note TeamNotFound + team <- fmap tdTeam $ E.getTeam tid >>= note TeamNotFound user <- - liftSem (E.getTeamMember tid zusr) + E.getTeamMember tid zusr >>= permissionCheck SetMemberPermissions -- user may not elevate permissions targetPermissions `ensureNotElevated` user previousMember <- - liftSem $ E.getTeamMember tid targetId >>= note TeamMemberNotFound - liftSem - . when - ( downgradesOwner previousMember targetPermissions - && not (canDowngradeOwner user previousMember) - ) + E.getTeamMember tid targetId >>= note TeamMemberNotFound + when + ( downgradesOwner previousMember targetPermissions + && not (canDowngradeOwner user previousMember) + ) $ throw AccessDenied -- update target in Cassandra - liftSem $ E.setTeamMemberPermissions (previousMember ^. permissions) tid targetId targetPermissions + E.setTeamMemberPermissions (previousMember ^. permissions) tid targetId targetPermissions updatedMembers <- getTeamMembersForFanout tid updateJournal team updatedMembers @@ -947,14 +985,14 @@ updateTeamMember zusr zcon tid targetMember = do permissionsRole (previousMember ^. permissions) == Just RoleOwner && permissionsRole targetPermissions /= Just RoleOwner - updateJournal :: Team -> TeamMemberList -> Galley r () + updateJournal :: Team -> TeamMemberList -> Sem r () updateJournal team mems = do when (team ^. teamBinding == Binding) $ do - (TeamSize size) <- liftSem $ E.getSize tid + (TeamSize size) <- E.getSize tid billingUserIds <- Journal.getBillingUserIds tid $ Just mems Journal.teamUpdate tid size billingUserIds - updatePeers :: UserId -> Permissions -> TeamMemberList -> Galley r () + updatePeers :: UserId -> Permissions -> TeamMemberList -> Sem r () updatePeers targetId targetPermissions updatedMembers = do -- inform members of the team about the change -- some (privileged) users will be informed about which change was applied @@ -962,11 +1000,11 @@ updateTeamMember zusr zcon tid targetMember = do mkUpdate = EdMemberUpdate targetId privilegedUpdate = mkUpdate $ Just targetPermissions privilegedRecipients = membersToRecipients Nothing privileged - now <- liftIO getCurrentTime + now <- input let ePriv = newEvent MemberUpdate tid now & eventData ?~ privilegedUpdate -- push to all members (user is privileged) let pushPriv = newPushLocal (updatedMembers ^. teamMemberListType) zusr (TeamEvent ePriv) $ privilegedRecipients - liftSem $ for_ pushPriv $ \p -> E.push1 $ p & pushConn .~ Just zcon + for_ pushPriv $ \p -> E.push1 $ p & pushConn .~ Just zcon deleteTeamMemberH :: Members @@ -975,19 +1013,25 @@ deleteTeamMemberH :: Error ActionError, Error AuthenticationError, Error InvalidInput, - Error TeamError, Error NotATeamMember, + Error TeamError, ExternalAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, - TeamStore + P.TinyLog, + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> - Galley r Response + Sem r Response deleteTeamMemberH (zusr ::: zcon ::: tid ::: remove ::: req ::: _) = do + lusr <- qualifyLocal zusr mBody <- fromOptionalJsonBody req - deleteTeamMember zusr zcon tid remove mBody >>= \case + deleteTeamMember lusr zcon tid remove mBody >>= \case TeamMemberDeleteAccepted -> pure (empty & setStatus status202) TeamMemberDeleteCompleted -> pure empty @@ -1006,35 +1050,38 @@ deleteTeamMember :: Error TeamError, Error NotATeamMember, ExternalAccess, + Input Opts, + Input UTCTime, GundeckAccess, MemberStore, - TeamStore + TeamStore, + P.TinyLog ] r => - UserId -> + Local UserId -> ConnId -> TeamId -> UserId -> Maybe Public.TeamMemberDeleteData -> - Galley r TeamMemberDeleteResult -deleteTeamMember zusr zcon tid remove mBody = do - Log.debug $ + Sem r TeamMemberDeleteResult +deleteTeamMember lusr zcon tid remove mBody = do + P.debug $ Log.field "targets" (toByteString remove) . Log.field "action" (Log.val "Teams.deleteTeamMember") - zusrMember <- liftSem $ E.getTeamMember tid zusr - targetMember <- liftSem $ E.getTeamMember tid remove + zusrMember <- E.getTeamMember tid (tUnqualified lusr) + targetMember <- E.getTeamMember tid remove void $ permissionCheck RemoveTeamMember zusrMember - liftSem $ do + do dm <- note TeamMemberNotFound zusrMember tm <- note TeamMemberNotFound targetMember unless (canDeleteMember dm tm) $ throw AccessDenied - team <- tdTeam <$> liftSem (E.getTeam tid >>= note TeamNotFound) + team <- fmap tdTeam $ E.getTeam tid >>= note TeamNotFound mems <- getTeamMembersForFanout tid if team ^. teamBinding == Binding && isJust targetMember then do - body <- liftSem $ mBody & note (InvalidPayload "missing request body") - ensureReAuthorised zusr (body ^. tmdAuthPassword) - (TeamSize sizeBeforeDelete) <- liftSem $ E.getSize tid + body <- mBody & note (InvalidPayload "missing request body") + ensureReAuthorised (tUnqualified lusr) (body ^. tmdAuthPassword) + (TeamSize sizeBeforeDelete) <- E.getSize tid -- TeamSize is 'Natural' and subtracting from 0 is an error -- TeamSize could be reported as 0 if team members are added and removed very quickly, -- which happens in tests @@ -1042,80 +1089,80 @@ deleteTeamMember zusr zcon tid remove mBody = do if sizeBeforeDelete == 0 then 0 else sizeBeforeDelete - 1 - liftSem $ E.deleteUser remove + E.deleteUser remove billingUsers <- Journal.getBillingUserIds tid (Just mems) Journal.teamUpdate tid sizeAfterDelete $ filter (/= remove) billingUsers pure TeamMemberDeleteAccepted else do - uncheckedDeleteTeamMember zusr (Just zcon) tid remove mems + uncheckedDeleteTeamMember lusr (Just zcon) tid remove mems pure TeamMemberDeleteCompleted -- This function is "unchecked" because it does not validate that the user has the `RemoveTeamMember` permission. uncheckedDeleteTeamMember :: forall r. Members - '[ BrigAccess, - ConversationStore, + '[ ConversationStore, GundeckAccess, ExternalAccess, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> Maybe ConnId -> TeamId -> UserId -> TeamMemberList -> - Galley r () -uncheckedDeleteTeamMember zusr zcon tid remove mems = do - now <- liftIO getCurrentTime + Sem r () +uncheckedDeleteTeamMember lusr zcon tid remove mems = do + now <- input pushMemberLeaveEvent now - liftSem $ E.deleteTeamMember tid remove + E.deleteTeamMember tid remove removeFromConvsAndPushConvLeaveEvent now where -- notify all team members. - pushMemberLeaveEvent :: UTCTime -> Galley r () + pushMemberLeaveEvent :: UTCTime -> Sem r () pushMemberLeaveEvent now = do let e = newEvent MemberLeave tid now & eventData ?~ EdMemberLeave remove - let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (mems ^. teamMembers)) - liftSem . E.push1 $ - newPushLocal1 (mems ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ zcon + let r = + list1 + (userRecipient (tUnqualified lusr)) + (membersToRecipients (Just (tUnqualified lusr)) (mems ^. teamMembers)) + E.push1 $ + newPushLocal1 (mems ^. teamMemberListType) (tUnqualified lusr) (TeamEvent e) r & pushConn .~ zcon -- notify all conversation members not in this team. - removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Galley r () + removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Sem r () removeFromConvsAndPushConvLeaveEvent now = do -- This may not make sense if that list has been truncated. In such cases, we still want to -- remove the user from conversations but never send out any events. We assume that clients -- handle nicely these missing events, regardless of whether they are in the same team or not - localDomain <- viewFederationDomain let tmids = Set.fromList $ map (view userId) (mems ^. teamMembers) - let edata = Conv.EdMembersLeave (Conv.QualifiedUserIdList [Qualified remove localDomain]) - cc <- liftSem $ E.getTeamConversations tid + let edata = Conv.EdMembersLeave (Conv.QualifiedUserIdList [qUntagged (qualifyAs lusr remove)]) + cc <- E.getTeamConversations tid for_ cc $ \c -> - liftSem (E.getConversation (c ^. conversationId)) >>= \conv -> + E.getConversation (c ^. conversationId) >>= \conv -> for_ conv $ \dc -> when (remove `isMember` Data.convLocalMembers dc) $ do - liftSem $ E.deleteMembers (c ^. conversationId) (UserList [remove] []) + E.deleteMembers (c ^. conversationId) (UserList [remove] []) -- If the list was truncated, then the tmids list is incomplete so we simply drop these events unless (c ^. managedConversation || mems ^. teamMemberListType == ListTruncated) $ pushEvent tmids edata now dc - pushEvent :: Set UserId -> Conv.EventData -> UTCTime -> Data.Conversation -> Galley r () + pushEvent :: Set UserId -> Conv.EventData -> UTCTime -> Data.Conversation -> Sem r () pushEvent exceptTo edata now dc = do - localDomain <- viewFederationDomain - let qconvId = Qualified (Data.convId dc) localDomain - qusr = Qualified zusr localDomain + let qconvId = qUntagged $ qualifyAs lusr (Data.convId dc) let (bots, users) = localBotsAndUsers (Data.convLocalMembers dc) let x = filter (\m -> not (Conv.lmId m `Set.member` exceptTo)) users - let y = Conv.Event Conv.MemberLeave qconvId qusr now edata - for_ (newPushLocal (mems ^. teamMemberListType) zusr (ConvEvent y) (recipient <$> x)) $ \p -> - liftSem . E.push1 $ p & pushConn .~ zcon - liftSem $ E.deliverAsync (bots `zip` repeat y) + let y = Conv.Event Conv.MemberLeave qconvId (qUntagged lusr) now edata + for_ (newPushLocal (mems ^. teamMemberListType) (tUnqualified lusr) (ConvEvent y) (recipient <$> x)) $ \p -> + E.push1 $ p & pushConn .~ zcon + E.deliverAsync (bots `zip` repeat y) getTeamConversations :: - Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error ActionError, Error NotATeamMember, TeamStore] r => UserId -> TeamId -> - Galley r Public.TeamConversationList -getTeamConversations zusr tid = liftSem $ do + Sem r Public.TeamConversationList +getTeamConversations zusr tid = do tm <- E.getTeamMember tid zusr >>= noteED @NotATeamMember @@ -1127,7 +1174,6 @@ getTeamConversation :: Members '[ Error ActionError, Error ConversationError, - Error TeamError, Error NotATeamMember, TeamStore ] @@ -1135,8 +1181,8 @@ getTeamConversation :: UserId -> TeamId -> ConvId -> - Galley r Public.TeamConversation -getTeamConversation zusr tid cid = liftSem $ do + Sem r Public.TeamConversation +getTeamConversation zusr tid cid = do tm <- E.getTeamMember tid zusr >>= noteED @NotATeamMember @@ -1147,68 +1193,62 @@ getTeamConversation zusr tid cid = liftSem $ do deleteTeamConversation :: Members - '[ BotAccess, - BrigAccess, - CodeStore, + '[ CodeStore, ConversationStore, Error ActionError, Error ConversationError, Error FederationError, Error InvalidInput, - Error TeamError, Error NotATeamMember, ExternalAccess, FederatorAccess, - FireAndForget, GundeckAccess, - LegalHoldStore, - MemberStore, + Input UTCTime, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> TeamId -> ConvId -> - Galley r () -deleteTeamConversation zusr zcon _tid cid = do - lusr <- qualifyLocal zusr - lconv <- qualifyLocal cid + Sem r () +deleteTeamConversation lusr zcon _tid cid = do + let lconv = qualifyAs lusr cid void $ API.deleteLocalConversation lusr zcon lconv getSearchVisibilityH :: Members '[ Error ActionError, - Error TeamError, Error NotATeamMember, SearchVisibilityStore, TeamStore ] r => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response getSearchVisibilityH (uid ::: tid ::: _) = do - zusrMembership <- liftSem $ E.getTeamMember tid uid + zusrMembership <- E.getTeamMember tid uid void $ permissionCheck ViewTeamSearchVisibility zusrMembership json <$> getSearchVisibilityInternal tid setSearchVisibilityH :: Members '[ Error ActionError, - Error InvalidInput, Error TeamError, Error NotATeamMember, + Input Opts, SearchVisibilityStore, TeamStore, - TeamFeatureStore + TeamFeatureStore, + WaiRoutes ] r => UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> - Galley r Response + Sem r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do - zusrMembership <- liftSem $ E.getTeamMember tid uid + zusrMembership <- E.getTeamMember tid uid void $ permissionCheck ChangeTeamSearchVisibility zusrMembership - setSearchVisibilityInternal tid =<< fromJsonBody req + setSearchVisibilityInternal tid =<< (fromJsonBody req) pure noContent -- Internal ----------------------------------------------------------------- @@ -1230,51 +1270,53 @@ withTeamIds :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> - (Bool -> [TeamId] -> Galley r a) -> - Galley r a + (Bool -> [TeamId] -> Sem r a) -> + Sem r a withTeamIds usr range size k = case range of Nothing -> do - r <- liftSem $ E.listItems usr Nothing (rcast size) + r <- E.listItems usr Nothing (rcast size) k (resultSetType r == ResultSetTruncated) (resultSetResult r) Just (Right c) -> do - r <- liftSem $ E.listItems usr (Just c) (rcast size) + r <- E.listItems usr (Just c) (rcast size) k (resultSetType r == ResultSetTruncated) (resultSetResult r) Just (Left (fromRange -> cc)) -> do - ids <- liftSem $ E.selectTeams usr (Data.ByteString.Conversion.fromList cc) + ids <- E.selectTeams usr (Data.ByteString.Conversion.fromList cc) k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => [UserId] -> Galley r () +ensureUnboundUsers :: Members '[Error TeamError, TeamStore] r => [UserId] -> Sem 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) $ + teams <- Map.elems <$> E.getUsersTeams uids + binds <- E.getTeamsBindings teams + when (any (== Binding) binds) $ throw UserBindingExists -ensureNonBindingTeam :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> Galley r () +ensureNonBindingTeam :: Members '[Error TeamError, TeamStore] r => TeamId -> Sem r () ensureNonBindingTeam tid = do - team <- liftSem $ note TeamNotFound =<< E.getTeam tid - liftSem . when ((tdTeam team) ^. teamBinding == Binding) $ + team <- note TeamNotFound =<< E.getTeam tid + 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 :: Member (Error ActionError) r => Permissions -> TeamMember -> Galley r () +ensureNotElevated :: Member (Error ActionError) r => Permissions -> TeamMember -> Sem r () ensureNotElevated targetPermissions member = - liftSem - . unless - ( (targetPermissions ^. self) - `Set.isSubsetOf` (member ^. permissions . copy) - ) + unless + ( (targetPermissions ^. self) + `Set.isSubsetOf` (member ^. permissions . copy) + ) $ throw InvalidPermissions -ensureNotTooLarge :: Members '[BrigAccess, Error TeamError] r => TeamId -> Galley r TeamSize +ensureNotTooLarge :: + Members '[BrigAccess, Error TeamError, Input Opts] r => + TeamId -> + Sem r TeamSize ensureNotTooLarge tid = do - o <- view options - (TeamSize size) <- liftSem $ E.getSize tid - liftSem . unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ + o <- input + (TeamSize size) <- E.getSize tid + unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ throw TooManyTeamMembers return $ TeamSize size @@ -1288,29 +1330,35 @@ ensureNotTooLarge tid = do -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. ensureNotTooLargeForLegalHold :: - Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => + Members + '[ Error LegalHoldError, + LegalHoldStore, + TeamStore, + TeamFeatureStore + ] + r => TeamId -> Int -> - Galley r () + Sem r () ensureNotTooLargeForLegalHold tid teamSize = whenM (isLegalHoldEnabledForTeam tid) $ unlessM (teamSizeBelowLimit teamSize) $ - liftSem $ throw TooManyTeamMembersOnTeamWithLegalhold + throw TooManyTeamMembersOnTeamWithLegalhold ensureNotTooLargeToActivateLegalHold :: - Members '[BrigAccess, Error TeamError] r => + Members '[BrigAccess, Error TeamError, TeamStore] r => TeamId -> - Galley r () + Sem r () ensureNotTooLargeToActivateLegalHold tid = do - (TeamSize teamSize) <- liftSem $ E.getSize tid + (TeamSize teamSize) <- E.getSize tid unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ - liftSem $ throw CannotEnableLegalHoldServiceLargeTeam + throw CannotEnableLegalHoldServiceLargeTeam -teamSizeBelowLimit :: Int -> Galley r Bool +teamSizeBelowLimit :: Member TeamStore r => Int -> Sem r Bool teamSizeBelowLimit teamSize = do - limit <- fromIntegral . fromRange <$> fanoutLimit + limit <- fromIntegral . fromRange <$> E.fanoutLimit let withinLimit = teamSize <= limit - view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case + E.getLegalHoldFlag >>= \case FeatureLegalHoldDisabledPermanently -> pure withinLimit FeatureLegalHoldDisabledByDefault -> pure withinLimit FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> @@ -1321,11 +1369,14 @@ addTeamMemberInternal :: Members '[ BrigAccess, Error TeamError, - Error NotATeamMember, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, TeamNotificationStore, - TeamStore + TeamStore, + P.TinyLog ] r => TeamId -> @@ -1333,21 +1384,21 @@ addTeamMemberInternal :: Maybe ConnId -> NewTeamMember -> TeamMemberList -> - Galley r TeamSize + Sem r TeamSize addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memList = do - Log.debug $ + P.debug $ Log.field "targets" (toByteString (new ^. userId)) . Log.field "action" (Log.val "Teams.addTeamMemberInternal") sizeBeforeAdd <- ensureNotTooLarge tid - liftSem $ E.createTeamMember tid new - cc <- liftSem $ filter (view managedConversation) <$> E.getTeamConversations tid - now <- liftIO getCurrentTime + E.createTeamMember tid new + cc <- filter (view managedConversation) <$> E.getTeamConversations tid + now <- input for_ cc $ \c -> do lcid <- qualifyLocal (c ^. conversationId) luid <- qualifyLocal (new ^. userId) - liftSem $ E.createMember lcid luid + E.createMember lcid luid let e = newEvent MemberJoin tid now & eventData ?~ EdMemberJoin (new ^. userId) - liftSem . E.push1 $ + E.push1 $ newPushLocal1 (memList ^. teamMemberListType) (new ^. userId) (TeamEvent e) (recipients origin new) & pushConn .~ originConn APITeamQueue.pushTeamEvent tid e return sizeBeforeAdd @@ -1368,7 +1419,6 @@ getTeamNotificationsH :: Members '[ BrigAccess, Error TeamError, - Error NotATeamMember, Error TeamNotificationError, TeamNotificationStore ] @@ -1377,19 +1427,19 @@ getTeamNotificationsH :: ::: Maybe ByteString {- NotificationId -} ::: Range 1 10000 Int32 ::: JSON -> - Galley r Response + Sem r Response getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do since <- parseSince json @Public.QueuedNotificationList <$> APITeamQueue.getTeamNotifications zusr since size where - parseSince :: Member (Error TeamNotificationError) r => Galley r (Maybe Public.NotificationId) + parseSince :: Member (Error TeamNotificationError) r => Sem r (Maybe Public.NotificationId) parseSince = maybe (pure Nothing) (fmap Just . parseUUID) sinceRaw - parseUUID :: Member (Error TeamNotificationError) r => ByteString -> Galley r Public.NotificationId + parseUUID :: Member (Error TeamNotificationError) r => ByteString -> Sem r Public.NotificationId parseUUID raw = maybe - (liftSem (throw InvalidTeamNotificationId)) + (throw InvalidTeamNotificationId) (pure . Id) ((UUID.fromASCIIBytes >=> isV1UUID) raw) @@ -1397,60 +1447,58 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do isV1UUID u = if UUID.version u == 1 then Just u else Nothing finishCreateTeam :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, Input UTCTime, TeamStore] r => Team -> TeamMember -> [TeamMember] -> Maybe ConnId -> - Galley r () + Sem r () finishCreateTeam team owner others zcon = do let zusr = owner ^. userId - liftSem $ - for_ (owner : others) $ - E.createTeamMember (team ^. teamId) - now <- liftIO getCurrentTime + for_ (owner : others) $ + E.createTeamMember (team ^. teamId) + now <- input let e = newEvent TeamCreate (team ^. teamId) now & eventData ?~ EdTeamCreate team let r = membersToRecipients Nothing others - liftSem . E.push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon + E.push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon -- FUTUREWORK: Get rid of CPS withBindingTeam :: - Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + Members '[Error TeamError, TeamStore] r => UserId -> - (TeamId -> Galley r b) -> - Galley r b + (TeamId -> Sem r b) -> + Sem r b withBindingTeam zusr callback = do - tid <- liftSem $ E.getOneUserTeam zusr >>= note TeamNotFound - binding <- liftSem $ E.getTeamBinding tid >>= note TeamNotFound + tid <- E.getOneUserTeam zusr >>= note TeamNotFound + binding <- E.getTeamBinding tid >>= note TeamNotFound case binding of Binding -> callback tid - NonBinding -> liftSem $ throw NotABindingTeamMember + NonBinding -> throw NotABindingTeamMember -getBindingTeamIdH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response +getBindingTeamIdH :: Members '[Error TeamError, TeamStore] r => UserId -> Sem r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r TeamId +getBindingTeamId :: Members '[Error TeamError, TeamStore] r => UserId -> Sem r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response +getBindingTeamMembersH :: Members '[Error TeamError, TeamStore] r => UserId -> Sem r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers getBindingTeamMembers :: Members '[ Error TeamError, - Error NotATeamMember, TeamStore ] r => UserId -> - Galley r TeamMemberList + Sem r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> getTeamMembersForFanout tid canUserJoinTeamH :: - Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => + Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamStore, TeamFeatureStore] r => TeamId -> - Galley r Response + Sem r Response canUserJoinTeamH tid = canUserJoinTeam tid >> pure empty -- This could be extended for more checks, for now we test only legalhold @@ -1459,102 +1507,106 @@ canUserJoinTeam :: '[ BrigAccess, Error LegalHoldError, LegalHoldStore, + TeamStore, TeamFeatureStore ] r => TeamId -> - Galley r () + Sem r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do - (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid + (TeamSize sizeBeforeJoin) <- E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) getTeamSearchVisibilityAvailableInternal :: - Member TeamFeatureStore r => + Members '[Input Opts, TeamFeatureStore] r => TeamId -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal tid = do -- TODO: This is just redundant given there is a decent default defConfig <- do - featureTeamSearchVisibility <- view (options . optSettings . setFeatureFlags . flagTeamSearchVisibility) + featureTeamSearchVisibility <- view (optSettings . setFeatureFlags . flagTeamSearchVisibility) <$> input pure . Public.TeamFeatureStatusNoConfig $ case featureTeamSearchVisibility of FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled - liftSem $ - fromMaybe defConfig - <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid + fromMaybe defConfig + <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternalH :: Member SearchVisibilityStore r => TeamId ::: JSON -> - Galley r Response + Sem r Response getSearchVisibilityInternalH (tid ::: _) = json <$> getSearchVisibilityInternal tid getSearchVisibilityInternal :: Member SearchVisibilityStore r => TeamId -> - Galley r TeamSearchVisibilityView + Sem r TeamSearchVisibilityView getSearchVisibilityInternal = - fmap TeamSearchVisibilityView . liftSem + fmap TeamSearchVisibilityView . SearchVisibilityData.getSearchVisibility setSearchVisibilityInternalH :: Members - '[ Error InvalidInput, - Error TeamError, - Error NotATeamMember, + '[ Error TeamError, + Input Opts, SearchVisibilityStore, - TeamFeatureStore + TeamFeatureStore, + WaiRoutes ] r => TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> - Galley r Response + Sem r Response setSearchVisibilityInternalH (tid ::: req ::: _) = do - setSearchVisibilityInternal tid =<< fromJsonBody req + setSearchVisibilityInternal tid =<< (fromJsonBody req) pure noContent setSearchVisibilityInternal :: - Members '[Error TeamError, Error NotATeamMember, SearchVisibilityStore, TeamFeatureStore] r => + Members + '[ Error TeamError, + Input Opts, + SearchVisibilityStore, + TeamFeatureStore + ] + r => TeamId -> TeamSearchVisibilityView -> - Galley r () + Sem r () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do status <- getTeamSearchVisibilityAvailableInternal tid - liftSem . unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ + unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ throw TeamSearchVisibilityNotEnabled - liftSem $ SearchVisibilityData.setSearchVisibility tid searchVisibility + SearchVisibilityData.setSearchVisibility tid searchVisibility userIsTeamOwnerH :: Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => TeamId ::: UserId ::: JSON -> - Galley r Response + Sem r Response userIsTeamOwnerH (tid ::: uid ::: _) = do userIsTeamOwner tid uid >>= \case True -> pure empty - False -> liftSem $ throw AccessDenied + False -> throw AccessDenied userIsTeamOwner :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> UserId -> - Galley r Bool + Sem r Bool userIsTeamOwner tid uid = do let asking = uid isTeamOwner . fst <$> getTeamMember asking tid uid -- Queues a team for async deletion queueTeamDeletion :: - Member (Error InternalError) r => + Members '[Error InternalError, Queue DeleteItem] r => TeamId -> UserId -> Maybe ConnId -> - Galley r () + Sem r () queueTeamDeletion tid zusr zcon = do - q <- view deleteQueue - ok <- Q.tryPush q (TeamItem tid zusr zcon) - liftSem . unless ok $ - throw DeleteQueueFull + ok <- E.tryPush (TeamItem tid zusr zcon) + 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 4498865cf33..19e49f76b1b 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -50,16 +50,17 @@ import qualified Data.Aeson as Aeson import Data.ByteString.Conversion hiding (fromList) import qualified Data.HashMap.Strict as HashMap import Data.Id -import Data.Proxy (Proxy (Proxy)) +import Data.Qualified import Data.String.Conversions (cs) +import Data.Time.Clock import Galley.API.Error as Galley import Galley.API.LegalHold import Galley.API.Teams (ensureNotTooLargeToActivateLegalHold) import Galley.API.Util -import Galley.App import Galley.Cassandra.Paging import Galley.Data.TeamFeatures import Galley.Effects +import Galley.Effects.BrigAccess import Galley.Effects.GundeckAccess import Galley.Effects.Paging import qualified Galley.Effects.SearchVisibilityStore as SearchVisibilityData @@ -69,20 +70,18 @@ import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush) import Galley.Options import Galley.Types.Teams hiding (newTeam) import Imports -import Network.HTTP.Client (Manager) import Network.Wai import Network.Wai.Predicate hiding (Error, or, result, setStatus) import Network.Wai.Utilities hiding (Error) +import Polysemy import Polysemy.Error -import Servant.API ((:<|>) ((:<|>))) -import qualified Servant.Client as Client +import Polysemy.Input +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Log -import Util.Options (Endpoint, epHost, epPort) import Wire.API.ErrorDescription 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 @@ -101,14 +100,14 @@ getFeatureStatus :: ] r ) => - (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) getFeatureStatus getter doauth tid = do case doauth of DoAuth uid -> do - zusrMembership <- liftSem $ getTeamMember tid uid + zusrMembership <- getTeamMember tid uid void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership DontDoAuth -> assertTeamExists tid @@ -126,15 +125,15 @@ setFeatureStatus :: ] r ) => - (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Sem r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> Public.TeamFeatureStatus a -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) setFeatureStatus setter doauth tid status = do case doauth of DoAuth uid -> do - zusrMembership <- liftSem $ getTeamMember tid uid + zusrMembership <- getTeamMember tid uid void $ permissionCheck (ChangeTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership DontDoAuth -> assertTeamExists tid @@ -152,43 +151,44 @@ getFeatureConfig :: ] r ) => - (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> UserId -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) getFeatureConfig getter zusr = do - mbTeam <- liftSem $ getOneUserTeam zusr + mbTeam <- getOneUserTeam zusr case mbTeam of Nothing -> getter (Left (Just zusr)) Just tid -> do - zusrMembership <- liftSem $ getTeamMember tid zusr + zusrMembership <- getTeamMember tid zusr void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership assertTeamExists tid getter (Right tid) getAllFeatureConfigs :: Members - '[ Error ActionError, - Error InternalError, + '[ BrigAccess, + Error ActionError, Error NotATeamMember, Error TeamError, + Input Opts, LegalHoldStore, TeamFeatureStore, TeamStore ] r => UserId -> - Galley r AllFeatureConfigs + Sem r AllFeatureConfigs getAllFeatureConfigs zusr = do - mbTeam <- liftSem $ getOneUserTeam zusr - zusrMembership <- maybe (pure Nothing) (liftSem . (flip getTeamMember zusr)) mbTeam + mbTeam <- getOneUserTeam zusr + zusrMembership <- maybe (pure Nothing) ((flip getTeamMember zusr)) mbTeam let getStatus :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a), Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r ) => - (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> - Galley r (Text, Aeson.Value) + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + Sem r (Text, Aeson.Value) getStatus getter = do when (isJust mbTeam) $ do void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership @@ -212,27 +212,29 @@ getAllFeatureConfigs zusr = do getAllFeaturesH :: Members - '[ Error ActionError, - Error InternalError, + '[ BrigAccess, + Error ActionError, Error TeamError, Error NotATeamMember, + Input Opts, LegalHoldStore, TeamFeatureStore, TeamStore ] r => UserId ::: TeamId ::: JSON -> - Galley r Response + Sem r Response getAllFeaturesH (uid ::: tid ::: _) = json <$> getAllFeatures uid tid getAllFeatures :: forall r. Members - '[ Error ActionError, - Error InternalError, + '[ BrigAccess, + Error ActionError, Error TeamError, Error NotATeamMember, + Input Opts, LegalHoldStore, TeamFeatureStore, TeamStore @@ -240,7 +242,7 @@ getAllFeatures :: r => UserId -> TeamId -> - Galley r Aeson.Value + Sem r Aeson.Value getAllFeatures uid tid = do Aeson.object <$> sequence @@ -261,8 +263,8 @@ getAllFeatures uid tid = do ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a) ) => - (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> - Galley r (Text, Aeson.Value) + (GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus a)) -> + Sem r (Text, Aeson.Value) getStatus getter = do status <- getFeatureStatus @a getter (DoAuth uid) tid let feature = Public.knownTeamFeatureName @a @@ -274,27 +276,27 @@ getFeatureStatusNoConfig :: HasStatusCol a, Member TeamFeatureStore r ) => - Galley r Public.TeamFeatureStatusValue -> + Sem r Public.TeamFeatureStatusValue -> TeamId -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) getFeatureStatusNoConfig getDefault tid = do defaultStatus <- Public.TeamFeatureStatusNoConfig <$> getDefault - liftSem $ fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid + fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid setFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, HasStatusCol a, - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r ) => - (Public.TeamFeatureStatusValue -> TeamId -> Galley r ()) -> + (Public.TeamFeatureStatusValue -> TeamId -> Sem r ()) -> TeamId -> Public.TeamFeatureStatus a -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) setFeatureStatusNoConfig applyState tid status = do applyState (Public.tfwoStatus status) tid - newStatus <- liftSem $ TeamFeatures.setFeatureStatusNoConfig @a tid status + newStatus <- TeamFeatures.setFeatureStatusNoConfig @a tid status pushFeatureConfigEvent tid $ Event.Event Event.Update (Public.knownTeamFeatureName @a) (EdFeatureWithoutConfigChanged newStatus) pure newStatus @@ -304,56 +306,56 @@ setFeatureStatusNoConfig applyState tid status = do type GetFeatureInternalParam = Either (Maybe UserId) TeamId getSSOStatusInternal :: - Member TeamFeatureStore r => + Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) getSSOStatusInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @'Public.TeamFeatureSSO getDef) where - getDef :: Galley r Public.TeamFeatureStatusValue + getDef :: Member (Input Opts) r => Sem r Public.TeamFeatureStatusValue getDef = - view (options . optSettings . setFeatureFlags . flagSSO) <&> \case + inputs (view (optSettings . setFeatureFlags . flagSSO)) <&> \case FeatureSSOEnabledByDefault -> Public.TeamFeatureEnabled FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled setSSOStatusInternal :: - Members '[Error TeamFeatureError, GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[Error TeamFeatureError, GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case - Public.TeamFeatureDisabled -> const (liftSem (throw DisableSsoNotImplemented)) + Public.TeamFeatureDisabled -> const (throw DisableSsoNotImplemented) Public.TeamFeatureEnabled -> const (pure ()) getTeamSearchVisibilityAvailableInternal :: - Member TeamFeatureStore r => + Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility getDef) where getDef = do - view (options . optSettings . setFeatureFlags . flagTeamSearchVisibility) <&> \case + inputs (view (optSettings . setFeatureFlags . flagTeamSearchVisibility)) <&> \case FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled setTeamSearchVisibilityAvailableInternal :: - Members '[GundeckAccess, SearchVisibilityStore, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, SearchVisibilityStore, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility $ \case - Public.TeamFeatureDisabled -> liftSem . SearchVisibilityData.resetSearchVisibility + Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility Public.TeamFeatureEnabled -> const (pure ()) getValidateSAMLEmailsInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) getValidateSAMLEmailsInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -365,16 +367,16 @@ getValidateSAMLEmailsInternal = getDef = pure Public.TeamFeatureDisabled setValidateSAMLEmailsInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () getDigitalSignaturesInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) getDigitalSignaturesInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -386,16 +388,16 @@ getDigitalSignaturesInternal = getDef = pure Public.TeamFeatureDisabled setDigitalSignaturesInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () getLegalholdStatusInternal :: - Members '[LegalHoldStore, TeamFeatureStore] r => + Members '[LegalHoldStore, TeamFeatureStore, TeamStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = pure $ Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled getLegalholdStatusInternal (Right tid) = do @@ -404,6 +406,7 @@ getLegalholdStatusInternal (Right tid) = do False -> Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled setLegalholdStatusInternal :: + forall p r. ( Paging p, Bounded (PagingBounds p TeamMember), Members @@ -424,25 +427,28 @@ setLegalholdStatusInternal :: FederatorAccess, FireAndForget, GundeckAccess, + Input (Local ()), + Input UTCTime, LegalHoldStore, ListItems LegacyPaging ConvId, MemberStore, TeamFeatureStore, TeamStore, - TeamMemberStore p + TeamMemberStore p, + P.TinyLog ] r ) => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do do -- this extra do is to encapsulate the assertions running before the actual operation. -- 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) - liftSem $ case featureLegalHold of + featureLegalHold <- getLegalHoldFlag + case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do pure () FeatureLegalHoldDisabledPermanently -> do @@ -452,68 +458,74 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do -- we're good to update the status now. case statusValue of - Public.TeamFeatureDisabled -> removeSettings' tid + Public.TeamFeatureDisabled -> removeSettings' @p tid Public.TeamFeatureEnabled -> do ensureNotTooLargeToActivateLegalHold tid - liftSem $ TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status + TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status getFileSharingInternal :: - Member TeamFeatureStore r => + Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) getFileSharingInternal = getFeatureStatusWithDefaultConfig @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just getFeatureStatusWithDefaultConfig :: forall (a :: TeamFeatureName) r. - (KnownTeamFeatureName a, HasStatusCol a, FeatureHasNoConfig a, Member TeamFeatureStore r) => + ( KnownTeamFeatureName a, + HasStatusCol a, + FeatureHasNoConfig a, + Members '[Input Opts, TeamFeatureStore] r + ) => Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus a)) -> Maybe TeamId -> - Galley r (Public.TeamFeatureStatus a) + Sem r (Public.TeamFeatureStatus a) getFeatureStatusWithDefaultConfig lens' = maybe (Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @a getDef) where - getDef :: Galley r Public.TeamFeatureStatusValue + getDef :: Sem r Public.TeamFeatureStatusValue getDef = - view (options . optSettings . setFeatureFlags . lens') + inputs (view (optSettings . setFeatureFlags . lens')) <&> Public.tfwoStatus . view unDefaults setFileSharingInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) setFileSharingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () getAppLockInternal :: - Member TeamFeatureStore r => + Members '[Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) getAppLockInternal mbtid = do - Defaults defaultStatus <- view (options . optSettings . setFeatureFlags . flagAppLockDefaults) + Defaults defaultStatus <- inputs (view (optSettings . setFeatureFlags . flagAppLockDefaults)) status <- - liftSem $ - join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) + join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) pure $ fromMaybe defaultStatus status setAppLockInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore, Error TeamFeatureError] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, Error TeamFeatureError, P.TinyLog] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ - liftSem $ throw AppLockinactivityTimeoutTooLow + throw AppLockinactivityTimeoutTooLow let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureAppLock (EdFeatureApplockChanged status) - (liftSem $ TeamFeatures.setApplockFeatureStatus tid status) <* pushEvent + (TeamFeatures.setApplockFeatureStatus tid status) <* pushEvent -getClassifiedDomainsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) +getClassifiedDomainsInternal :: + Member (Input Opts) r => + GetFeatureInternalParam -> + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) getClassifiedDomainsInternal _mbtid = do - globalConfig <- view (options . optSettings . setFeatureFlags . flagClassifiedDomains) + globalConfig <- inputs (view (optSettings . setFeatureFlags . flagClassifiedDomains)) let config = globalConfig pure $ case Public.tfwcStatus config of Public.TeamFeatureDisabled -> @@ -521,9 +533,9 @@ getClassifiedDomainsInternal _mbtid = do Public.TeamFeatureEnabled -> config getConferenceCallingInternal :: - Members '[Error InternalError, TeamFeatureStore] r => + Members '[BrigAccess, Input Opts, TeamFeatureStore] r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do getFeatureConfigViaAccount @'Public.TeamFeatureConferenceCalling uid getConferenceCallingInternal (Left Nothing) = do @@ -532,44 +544,43 @@ getConferenceCallingInternal (Right tid) = do getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) setConferenceCallingInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) setConferenceCallingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () getSelfDeletingMessagesInternal :: Member TeamFeatureStore r => GetFeatureInternalParam -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) getSelfDeletingMessagesInternal = \case Left _ -> pure Public.defaultSelfDeletingMessagesStatus Right tid -> - liftSem $ - TeamFeatures.getSelfDeletingMessagesStatus tid - <&> maybe Public.defaultSelfDeletingMessagesStatus id + TeamFeatures.getSelfDeletingMessagesStatus tid + <&> maybe Public.defaultSelfDeletingMessagesStatus id setSelfDeletingMessagesInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages -> - Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) + Sem r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) setSelfDeletingMessagesInternal tid st = do let pushEvent = pushFeatureConfigEvent tid $ Event.Event Event.Update Public.TeamFeatureSelfDeletingMessages (EdFeatureSelfDeletingMessagesChanged st) - (liftSem $ TeamFeatures.setSelfDeletingMessagesStatus tid st) <* pushEvent + (TeamFeatures.setSelfDeletingMessagesStatus tid st) <* pushEvent pushFeatureConfigEvent :: - Members '[GundeckAccess, TeamStore] r => + Members '[GundeckAccess, TeamStore, P.TinyLog] r => TeamId -> Event.Event -> - Galley r () + Sem r () pushFeatureConfigEvent tid event = do memList <- getTeamMembersForFanout tid when ((memList ^. teamMemberListType) == ListTruncated) $ do - Log.warn $ + P.warn $ Log.field "action" (Log.val "Features.pushFeatureConfigEvent") . Log.field "feature" (Log.val (toByteString' . Event._eventFeatureName $ event)) . Log.field "team" (Log.val (cs . show $ tid)) @@ -577,49 +588,14 @@ pushFeatureConfigEvent tid event = do let recipients = membersToRecipients Nothing (memList ^. teamMembers) for_ (newPush (memList ^. teamMemberListType) Nothing (FeatureConfigEvent event) recipients) - (liftSem . push1) + (push1) -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) getFeatureConfigViaAccount :: - (flag ~ 'Public.TeamFeatureConferenceCalling, Member (Error InternalError) r) => + ( flag ~ 'Public.TeamFeatureConferenceCalling, + Member BrigAccess r + ) => UserId -> - Galley r (Public.TeamFeatureStatus flag) -getFeatureConfigViaAccount uid = do - mgr <- asks (^. manager) - brigep <- asks (^. brig) - getAccountFeatureConfigClient brigep mgr uid >>= handleResp - where - handleResp :: - Member (Error InternalError) r => - Either Client.ClientError Public.TeamFeatureStatusNoConfig -> - Galley r Public.TeamFeatureStatusNoConfig - handleResp (Right cfg) = pure cfg - handleResp (Left errmsg) = liftSem . throw . InternalErrorWithDescription . cs . show $ errmsg - - getAccountFeatureConfigClient :: - (HasCallStack, MonadIO m) => - Endpoint -> - Manager -> - UserId -> - m (Either Client.ClientError Public.TeamFeatureStatusNoConfig) - getAccountFeatureConfigClient brigep mgr = runHereClientM brigep mgr . getAccountFeatureConfigClientM - - getAccountFeatureConfigClientM :: - UserId -> Client.ClientM Public.TeamFeatureStatusNoConfig - ( _ - :<|> getAccountFeatureConfigClientM - :<|> _ - :<|> _ - ) = Client.client (Proxy @IAPI.API) - - runHereClientM :: - (HasCallStack, MonadIO m) => - Endpoint -> - Manager -> - Client.ClientM a -> - m (Either Client.ClientError a) - runHereClientM brigep mgr action = do - let env = Client.mkClientEnv mgr baseurl - baseurl = Client.BaseUrl Client.Http (cs $ brigep ^. epHost) (fromIntegral $ brigep ^. epPort) "" - liftIO $ Client.runClientM action env + Sem r (Public.TeamFeatureStatus flag) +getFeatureConfigViaAccount = getAccountFeatureConfigClient diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index 0836369ee8a..c84918ccd53 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -41,15 +41,11 @@ where import Brig.Types.Intra (accountUser) import Brig.Types.User (userTeam) -import Control.Monad.Catch -import Control.Retry (exponentialBackoff, limitRetries, retrying) import Data.Id import Data.Json.Util (toJSONObject) import qualified Data.List1 as List1 import Data.Range (Range) -import qualified Data.UUID.V1 as UUID import Galley.API.Error -import Galley.App import qualified Galley.Data.TeamNotifications as DataTeamQueue import Galley.Effects import Galley.Effects.BrigAccess as Intra @@ -57,8 +53,7 @@ import qualified Galley.Effects.TeamNotificationStore as E import Galley.Types.Teams hiding (newTeam) import Gundeck.Types.Notification import Imports -import Network.HTTP.Types -import Network.Wai.Utilities hiding (Error) +import Polysemy import Polysemy.Error getTeamNotifications :: @@ -66,27 +61,17 @@ getTeamNotifications :: UserId -> Maybe NotificationId -> Range 1 10000 Int32 -> - Galley r QueuedNotificationList + Sem r QueuedNotificationList getTeamNotifications zusr since size = do - tid <- liftSem . (note TeamNotFound =<<) $ (userTeam . accountUser =<<) <$> Intra.getUser zusr - page <- liftSem $ E.getTeamNotifications tid since size + tid <- (note TeamNotFound =<<) $ (userTeam . accountUser =<<) <$> Intra.getUser zusr + page <- E.getTeamNotifications tid since size pure $ queuedNotificationList (toList (DataTeamQueue.resultSeq page)) (DataTeamQueue.resultHasMore page) Nothing -pushTeamEvent :: Member TeamNotificationStore r => TeamId -> Event -> Galley r () +pushTeamEvent :: Member TeamNotificationStore r => TeamId -> Event -> Sem r () pushTeamEvent tid evt = do - 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 :: IO NotificationId -mkNotificationId = do - ni <- fmap Id <$> retrying x10 fun (const (liftIO UUID.nextUUID)) - maybe (throwM err) return ni - where - x10 = limitRetries 10 <> exponentialBackoff 10 - fun = const (return . isNothing) - err = mkError status500 "internal-error" "unable to generate notification ID" + nid <- E.mkNotificationId + E.createTeamNotification tid nid (List1.singleton $ toJSONObject evt) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 98344a35462..af64045f7b6 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -65,9 +65,9 @@ module Galley.API.Update ) where +import Control.Error.Util (hush) import Control.Lens import Control.Monad.State -import Control.Monad.Trans.Maybe import Data.Code import Data.Either.Extra (mapRight) import Data.Id @@ -80,11 +80,10 @@ 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.LegalHold.Conflicts import Galley.API.Mapping import Galley.API.Message import Galley.API.Util -import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) @@ -99,6 +98,7 @@ import qualified Galley.Effects.GundeckAccess as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.ServiceStore as E import qualified Galley.Effects.TeamStore as E +import Galley.Effects.WaiRoutes import Galley.Intra.Push import Galley.Options import Galley.Types @@ -117,6 +117,8 @@ import Network.Wai.Predicate hiding (Error, and, failure, setStatus, _1, _2) import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Code as Public import Wire.API.Conversation.Role (roleNameWireAdmin) @@ -137,13 +139,17 @@ acceptConvH :: Error ConversationError, Error InternalError, GundeckAccess, - MemberStore + Input (Local ()), + Input UTCTime, + MemberStore, + TinyLog ] r => UserId ::: Maybe ConnId ::: ConvId -> - Galley r Response -acceptConvH (usr ::: conn ::: cnv) = - setStatus status200 . json <$> acceptConv usr conn cnv + Sem r Response +acceptConvH (usr ::: conn ::: cnv) = do + lusr <- qualifyLocal usr + setStatus status200 . json <$> acceptConv lusr conn cnv acceptConv :: Members @@ -152,18 +158,20 @@ acceptConv :: Error ConversationError, Error InternalError, GundeckAccess, - MemberStore + Input UTCTime, + MemberStore, + TinyLog ] r => - UserId -> + Local UserId -> Maybe ConnId -> ConvId -> - Galley r Conversation -acceptConv usr conn cnv = do + Sem r Conversation +acceptConv lusr conn cnv = do conv <- - liftSem $ E.getConversation cnv >>= note ConvNotFound - conv' <- acceptOne2One usr conv conn - conversationView usr conv' + E.getConversation cnv >>= note ConvNotFound + conv' <- acceptOne2One lusr conv conn + conversationView lusr conv' blockConvH :: Members @@ -174,7 +182,7 @@ blockConvH :: ] r => UserId ::: ConvId -> - Galley r Response + Sem r Response blockConvH (zusr ::: cnv) = empty <$ blockConv zusr cnv @@ -188,13 +196,13 @@ blockConv :: r => UserId -> ConvId -> - Galley r () + Sem r () blockConv zusr cnv = do - conv <- liftSem $ E.getConversation cnv >>= note ConvNotFound + conv <- E.getConversation cnv >>= note ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - liftSem . throw . InvalidOp . Data.convType $ conv + throw . InvalidOp . Data.convType $ conv let mems = Data.convLocalMembers conv - when (zusr `isMember` mems) . liftSem $ + when (zusr `isMember` mems) $ E.deleteMembers cnv (UserList [zusr] []) unblockConvH :: @@ -204,13 +212,17 @@ unblockConvH :: Error ConversationError, Error InternalError, GundeckAccess, - MemberStore + Input (Local ()), + Input UTCTime, + MemberStore, + TinyLog ] r => UserId ::: Maybe ConnId ::: ConvId -> - Galley r Response -unblockConvH (usr ::: conn ::: cnv) = - setStatus status200 . json <$> unblockConv usr conn cnv + Sem r Response +unblockConvH (usr ::: conn ::: cnv) = do + lusr <- qualifyLocal usr + setStatus status200 . json <$> unblockConv lusr conn cnv unblockConv :: Members @@ -219,20 +231,22 @@ unblockConv :: Error ConversationError, Error InternalError, GundeckAccess, - MemberStore + Input UTCTime, + MemberStore, + TinyLog ] r => - UserId -> + Local UserId -> Maybe ConnId -> ConvId -> - Galley r Conversation -unblockConv usr conn cnv = do + Sem r Conversation +unblockConv lusr conn cnv = do conv <- - liftSem $ E.getConversation cnv >>= note ConvNotFound + E.getConversation cnv >>= note ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - liftSem . throw . InvalidOp . Data.convType $ conv - conv' <- acceptOne2One usr conv conn - conversationView usr conv' + throw . InvalidOp . Data.convType $ conv + conv' <- acceptOne2One lusr conv conn + conversationView lusr conv' -- conversation updates @@ -255,17 +269,17 @@ updateConversationAccess :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Public.ConversationAccessData -> - Galley r (UpdateResult Event) -updateConversationAccess usr con qcnv update = do - lusr <- qualifyLocal usr + Sem r (UpdateResult Event) +updateConversationAccess lusr con qcnv update = do let doUpdate = foldQualified lusr @@ -286,18 +300,18 @@ updateConversationAccessUnqualified :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.ConversationAccessData -> - Galley r (UpdateResult Event) -updateConversationAccessUnqualified usr zcon cnv update = do - lusr <- qualifyLocal usr - lcnv <- qualifyLocal cnv + Sem r (UpdateResult Event) +updateConversationAccessUnqualified lusr zcon cnv update = do + let lcnv = qualifyAs lusr cnv updateLocalConversationAccess lcnv lusr zcon update updateLocalConversationAccess :: @@ -313,6 +327,7 @@ updateLocalConversationAccess :: FederatorAccess, FireAndForget, GundeckAccess, + Input UTCTime, MemberStore, TeamStore ] @@ -321,7 +336,7 @@ updateLocalConversationAccess :: Local UserId -> ConnId -> Public.ConversationAccessData -> - Galley r (UpdateResult Event) + Sem r (UpdateResult Event) updateLocalConversationAccess lcnv lusr con = getUpdateResult . updateLocalConversation lcnv (qUntagged lusr) (Just con) @@ -332,8 +347,8 @@ updateRemoteConversationAccess :: Local UserId -> ConnId -> Public.ConversationAccessData -> - Galley r (UpdateResult Event) -updateRemoteConversationAccess _ _ _ _ = liftSem $ throw FederationNotImplemented + Sem r (UpdateResult Event) +updateRemoteConversationAccess _ _ _ _ = throw FederationNotImplemented updateConversationReceiptMode :: Members @@ -343,17 +358,17 @@ updateConversationReceiptMode :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => Members '[Error FederationError] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Public.ConversationReceiptModeUpdate -> - Galley r (UpdateResult Event) -updateConversationReceiptMode usr zcon qcnv update = do - lusr <- qualifyLocal usr + Sem r (UpdateResult Event) +updateConversationReceiptMode lusr zcon qcnv update = do let doUpdate = foldQualified lusr @@ -369,17 +384,17 @@ updateConversationReceiptModeUnqualified :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.ConversationReceiptModeUpdate -> - Galley r (UpdateResult Event) -updateConversationReceiptModeUnqualified usr zcon cnv update = do - lusr <- qualifyLocal usr - lcnv <- qualifyLocal cnv + Sem r (UpdateResult Event) +updateConversationReceiptModeUnqualified lusr zcon cnv update = do + let lcnv = qualifyAs lusr cnv updateLocalConversationReceiptMode lcnv lusr zcon update updateLocalConversationReceiptMode :: @@ -390,14 +405,15 @@ updateLocalConversationReceiptMode :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => Local ConvId -> Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> - Galley r (UpdateResult Event) + Sem r (UpdateResult Event) updateLocalConversationReceiptMode lcnv lusr con update = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) update @@ -408,8 +424,8 @@ updateRemoteConversationReceiptMode :: Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> - Galley r (UpdateResult Event) -updateRemoteConversationReceiptMode _ _ _ _ = liftSem $ throw FederationNotImplemented + Sem r (UpdateResult Event) +updateRemoteConversationReceiptMode _ _ _ _ = throw FederationNotImplemented updateConversationMessageTimerUnqualified :: Members @@ -419,17 +435,17 @@ updateConversationMessageTimerUnqualified :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.ConversationMessageTimerUpdate -> - Galley r (UpdateResult Event) -updateConversationMessageTimerUnqualified usr zcon cnv update = do - lusr <- qualifyLocal usr - lcnv <- qualifyLocal cnv + Sem r (UpdateResult Event) +updateConversationMessageTimerUnqualified lusr zcon cnv update = do + let lcnv = qualifyAs lusr cnv updateLocalConversationMessageTimer lusr zcon lcnv update updateConversationMessageTimer :: @@ -441,20 +457,20 @@ updateConversationMessageTimer :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Public.ConversationMessageTimerUpdate -> - Galley r (UpdateResult Event) -updateConversationMessageTimer usr zcon qcnv update = do - lusr <- qualifyLocal usr + Sem r (UpdateResult Event) +updateConversationMessageTimer lusr zcon qcnv update = do foldQualified lusr (updateLocalConversationMessageTimer lusr zcon) - (\_ _ -> liftSem (throw FederationNotImplemented)) + (\_ _ -> throw FederationNotImplemented) qcnv update @@ -466,14 +482,15 @@ updateLocalConversationMessageTimer :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationMessageTimerUpdate -> - Galley r (UpdateResult Event) + Sem r (UpdateResult Event) updateLocalConversationMessageTimer lusr con lcnv update = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) update @@ -490,19 +507,20 @@ deleteLocalConversation :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, TeamStore ] r => Local UserId -> ConnId -> Local ConvId -> - Galley r (UpdateResult Event) + Sem r (UpdateResult Event) deleteLocalConversation lusr con lcnv = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationDelete -getUpdateResult :: Functor m => MaybeT m a -> m (UpdateResult a) -getUpdateResult = fmap (maybe Unchanged Updated) . runMaybeT +getUpdateResult :: Sem (Error NoChanges ': r) a -> Sem r (UpdateResult a) +getUpdateResult = fmap (either (const Unchanged) Updated) . runError addCodeH :: Members @@ -510,13 +528,17 @@ addCodeH :: ConversationStore, Error ConversationError, ExternalAccess, - GundeckAccess + GundeckAccess, + Input (Local ()), + Input UTCTime ] r => UserId ::: ConnId ::: ConvId -> - Galley r Response -addCodeH (usr ::: zcon ::: cnv) = - addCode usr zcon cnv <&> \case + Sem r Response +addCodeH (usr ::: zcon ::: cnv) = do + lusr <- qualifyLocal usr + lcnv <- qualifyLocal cnv + addCode lusr zcon lcnv <&> \case CodeAdded event -> json event & setStatus status201 CodeAlreadyExisted conversationCode -> json conversationCode & setStatus status200 @@ -531,39 +553,37 @@ addCode :: ConversationStore, Error ConversationError, ExternalAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> - ConvId -> - Galley r AddCodeResult -addCode usr zcon cnv = do - localDomain <- viewFederationDomain - let qcnv = Qualified cnv localDomain - qusr = Qualified usr localDomain - conv <- liftSem $ E.getConversation cnv >>= note ConvNotFound - ensureConvMember (Data.convLocalMembers conv) usr - liftSem $ ensureAccess conv CodeAccess + Local ConvId -> + Sem r AddCodeResult +addCode lusr zcon lcnv = do + conv <- E.getConversation (tUnqualified lcnv) >>= note ConvNotFound + ensureConvMember (Data.convLocalMembers conv) (tUnqualified lusr) + ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv - key <- mkKey cnv - mCode <- liftSem $ E.getCode key ReusableCode + key <- E.makeKey (tUnqualified lcnv) + mCode <- E.getCode key ReusableCode case mCode of Nothing -> do - code <- generate cnv ReusableCode (Timeout 3600 * 24 * 365) -- one year TODO: configurable - liftSem $ E.createCode code - now <- liftIO getCurrentTime + code <- E.generateCode (tUnqualified lcnv) ReusableCode (Timeout 3600 * 24 * 365) -- one year FUTUREWORK: configurable + E.createCode code + now <- input conversationCode <- createCode code - let event = Event ConvCodeUpdate qcnv qusr now (EdConvCodeUpdate conversationCode) - pushConversationEvent (Just zcon) event (map lmId users) bots + let event = Event ConvCodeUpdate (qUntagged lcnv) (qUntagged lusr) now (EdConvCodeUpdate conversationCode) + pushConversationEvent (Just zcon) event (qualifyAs lusr (map lmId users)) bots pure $ CodeAdded event Just code -> do conversationCode <- createCode code pure $ CodeAlreadyExisted conversationCode where - createCode :: Code -> Galley r ConversationCode + createCode :: Code -> Sem r ConversationCode createCode code = do - urlPrefix <- view $ options . optSettings . setConversationCodeURI + urlPrefix <- E.getConversationCodeURI return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix rmCodeH :: @@ -572,13 +592,17 @@ rmCodeH :: ConversationStore, Error ConversationError, ExternalAccess, - GundeckAccess + GundeckAccess, + Input (Local ()), + Input UTCTime ] r => UserId ::: ConnId ::: ConvId -> - Galley r Response -rmCodeH (usr ::: zcon ::: cnv) = - setStatus status200 . json <$> rmCode usr zcon cnv + Sem r Response +rmCodeH (usr ::: zcon ::: cnv) = do + lusr <- qualifyLocal usr + lcnv <- qualifyLocal cnv + setStatus status200 . json <$> rmCode lusr zcon lcnv rmCode :: Members @@ -586,27 +610,25 @@ rmCode :: ConversationStore, Error ConversationError, ExternalAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> - ConvId -> - Galley r Public.Event -rmCode usr zcon cnv = do - localDomain <- viewFederationDomain - let qcnv = Qualified cnv localDomain - qusr = Qualified usr localDomain + Local ConvId -> + Sem r Public.Event +rmCode lusr zcon lcnv = do conv <- - liftSem $ E.getConversation cnv >>= note ConvNotFound - ensureConvMember (Data.convLocalMembers conv) usr - liftSem $ ensureAccess conv CodeAccess + E.getConversation (tUnqualified lcnv) >>= note ConvNotFound + ensureConvMember (Data.convLocalMembers conv) (tUnqualified lusr) + ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv - key <- mkKey cnv - liftSem $ E.deleteCode key ReusableCode - now <- liftIO getCurrentTime - let event = Event ConvCodeDelete qcnv qusr now EdConvCodeDelete - pushConversationEvent (Just zcon) event (map lmId users) bots + key <- E.makeKey (tUnqualified lcnv) + E.deleteCode key ReusableCode + now <- input + let event = Event ConvCodeDelete (qUntagged lcnv) (qUntagged lusr) now EdConvCodeDelete + pushConversationEvent (Just zcon) event (qualifyAs lusr (map lmId users)) bots pure event getCodeH :: @@ -618,7 +640,7 @@ getCodeH :: ] r => UserId ::: ConvId -> - Galley r Response + Sem r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv @@ -632,25 +654,25 @@ getCode :: r => UserId -> ConvId -> - Galley r Public.ConversationCode + Sem r Public.ConversationCode getCode usr cnv = do conv <- - liftSem $ E.getConversation cnv >>= note ConvNotFound - liftSem $ ensureAccess conv CodeAccess + E.getConversation cnv >>= note ConvNotFound + ensureAccess conv CodeAccess ensureConvMember (Data.convLocalMembers conv) usr - key <- mkKey cnv - c <- liftSem $ E.getCode key ReusableCode >>= note CodeNotFound + key <- E.makeKey cnv + c <- E.getCode key ReusableCode >>= note CodeNotFound returnCode c -returnCode :: Code -> Galley r Public.ConversationCode +returnCode :: Member CodeStore r => Code -> Sem r Public.ConversationCode returnCode c = do - urlPrefix <- view $ options . optSettings . setConversationCodeURI + urlPrefix <- E.getConversationCodeURI pure $ Public.mkConversationCode (codeKey c) (codeValue c) urlPrefix checkReusableCodeH :: - Members '[CodeStore, Error CodeError, Error InvalidInput] r => + Members '[CodeStore, Error CodeError, WaiRoutes] r => JsonRequest Public.ConversationCode -> - Galley r Response + Sem r Response checkReusableCodeH req = do convCode <- fromJsonBody req checkReusableCode convCode @@ -659,7 +681,7 @@ checkReusableCodeH req = do checkReusableCode :: Members '[CodeStore, Error CodeError] r => Public.ConversationCode -> - Galley r () + Sem r () checkReusableCode convCode = void $ verifyReusableCode convCode @@ -672,20 +694,23 @@ joinConversationByReusableCodeH :: Error ActionError, Error CodeError, Error ConversationError, - Error FederationError, - Error InvalidInput, Error NotATeamMember, ExternalAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> - Galley r Response + Sem r Response joinConversationByReusableCodeH (zusr ::: zcon ::: req) = do + lusr <- qualifyLocal zusr convCode <- fromJsonBody req - handleUpdateResult <$> joinConversationByReusableCode zusr zcon convCode + handleUpdateResult <$> joinConversationByReusableCode lusr zcon convCode joinConversationByReusableCode :: Members @@ -695,44 +720,46 @@ joinConversationByReusableCode :: Error ActionError, Error CodeError, Error ConversationError, - Error FederationError, - Error InvalidInput, Error NotATeamMember, FederatorAccess, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> Public.ConversationCode -> - Galley r (UpdateResult Event) -joinConversationByReusableCode zusr zcon convCode = do + Sem r (UpdateResult Event) +joinConversationByReusableCode lusr zcon convCode = do c <- verifyReusableCode convCode - joinConversation zusr zcon (codeConversation c) CodeAccess + joinConversation lusr zcon (codeConversation c) CodeAccess joinConversationByIdH :: Members '[ BrigAccess, - ConversationStore, FederatorAccess, + ConversationStore, Error ActionError, Error ConversationError, - Error FederationError, - Error InvalidInput, Error NotATeamMember, ExternalAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, TeamStore ] r => UserId ::: ConnId ::: ConvId ::: JSON -> - Galley r Response -joinConversationByIdH (zusr ::: zcon ::: cnv ::: _) = - handleUpdateResult <$> joinConversationById zusr zcon cnv + Sem r Response +joinConversationByIdH (zusr ::: zcon ::: cnv ::: _) = do + lusr <- qualifyLocal zusr + handleUpdateResult <$> joinConversationById lusr zcon cnv joinConversationById :: Members @@ -741,21 +768,21 @@ joinConversationById :: ConversationStore, Error ActionError, Error ConversationError, - Error FederationError, - Error InvalidInput, Error NotATeamMember, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> - Galley r (UpdateResult Event) -joinConversationById zusr zcon cnv = - joinConversation zusr zcon cnv LinkAccess + Sem r (UpdateResult Event) +joinConversationById lusr zcon cnv = + joinConversation lusr zcon cnv LinkAccess joinConversation :: Members @@ -764,41 +791,39 @@ joinConversation :: FederatorAccess, Error ActionError, Error ConversationError, - Error FederationError, - Error InvalidInput, Error NotATeamMember, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Access -> - Galley r (UpdateResult Event) -joinConversation zusr zcon cnv access = do - lusr <- qualifyLocal zusr - lcnv <- qualifyLocal cnv - conv <- ensureConversationAccess zusr cnv access - liftSem . ensureGroupConversation $ conv + Sem r (UpdateResult Event) +joinConversation lusr zcon cnv access = do + let lcnv = qualifyAs lusr cnv + conv <- ensureConversationAccess (tUnqualified lusr) cnv access + ensureGroupConversation $ conv -- FUTUREWORK: remote users? - ensureMemberLimit (toList $ Data.convLocalMembers conv) [zusr] + ensureMemberLimit (toList $ Data.convLocalMembers conv) [tUnqualified lusr] getUpdateResult $ do -- NOTE: When joining conversations, all users become members -- as this is our desired behavior for these types of conversations -- where there is no way to control who joins, etc. - let users = filter (notIsConvMember lusr conv) [zusr] + let users = filter (notIsConvMember lusr conv) [tUnqualified lusr] (extraTargets, action) <- addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember - lift $ - notifyConversationAction - (qUntagged lusr) - (Just zcon) - lcnv - (convBotsAndMembers conv <> extraTargets) - (conversationAction action) + notifyConversationAction + (qUntagged lusr) + (Just zcon) + lcnv + (convBotsAndMembers conv <> extraTargets) + (conversationAction action) addMembersUnqualified :: Members @@ -813,19 +838,21 @@ addMembersUnqualified :: ExternalAccess, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.Invite -> - Galley r (UpdateResult Event) -addMembersUnqualified zusr zcon cnv (Public.Invite users role) = do - qusers <- traverse (fmap qUntagged . qualifyLocal) (toNonEmpty users) - addMembers zusr zcon cnv (Public.InviteQualified qusers role) + Sem r (UpdateResult Event) +addMembersUnqualified lusr zcon cnv (Public.Invite users role) = do + let qusers = fmap (qUntagged . qualifyAs lusr) (toNonEmpty users) + addMembers lusr zcon cnv (Public.InviteQualified qusers role) addMembers :: Members @@ -840,19 +867,20 @@ addMembers :: ExternalAccess, FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, LegalHoldStore, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.InviteQualified -> - Galley r (UpdateResult Event) -addMembers zusr zcon cnv (Public.InviteQualified users role) = do - lusr <- qualifyLocal zusr - lcnv <- qualifyLocal cnv + Sem r (UpdateResult Event) +addMembers lusr zcon cnv (Public.InviteQualified users role) = do + let lcnv = qualifyAs lusr cnv getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just zcon) $ ConversationJoin users role @@ -861,39 +889,37 @@ updateSelfMember :: Members '[ ConversationStore, Error ConversationError, - GundeckAccess, ExternalAccess, + GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Public.MemberUpdate -> - Galley r () -updateSelfMember zusr zcon qcnv update = do - lusr <- qualifyLocal zusr - exists <- liftSem $ foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr - liftSem . unless exists . throw $ ConvNotFound - liftSem $ E.setSelfMember qcnv lusr update - now <- liftIO getCurrentTime + Sem r () +updateSelfMember lusr zcon qcnv update = do + exists <- foldQualified lusr checkLocalMembership checkRemoteMembership qcnv + unless exists . throw $ ConvNotFound + E.setSelfMember qcnv lusr update + now <- input let e = Event MemberStateUpdate qcnv (qUntagged lusr) now (EdMemberUpdate (updateData lusr)) - pushConversationEvent (Just zcon) e [zusr] [] + pushConversationEvent (Just zcon) e (fmap pure lusr) [] where checkLocalMembership :: Members '[MemberStore] r => Local ConvId -> - Local UserId -> Sem r Bool - checkLocalMembership lcnv lusr = + checkLocalMembership lcnv = isMember (tUnqualified lusr) <$> E.getLocalMembers (tUnqualified lcnv) checkRemoteMembership :: Members '[ConversationStore] r => Remote ConvId -> - Local UserId -> Sem r Bool - checkRemoteMembership rcnv lusr = + checkRemoteMembership rcnv = isJust . Map.lookup rcnv <$> E.getRemoteConversationStatus (tUnqualified lusr) [rcnv] updateData luid = @@ -914,17 +940,18 @@ updateUnqualifiedSelfMember :: Error ConversationError, ExternalAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.MemberUpdate -> - Galley r () -updateUnqualifiedSelfMember zusr zcon cnv update = do - lcnv <- qualifyLocal cnv - updateSelfMember zusr zcon (qUntagged lcnv) update + Sem r () +updateUnqualifiedSelfMember lusr zcon cnv update = do + let lcnv = qualifyAs lusr cnv + updateSelfMember lusr zcon (qUntagged lcnv) update updateOtherMemberUnqualified :: Members @@ -935,19 +962,19 @@ updateOtherMemberUnqualified :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> UserId -> Public.OtherMemberUpdate -> - Galley r () -updateOtherMemberUnqualified zusr zcon cnv victim update = do - lusr <- qualifyLocal zusr - lcnv <- qualifyLocal cnv - lvictim <- qualifyLocal victim + Sem r () +updateOtherMemberUnqualified lusr zcon cnv victim update = do + let lcnv = qualifyAs lusr cnv + let lvictim = qualifyAs lusr victim updateOtherMemberLocalConv lcnv lusr zcon (qUntagged lvictim) update updateOtherMember :: @@ -960,17 +987,17 @@ updateOtherMember :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley r () -updateOtherMember zusr zcon qcnv qvictim update = do - lusr <- qualifyLocal zusr + Sem r () +updateOtherMember lusr zcon qcnv qvictim update = do let doUpdate = foldQualified lusr updateOtherMemberLocalConv updateOtherMemberRemoteConv doUpdate qcnv lusr zcon qvictim update @@ -983,6 +1010,7 @@ updateOtherMemberLocalConv :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => @@ -991,9 +1019,9 @@ updateOtherMemberLocalConv :: ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley r () + Sem r () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do - lift . liftSem . when (qUntagged lusr == qvictim) $ + when (qUntagged lusr == qvictim) $ throw InvalidTargetUserOp updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationMemberUpdate qvictim update @@ -1005,8 +1033,8 @@ updateOtherMemberRemoteConv :: ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley r () -updateOtherMemberRemoteConv _ _ _ _ _ = liftSem $ throw FederationNotImplemented + Sem r () +updateOtherMemberRemoteConv _ _ _ _ _ = throw FederationNotImplemented removeMemberUnqualified :: Members @@ -1017,18 +1045,19 @@ removeMemberUnqualified :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> UserId -> - Galley r RemoveFromConversationResponse -removeMemberUnqualified zusr con cnv victim = do - lcnv <- qualifyLocal cnv - lvictim <- qualifyLocal victim - removeMemberQualified zusr con (qUntagged lcnv) (qUntagged lvictim) + Sem r RemoveFromConversationResponse +removeMemberUnqualified lusr con cnv victim = do + let lvictim = qualifyAs lusr victim + lcnv = qualifyAs lusr cnv + removeMemberQualified lusr con (qUntagged lcnv) (qUntagged lvictim) removeMemberQualified :: Members @@ -1039,41 +1068,39 @@ removeMemberQualified :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Qualified UserId -> - Galley r RemoveFromConversationResponse -removeMemberQualified zusr con qcnv victim = do - lusr <- qualifyLocal zusr + Sem r RemoveFromConversationResponse +removeMemberQualified lusr con qcnv victim = do foldQualified lusr removeMemberFromLocalConv removeMemberFromRemoteConv qcnv lusr (Just con) victim removeMemberFromRemoteConv :: - Members '[FederatorAccess] r => + Members '[FederatorAccess, Input UTCTime] r => Remote ConvId -> Local UserId -> Maybe ConnId -> Qualified UserId -> - Galley r RemoveFromConversationResponse + Sem r RemoveFromConversationResponse removeMemberFromRemoteConv cnv lusr _ victim - | qUntagged lusr == victim = - do - let lc = FederatedGalley.LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) - let rpc = - FederatedGalley.leaveConversation - FederatedGalley.clientRoutes - (qDomain victim) - lc - t <- liftIO getCurrentTime - let successEvent = - Event MemberLeave (qUntagged cnv) (qUntagged lusr) t $ - EdMembersLeave (QualifiedUserIdList [victim]) - liftSem $ - mapRight (const successEvent) . FederatedGalley.leaveResponse - <$> E.runFederated cnv rpc + | qUntagged lusr == victim = do + let lc = FederatedGalley.LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) + let rpc = + FederatedGalley.leaveConversation + FederatedGalley.clientRoutes + (qDomain victim) + lc + t <- input + let successEvent = + Event MemberLeave (qUntagged cnv) (qUntagged lusr) t $ + EdMembersLeave (QualifiedUserIdList [victim]) + mapRight (const successEvent) . FederatedGalley.leaveResponse + <$> E.runFederated cnv rpc | otherwise = pure . Left $ RemoveFromConversationErrorRemovalNotAllowed -- | Remove a member from a local conversation. @@ -1086,6 +1113,7 @@ removeMemberFromLocalConv :: ExternalAccess, FederatorAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => @@ -1093,11 +1121,11 @@ removeMemberFromLocalConv :: Local UserId -> Maybe ConnId -> Qualified UserId -> - Galley r RemoveFromConversationResponse + Sem r RemoveFromConversationResponse removeMemberFromLocalConv lcnv lusr con victim = -- FUTUREWORK: actually return errors as part of the response instead of throwing - fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) - . runMaybeT + runError + . mapError @NoChanges (const (RemoveFromConversationErrorUnchanged)) . updateLocalConversation lcnv (qUntagged lusr) con . ConversationLeave . pure @@ -1118,9 +1146,9 @@ handleOtrResult :: ] r => OtrResult -> - Galley r Response + Sem r Response handleOtrResult = - liftSem . \case + \case OtrSent m -> pure $ json m & setStatus status201 OtrMissingRecipients m -> pure $ json m & setStatus status412 OtrUnknownClient _ -> throw UnknownClient @@ -1128,48 +1156,53 @@ handleOtrResult = postBotMessageH :: Members - '[ BotAccess, - BrigAccess, + '[ BrigAccess, ClientStore, ConversationStore, Error ClientError, Error ConversationError, Error LegalHoldError, - Error InvalidInput, - FederatorAccess, GundeckAccess, ExternalAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + TinyLog, + WaiRoutes ] r => BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> - Galley r Response -postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do + Sem r Response +postBotMessageH (zbot ::: cnv ::: val ::: req ::: _) = do + lbot <- qualifyLocal zbot + lcnv <- qualifyLocal cnv message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message - handleOtrResult =<< postBotMessage zbot zcnv val' message + handleOtrResult =<< postBotMessage lbot lcnv val' message postBotMessage :: Members - '[ BotAccess, - BrigAccess, + '[ BrigAccess, ClientStore, ConversationStore, Error LegalHoldError, ExternalAccess, - FederatorAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + TinyLog ] r => - BotId -> - ConvId -> + Local BotId -> + Local ConvId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> - Galley r OtrResult -postBotMessage zbot = postNewOtrMessage Bot (botUserId zbot) Nothing + Sem r OtrResult +postBotMessage zbot = postNewOtrMessage Bot (fmap botUserId zbot) Nothing postProteusMessage :: Members @@ -1180,20 +1213,22 @@ postProteusMessage :: FederatorAccess, GundeckAccess, ExternalAccess, + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + TinyLog ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> RawProto Public.QualifiedNewOtrMessage -> - Galley r (Public.PostOtrResponse Public.MessageSendingStatus) -postProteusMessage zusr zcon conv msg = do - sender <- qualifyLocal zusr + Sem r (Public.PostOtrResponse Public.MessageSendingStatus) +postProteusMessage sender zcon conv msg = runLocalInput sender $ do foldQualified sender - (\c -> postQualifiedOtrMessage User (qUntagged sender) (Just zcon) (tUnqualified c) (rpValue msg)) + (\c -> postQualifiedOtrMessage User (qUntagged sender) (Just zcon) c (rpValue msg)) (\c -> postRemoteOtrMessage (qUntagged sender) c (rpRaw msg)) conv @@ -1207,20 +1242,23 @@ postOtrMessageUnqualified :: GundeckAccess, ExternalAccess, MemberStore, - TeamStore + Input Opts, + Input UTCTime, + TeamStore, + TinyLog ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Maybe Public.IgnoreMissing -> Maybe Public.ReportMissing -> Public.NewOtrMessage -> - Galley r (Public.PostOtrResponse Public.ClientMismatch) -postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do - localDomain <- viewFederationDomain - let sender = Qualified zusr localDomain - qualifiedRecipients = + Sem r (Public.PostOtrResponse Public.ClientMismatch) +postOtrMessageUnqualified sender zcon cnv ignoreMissing reportMissing message = do + let lcnv = qualifyAs sender cnv + localDomain = tDomain sender + let qualifiedRecipients = Public.QualifiedOtrRecipients . QualifiedUserClientMap . Map.singleton localDomain @@ -1240,8 +1278,9 @@ postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do Public.qualifiedNewOtrData = maybe mempty fromBase64TextLenient (newOtrData message), Public.qualifiedNewOtrClientMismatchStrategy = clientMismatchStrategy } - unqualify localDomain - <$> postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage + runLocalInput sender $ + unqualify localDomain + <$> postQualifiedOtrMessage User (qUntagged sender) (Just zcon) lcnv qualifiedMessage postProtoOtrBroadcastH :: Members @@ -1251,19 +1290,23 @@ postProtoOtrBroadcastH :: Error ClientError, Error ConversationError, Error LegalHoldError, - Error InvalidInput, - Error NotATeamMember, Error TeamError, GundeckAccess, - TeamStore + Input (Local ()), + Input Opts, + Input UTCTime, + TeamStore, + TinyLog, + WaiRoutes ] r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> - Galley r Response + Sem r Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do + lusr <- qualifyLocal zusr message <- Public.protoToNewOtrMessage <$> fromProtoBody req let val' = allowOtrFilterMissingInBody val message - handleOtrResult =<< postOtrBroadcast zusr zcon val' message + handleOtrResult =<< postOtrBroadcast lusr zcon val' message postOtrBroadcastH :: Members @@ -1273,19 +1316,23 @@ postOtrBroadcastH :: Error ClientError, Error ConversationError, Error LegalHoldError, - Error InvalidInput, - Error NotATeamMember, Error TeamError, GundeckAccess, - TeamStore + Input (Local ()), + Input Opts, + Input UTCTime, + TeamStore, + TinyLog, + WaiRoutes ] r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> - Galley r Response + Sem r Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do + lusr <- qualifyLocal zusr message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message - handleOtrResult =<< postOtrBroadcast zusr zcon val' message + handleOtrResult =<< postOtrBroadcast lusr zcon val' message postOtrBroadcast :: Members @@ -1293,18 +1340,20 @@ postOtrBroadcast :: ClientStore, Error ActionError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, GundeckAccess, - TeamStore + Input Opts, + Input UTCTime, + TeamStore, + TinyLog ] r => - UserId -> + Local UserId -> ConnId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> - Galley r OtrResult -postOtrBroadcast zusr zcon = postNewOtrBroadcast zusr (Just zcon) + Sem r OtrResult +postOtrBroadcast lusr zcon = postNewOtrBroadcast lusr (Just zcon) -- internal OTR helpers @@ -1323,58 +1372,57 @@ postNewOtrBroadcast :: ClientStore, Error ActionError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, + Input Opts, + Input UTCTime, GundeckAccess, - TeamStore + TeamStore, + TinyLog ] r => - UserId -> + Local UserId -> Maybe ConnId -> OtrFilterMissing -> NewOtrMessage -> - Galley r OtrResult -postNewOtrBroadcast usr con val msg = do - localDomain <- viewFederationDomain - let qusr = Qualified usr localDomain - sender = newOtrSender msg + Sem r OtrResult +postNewOtrBroadcast lusr con val msg = do + let sender = newOtrSender msg recvrs = newOtrRecipients msg - now <- liftIO getCurrentTime - withValidOtrBroadcastRecipients usr sender recvrs val now $ \rs -> do - let (_, toUsers) = foldr (newMessage qusr con Nothing msg now) ([], []) rs - liftSem $ E.push (catMaybes toUsers) + now <- input + withValidOtrBroadcastRecipients (tUnqualified lusr) sender recvrs val now $ \rs -> do + let (_, toUsers) = foldr (newMessage (qUntagged lusr) con Nothing msg now) ([], []) rs + E.push (catMaybes toUsers) postNewOtrMessage :: Members - '[ BotAccess, - BrigAccess, + '[ BrigAccess, ClientStore, ConversationStore, Error LegalHoldError, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + TinyLog ] r => UserType -> - UserId -> + Local UserId -> Maybe ConnId -> - ConvId -> + Local ConvId -> OtrFilterMissing -> NewOtrMessage -> - Galley r OtrResult -postNewOtrMessage utype usr con cnv val msg = do - localDomain <- viewFederationDomain - let qusr = Qualified usr localDomain - qcnv = Qualified cnv localDomain - sender = newOtrSender msg + Sem r OtrResult +postNewOtrMessage utype lusr con lcnv val msg = do + let sender = newOtrSender msg recvrs = newOtrRecipients msg - now <- liftIO getCurrentTime - withValidOtrRecipients utype usr sender cnv recvrs val now $ \rs -> liftSem $ do - let (toBots, toUsers) = foldr (newMessage qusr con (Just qcnv) msg now) ([], []) rs + now <- input + withValidOtrRecipients utype (tUnqualified lusr) sender (tUnqualified lcnv) recvrs val now $ \rs -> do + let (toBots, toUsers) = foldr (newMessage (qUntagged lusr) con (Just (qUntagged lcnv)) msg now) ([], []) rs E.push (catMaybes toUsers) - E.deliverAndDeleteAsync cnv toBots + E.deliverAndDeleteAsync (tUnqualified lcnv) toBots newMessage :: Qualified UserId -> @@ -1420,20 +1468,20 @@ updateConversationName :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> Qualified ConvId -> Public.ConversationRename -> - Galley r (Maybe Public.Event) -updateConversationName zusr zcon qcnv convRename = do - lusr <- qualifyLocal zusr + Sem r (Maybe Public.Event) +updateConversationName lusr zcon qcnv convRename = do foldQualified lusr (updateLocalConversationName lusr zcon) - (\_ _ -> liftSem (throw FederationNotImplemented)) + (\_ _ -> throw FederationNotImplemented) qcnv convRename @@ -1445,17 +1493,17 @@ updateUnqualifiedConversationName :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => - UserId -> + Local UserId -> ConnId -> ConvId -> Public.ConversationRename -> - Galley r (Maybe Public.Event) -updateUnqualifiedConversationName zusr zcon cnv rename = do - lusr <- qualifyLocal zusr - lcnv <- qualifyLocal cnv + Sem r (Maybe Public.Event) +updateUnqualifiedConversationName lusr zcon cnv rename = do + let lcnv = qualifyAs lusr cnv updateLocalConversationName lusr zcon lcnv rename updateLocalConversationName :: @@ -1466,19 +1514,20 @@ updateLocalConversationName :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationRename -> - Galley r (Maybe Public.Event) + Sem r (Maybe Public.Event) updateLocalConversationName lusr zcon lcnv convRename = do - alive <- liftSem $ E.isConversationAlive (tUnqualified lcnv) + alive <- E.isConversationAlive (tUnqualified lcnv) if alive then updateLiveLocalConversationName lusr zcon lcnv convRename - else liftSem $ Nothing <$ E.deleteConversation (tUnqualified lcnv) + else Nothing <$ E.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: Members @@ -1488,50 +1537,52 @@ updateLiveLocalConversationName :: Error InvalidInput, ExternalAccess, FederatorAccess, - GundeckAccess + GundeckAccess, + Input UTCTime ] r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationRename -> - Galley r (Maybe Public.Event) + Sem r (Maybe Public.Event) updateLiveLocalConversationName lusr con lcnv rename = - runMaybeT $ + fmap hush . runError @NoChanges $ updateLocalConversation lcnv (qUntagged lusr) (Just con) rename isTypingH :: Members '[ Error ConversationError, - Error InvalidInput, GundeckAccess, - MemberStore + Input (Local ()), + Input UTCTime, + MemberStore, + WaiRoutes ] r => UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> - Galley r Response + Sem r Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do + lusr <- qualifyLocal zusr + lcnv <- qualifyLocal cnv typingData <- fromJsonBody req - isTyping zusr zcon cnv typingData + isTyping lusr zcon lcnv typingData pure empty isTyping :: - Members '[Error ConversationError, GundeckAccess, MemberStore] r => - UserId -> + Members '[Error ConversationError, GundeckAccess, Input UTCTime, MemberStore] r => + Local UserId -> ConnId -> - ConvId -> + Local ConvId -> Public.TypingData -> - Galley r () -isTyping zusr zcon cnv typingData = do - localDomain <- viewFederationDomain - let qcnv = Qualified cnv localDomain - qusr = Qualified zusr localDomain - mm <- liftSem $ E.getLocalMembers cnv - 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 -> - liftSem . E.push1 $ + Sem r () +isTyping lusr zcon lcnv typingData = do + mm <- E.getLocalMembers (tUnqualified lcnv) + unless (tUnqualified lusr `isMember` mm) . throw $ ConvNotFound + now <- input + let e = Event Typing (qUntagged lcnv) (qUntagged lusr) now (EdTyping typingData) + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> mm)) $ \p -> + E.push1 $ p & pushConn ?~ zcon & pushRoute .~ RouteDirect @@ -1539,22 +1590,22 @@ isTyping zusr zcon cnv typingData = do addServiceH :: Members - '[ Error InvalidInput, - ServiceStore + '[ ServiceStore, + WaiRoutes ] r => JsonRequest Service -> - Galley r Response + Sem r Response addServiceH req = do - liftSem . E.createService =<< fromJsonBody req + E.createService =<< fromJsonBody req return empty rmServiceH :: - Members '[Error InvalidInput, ServiceStore] r => + Members '[ServiceStore, WaiRoutes] r => JsonRequest ServiceRef -> - Galley r Response + Sem r Response rmServiceH req = do - liftSem . E.deleteService =<< fromJsonBody req + E.deleteService =<< fromJsonBody req return empty addBotH :: @@ -1566,15 +1617,20 @@ addBotH :: Error ConversationError, ExternalAccess, GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, MemberStore, - TeamStore + TeamStore, + WaiRoutes ] r => UserId ::: ConnId ::: JsonRequest AddBot -> - Galley r Response + Sem r Response addBotH (zusr ::: zcon ::: req) = do bot <- fromJsonBody req - json <$> addBot zusr zcon bot + lusr <- qualifyLocal zusr + json <$> addBot lusr zcon bot addBot :: forall r. @@ -1586,24 +1642,25 @@ addBot :: Error InvalidInput, ExternalAccess, GundeckAccess, + Input Opts, + Input UTCTime, MemberStore, TeamStore ] r => - UserId -> + Local UserId -> ConnId -> AddBot -> - Galley r Event -addBot zusr zcon b = do - lusr <- qualifyLocal zusr + Sem r Event +addBot lusr zcon b = do c <- - liftSem $ E.getConversation (b ^. addBotConv) >>= note ConvNotFound + 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 - t <- liftIO getCurrentTime - liftSem $ E.createClient (botUserId (b ^. addBotId)) (b ^. addBotClient) - bm <- liftSem $ E.createBotMember (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) + (bots, users) <- regularConvChecks c + t <- input + E.createClient (botUserId (b ^. addBotId)) (b ^. addBotClient) + bm <- E.createBotMember (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) let e = Event MemberJoin @@ -1618,44 +1675,46 @@ addBot zusr zcon b = do ] ) ) - for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> - liftSem . E.push1 $ p & pushConn ?~ zcon - liftSem $ E.deliverAsync ((bm : bots) `zip` repeat e) + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> users)) $ \p -> + E.push1 $ p & pushConn ?~ zcon + E.deliverAsync ((bm : bots) `zip` repeat e) pure e where - regularConvChecks lusr c = do + regularConvChecks c = do let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) - liftSem . unless (zusr `isMember` users) . throw $ ConvNotFound - liftSem $ ensureGroupConversation c - self <- getSelfMemberFromLocals zusr users + unless (tUnqualified lusr `isMember` users) . throw $ ConvNotFound + ensureGroupConversation c + self <- getSelfMemberFromLocals (tUnqualified lusr) 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] return (bots, users) - teamConvChecks :: ConvId -> TeamId -> Galley r () + teamConvChecks :: ConvId -> TeamId -> Sem r () teamConvChecks cid tid = do - tcv <- liftSem $ E.getTeamConversation tid cid - liftSem $ - when (maybe True (view managedConversation) tcv) $ - throw NoAddToManaged + tcv <- E.getTeamConversation tid cid + when (maybe True (view managedConversation) tcv) $ + throw NoAddToManaged rmBotH :: Members '[ ClientStore, ConversationStore, Error ConversationError, - Error InvalidInput, ExternalAccess, GundeckAccess, - MemberStore + Input (Local ()), + Input UTCTime, + MemberStore, + WaiRoutes ] r => UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> - Galley r Response + Sem r Response rmBotH (zusr ::: zcon ::: req) = do + lusr <- qualifyLocal zusr bot <- fromJsonBody req - handleUpdateResult <$> rmBot zusr zcon bot + handleUpdateResult <$> rmBot lusr zcon bot rmBot :: Members @@ -1664,30 +1723,29 @@ rmBot :: Error ConversationError, ExternalAccess, GundeckAccess, + Input UTCTime, MemberStore ] r => - UserId -> + Local UserId -> Maybe ConnId -> RemoveBot -> - Galley r (UpdateResult Event) -rmBot zusr zcon b = do + Sem r (UpdateResult Event) +rmBot lusr zcon b = do c <- - 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) $ + E.getConversation (b ^. rmBotConv) >>= note ConvNotFound + let lcnv = qualifyAs lusr (Data.convId c) + unless (tUnqualified lusr `isMember` Data.convLocalMembers c) $ throw ConvNotFound let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) if not (any ((== b ^. rmBotId) . botMemId) bots) then pure Unchanged else do - t <- liftIO getCurrentTime - liftSem $ do - let evd = EdMembersLeave (QualifiedUserIdList [Qualified (botUserId (b ^. rmBotId)) localDomain]) - let e = Event MemberLeave qcnv qusr t evd - for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> + t <- input + do + let evd = EdMembersLeave (QualifiedUserIdList [qUntagged (qualifyAs lusr (botUserId (b ^. rmBotId)))]) + let e = Event MemberLeave (qUntagged lcnv) (qUntagged lusr) t evd + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> users)) $ \p -> E.push1 $ p & pushConn .~ zcon E.deleteMembers (Data.convId c) (UserList [botUserId (b ^. rmBotId)] []) E.deleteClients (botUserId (b ^. rmBotId)) @@ -1697,10 +1755,9 @@ rmBot zusr zcon b = do ------------------------------------------------------------------------------- -- Helpers -ensureConvMember :: Member (Error ConversationError) r => [LocalMember] -> UserId -> Galley r () +ensureConvMember :: Member (Error ConversationError) r => [LocalMember] -> UserId -> Sem r () ensureConvMember users usr = - liftSem $ - unless (usr `isMember` users) $ throw ConvNotFound + unless (usr `isMember` users) $ throw ConvNotFound ------------------------------------------------------------------------------- -- OtrRecipients Validation @@ -1724,9 +1781,10 @@ withValidOtrBroadcastRecipients :: ClientStore, Error ActionError, Error LegalHoldError, - Error NotATeamMember, Error TeamError, - TeamStore + Input Opts, + TeamStore, + TinyLog ] r => UserId -> @@ -1734,12 +1792,12 @@ withValidOtrBroadcastRecipients :: OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(LocalMember, ClientId, Text)] -> Galley r ()) -> - Galley r OtrResult + ([(LocalMember, ClientId, Text)] -> Sem r ()) -> + Sem r OtrResult withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ \tid -> do - limit <- fromIntegral . fromRange <$> fanoutLimit + limit <- fromIntegral . fromRange <$> E.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) $ + 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 @@ -1748,14 +1806,13 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ fmap (view userId) <$> case val of OtrReportMissing us -> maybeFetchLimitedTeamMemberList limit tid us _ -> maybeFetchAllMembersInTeam tid - contacts <- liftSem $ E.getContactList usr + contacts <- E.getContactList usr let users = Set.toList $ Set.union (Set.fromList tMembers) (Set.fromList contacts) - isInternal <- view $ options . optSettings . setIntraListing + isInternal <- E.useIntraClientListing clts <- - liftSem $ - if isInternal - then Clients.fromUserClients <$> E.lookupClients users - else E.getClients users + if isInternal + then Clients.fromUserClients <$> E.lookupClients users + else E.getClients users let membs = newMember <$> users handleOtrResponse User usr clt rcps membs clts val now go where @@ -1764,13 +1821,13 @@ 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) - liftSem . unless (length localUserIdsToLookup <= limit) $ + unless (length localUserIdsToLookup <= limit) $ throw BroadcastLimitExceeded - liftSem $ E.selectTeamMembers tid localUserIdsToLookup - maybeFetchAllMembersInTeam :: TeamId -> Galley r [TeamMember] + E.selectTeamMembers tid localUserIdsToLookup + maybeFetchAllMembersInTeam :: TeamId -> Sem r [TeamMember] maybeFetchAllMembersInTeam tid = do mems <- getTeamMembersForFanout tid - liftSem . when (mems ^. teamMemberListType == ListTruncated) $ + when (mems ^. teamMemberListType == ListTruncated) $ throw BroadcastLimitExceeded pure (mems ^. teamMembers) @@ -1780,8 +1837,10 @@ withValidOtrRecipients :: ClientStore, ConversationStore, Error LegalHoldError, + Input Opts, MemberStore, - TeamStore + TeamStore, + TinyLog ] r => UserType -> @@ -1791,27 +1850,26 @@ withValidOtrRecipients :: OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(LocalMember, ClientId, Text)] -> Galley r ()) -> - Galley r OtrResult + ([(LocalMember, ClientId, Text)] -> Sem r ()) -> + Sem r OtrResult withValidOtrRecipients utype usr clt cnv rcps val now go = do - alive <- liftSem $ E.isConversationAlive cnv + alive <- E.isConversationAlive cnv if not alive then do - liftSem $ E.deleteConversation cnv + E.deleteConversation cnv pure $ OtrConversationNotFound mkErrorDescription else do - localMembers <- liftSem $ E.getLocalMembers cnv + localMembers <- E.getLocalMembers cnv let localMemberIds = lmId <$> localMembers - isInternal <- view $ options . optSettings . setIntraListing + isInternal <- E.useIntraClientListing clts <- - liftSem $ - if isInternal - then Clients.fromUserClients <$> E.lookupClients localMemberIds - else E.getClients localMemberIds + if isInternal + then Clients.fromUserClients <$> E.lookupClients localMemberIds + else E.getClients localMemberIds handleOtrResponse utype usr clt rcps localMembers clts val now go handleOtrResponse :: - Members '[BrigAccess, Error LegalHoldError, TeamStore] r => + Members '[BrigAccess, Error LegalHoldError, Input Opts, TeamStore, TinyLog] r => -- | Type of proposed sender (user / bot) UserType -> -- | Proposed sender (user) @@ -1829,13 +1887,12 @@ handleOtrResponse :: -- | The current timestamp. UTCTime -> -- | Callback if OtrRecipients are valid - ([(LocalMember, ClientId, Text)] -> Galley r ()) -> - Galley r OtrResult + ([(LocalMember, ClientId, Text)] -> Sem r ()) -> + Sem r OtrResult handleOtrResponse utype usr clt rcps membs clts val now go = case checkOtrRecipients usr clt rcps membs clts val now of ValidOtrRecipients m r -> go r >> pure (OtrSent m) - MissingOtrRecipients m -> do + MissingOtrRecipients m -> mapError @LegalholdConflicts (const MissingLegalholdConsent) $ do guardLegalholdPolicyConflicts (userToProtectee utype usr) (missingClients m) - >>= either (const (liftSem . throw $ MissingLegalholdConsent)) pure pure (OtrMissingRecipients m) InvalidOtrSenderUser -> pure $ OtrConversationNotFound mkErrorDescription InvalidOtrSenderClient -> pure $ OtrUnknownClient mkErrorDescription @@ -1930,11 +1987,11 @@ withBindingTeam :: ] r => UserId -> - (TeamId -> Galley r b) -> - Galley r b + (TeamId -> Sem r b) -> + Sem r b withBindingTeam zusr callback = do - tid <- liftSem $ E.getOneUserTeam zusr >>= note TeamNotFound - binding <- liftSem $ E.getTeamBinding tid >>= note TeamNotFound + tid <- E.getOneUserTeam zusr >>= note TeamNotFound + binding <- E.getTeamBinding tid >>= note TeamNotFound case binding of Binding -> callback tid - NonBinding -> liftSem $ throw NotABindingTeamMember + NonBinding -> throw NotABindingTeamMember diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index f76e4ff748b..4971c19dc87 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -36,7 +36,6 @@ import Data.Qualified import qualified Data.Set as Set import Data.Time import Galley.API.Error -import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Data.Services (BotMember, newBotMember) import qualified Galley.Data.Types as DataTypes @@ -64,6 +63,7 @@ import Network.Wai.Predicate hiding (Error) import qualified Network.Wai.Utilities as Wai import Polysemy import Polysemy.Error +import Polysemy.Input import qualified Wire.API.Conversation as Public import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley as FederatedGalley @@ -75,8 +75,8 @@ ensureAccessRole :: Members '[BrigAccess, Error NotATeamMember, Error ConversationError] r => AccessRole -> [(UserId, Maybe TeamMember)] -> - Galley r () -ensureAccessRole role users = liftSem $ case role of + Sem r () +ensureAccessRole role users = case role of PrivateAccessRole -> throw ConvAccessDenied TeamAccessRole -> when (any (isNothing . snd) users) $ @@ -96,12 +96,12 @@ ensureConnectedOrSameTeam :: Members '[BrigAccess, TeamStore, Error ActionError] r => Local UserId -> [UserId] -> - Galley r () + Sem r () ensureConnectedOrSameTeam _ [] = pure () ensureConnectedOrSameTeam (tUnqualified -> u) uids = do - uTeams <- liftSem $ getUserTeams u + uTeams <- getUserTeams u -- We collect all the relevant uids from same teams as the origin user - sameTeamUids <- liftSem . forM uTeams $ \team -> + sameTeamUids <- 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) @@ -115,7 +115,7 @@ ensureConnected :: Members '[BrigAccess, Error ActionError] r => Local UserId -> UserList UserId -> - Galley r () + Sem r () ensureConnected self others = do ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToRemotes self (ulRemotes others) @@ -124,9 +124,9 @@ ensureConnectedToLocals :: Members '[BrigAccess, Error ActionError] r => UserId -> [UserId] -> - Galley r () + Sem r () ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = liftSem $ do +ensureConnectedToLocals u uids = do (connsFrom, connsTo) <- getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) unless (length connsFrom == length uids && length connsTo == length uids) $ @@ -136,9 +136,9 @@ ensureConnectedToRemotes :: Members '[BrigAccess, Error ActionError] r => Local UserId -> [Remote UserId] -> - Galley r () + Sem r () ensureConnectedToRemotes _ [] = pure () -ensureConnectedToRemotes u remotes = liftSem $ do +ensureConnectedToRemotes u remotes = do acceptedConns <- getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) when (length acceptedConns /= length remotes) $ throw NotConnected @@ -151,8 +151,8 @@ ensureReAuthorised :: r => UserId -> Maybe PlainTextPassword -> - Galley r () -ensureReAuthorised u secret = liftSem $ do + Sem r () +ensureReAuthorised u secret = do reAuthed <- reauthUser u (ReAuthUser secret) unless reAuthed $ throw ReAuthFailed @@ -164,8 +164,8 @@ ensureActionAllowed :: (IsConvMember mem, Members '[Error ActionError, Error InvalidInput] r) => Action -> mem -> - Galley r () -ensureActionAllowed action self = liftSem $ case isActionAllowed action (convMemberRole self) of + Sem r () +ensureActionAllowed action self = case isActionAllowed action (convMemberRole self) of Just True -> pure () Just False -> throw (ActionDenied action) -- Actually, this will "never" happen due to the @@ -185,8 +185,8 @@ ensureConvRoleNotElevated :: (IsConvMember mem, Members '[Error InvalidInput, Error ActionError] r) => mem -> RoleName -> - Galley r () -ensureConvRoleNotElevated origMember targetRole = liftSem $ do + Sem r () +ensureConvRoleNotElevated origMember targetRole = do case (roleNameToActions targetRole, roleNameToActions (convMemberRole origMember)) of (Just targetActions, Just memberActions) -> unless (Set.isSubsetOf targetActions memberActions) $ @@ -201,28 +201,27 @@ permissionCheck :: (IsPerm perm, Show perm, Members '[Error ActionError, Error NotATeamMember] r) => perm -> Maybe TeamMember -> - Galley r TeamMember + Sem r TeamMember permissionCheck p = - liftSem . \case + \case Just m -> do if m `hasPermission` p then pure m else throw (OperationDenied (show p)) Nothing -> throwED @NotATeamMember -assertTeamExists :: Members '[Error TeamError, TeamStore] r => TeamId -> Galley r () -assertTeamExists tid = liftSem $ do +assertTeamExists :: Members '[Error TeamError, TeamStore] r => TeamId -> Sem r () +assertTeamExists tid = do teamExists <- isJust <$> getTeam tid if teamExists then pure () else throw TeamNotFound -assertOnTeam :: Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r () +assertOnTeam :: Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Sem r () assertOnTeam uid tid = - liftSem $ - getTeamMember tid uid >>= \case - Nothing -> throwED @NotATeamMember - Just _ -> return () + getTeamMember tid uid >>= \case + Nothing -> throwED @NotATeamMember + Just _ -> return () -- | If the conversation is in a team, throw iff zusr is a team member and does not have named -- permission. If the conversation is not in a team, do nothing (no error). @@ -238,13 +237,13 @@ permissionCheckTeamConv :: UserId -> ConvId -> Perm -> - Galley r () + Sem r () permissionCheckTeamConv zusr cnv perm = - liftSem (getConversation cnv) >>= \case + getConversation cnv >>= \case Just cnv' -> case Data.convTeam cnv' of - Just tid -> void $ permissionCheck perm =<< liftSem (getTeamMember tid zusr) + Just tid -> void $ permissionCheck perm =<< getTeamMember tid zusr Nothing -> pure () - Nothing -> liftSem $ throw ConvNotFound + Nothing -> throw ConvNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: @@ -253,39 +252,39 @@ acceptOne2One :: Error ActionError, Error ConversationError, Error InternalError, - MemberStore, - GundeckAccess + GundeckAccess, + Input UTCTime, + MemberStore ] r => - UserId -> + Local UserId -> Data.Conversation -> Maybe ConnId -> - Galley r Data.Conversation -acceptOne2One usr conv conn = do - lusr <- qualifyLocal usr - lcid <- qualifyLocal cid + Sem r Data.Conversation +acceptOne2One lusr conv conn = do + let lcid = qualifyAs lusr cid case Data.convType conv of One2OneConv -> - if usr `isMember` mems + if tUnqualified lusr `isMember` mems then return conv else do - mm <- liftSem $ createMember lcid lusr + mm <- createMember lcid lusr return $ conv {Data.convLocalMembers = mems <> toList mm} ConnectConv -> case mems of - [_, _] | usr `isMember` mems -> liftSem promote - [_, _] -> liftSem $ throw ConvNotFound + [_, _] | tUnqualified lusr `isMember` mems -> promote + [_, _] -> throw ConvNotFound _ -> do when (length mems > 2) $ - liftSem . throw . BadConvState $ cid - now <- liftIO getCurrentTime - mm <- liftSem $ createMember lcid lusr + throw . BadConvState $ cid + now <- input + mm <- createMember lcid lusr let e = memberJoinEvent lusr (qUntagged lcid) now mm [] - conv' <- if isJust (find ((usr /=) . lmId) mems) then liftSem promote else pure conv + conv' <- if isJust (find ((tUnqualified lusr /=) . lmId) mems) then promote else pure conv let mems' = mems <> toList mm - for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> mems')) $ \p -> - liftSem $ push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect + for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> mems')) $ \p -> + push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect return $ conv' {Data.convLocalMembers = mems'} - x -> liftSem . throw . InvalidOp $ x + x -> throw . InvalidOp $ x where cid = Data.convId conv mems = Data.convLocalMembers conv @@ -455,9 +454,9 @@ getSelfMemberFromLocals :: (Foldable t, Member (Error ConversationError) r) => UserId -> t LocalMember -> - Galley r LocalMember + Sem r LocalMember getSelfMemberFromLocals usr lmems = - liftSem $ getMember lmId ConvNotFound usr lmems + getMember lmId ConvNotFound usr lmems -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). @@ -476,9 +475,9 @@ getSelfMemberFromRemotes :: (Foldable t, Member (Error ConversationError) r) => Remote UserId -> t RemoteMember -> - Galley r RemoteMember + Sem r RemoteMember getSelfMemberFromRemotes usr rmems = - liftSem $ getMember rmId ConvNotFound usr rmems + getMember rmId ConvNotFound usr rmems getQualifiedMember :: Member (Error e) r => @@ -510,29 +509,28 @@ getMember p ex u = note ex . find ((u ==) . p) getConversationAndCheckMembership :: Members '[ConversationStore, Error ConversationError] r => UserId -> - ConvId -> - Galley r Data.Conversation -getConversationAndCheckMembership uid cnv = do + Local ConvId -> + Sem r Data.Conversation +getConversationAndCheckMembership uid lcnv = do (conv, _) <- getConversationAndMemberWithError ConvAccessDenied uid - cnv + lcnv pure conv getConversationAndMemberWithError :: (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 >>= note ConvNotFound - liftSem . when (DataTypes.isConvDeleted c) $ do - deleteConversation convId + Local ConvId -> + Sem r (Data.Conversation, mem) +getConversationAndMemberWithError ex usr lcnv = do + c <- getConversation (tUnqualified lcnv) >>= note ConvNotFound + when (DataTypes.isConvDeleted c) $ do + deleteConversation (tUnqualified lcnv) throw ConvNotFound - loc <- qualifyLocal () - member <- liftSem . note ex $ getConvMember loc c usr + member <- note ex $ getConvMember lcnv c usr pure (c, member) -- | Deletion requires a permission check, but also a 'Role' comparison: @@ -557,35 +555,31 @@ pushConversationEvent :: (Members '[GundeckAccess, ExternalAccess] r, Foldable f) => Maybe ConnId -> Event -> - f UserId -> + Local (f UserId) -> f BotMember -> - Galley r () -pushConversationEvent conn e users bots = do - localDomain <- viewFederationDomain - for_ (newConversationEventPush localDomain e (toList users)) $ \p -> - liftSem $ push1 $ p & set pushConn conn - liftSem $ deliverAsync (toList bots `zip` repeat e) + Sem r () +pushConversationEvent conn e lusers bots = do + for_ (newConversationEventPush e (fmap toList lusers)) $ \p -> + push1 $ p & set pushConn conn + deliverAsync (toList bots `zip` repeat e) verifyReusableCode :: Members '[CodeStore, Error CodeError] r => ConversationCode -> - Galley r DataTypes.Code + Sem r DataTypes.Code verifyReusableCode convCode = do c <- - liftSem $ - getCode (conversationKey convCode) DataTypes.ReusableCode - >>= note CodeNotFound + getCode (conversationKey convCode) DataTypes.ReusableCode + >>= note CodeNotFound unless (DataTypes.codeValue c == conversationCode convCode) $ - liftSem $ throw CodeNotFound + throw CodeNotFound return c ensureConversationAccess :: Members '[ BrigAccess, ConversationStore, - Error ActionError, Error ConversationError, - Error FederationError, Error NotATeamMember, TeamStore ] @@ -593,15 +587,13 @@ ensureConversationAccess :: UserId -> ConvId -> Access -> - Galley r Data.Conversation + Sem r Data.Conversation ensureConversationAccess zusr cnv access = do conv <- - liftSem $ - getConversation cnv >>= note ConvNotFound - liftSem $ ensureAccess conv access + getConversation cnv >>= note ConvNotFound + ensureAccess conv access zusrMembership <- - liftSem $ - maybe (pure Nothing) (`getTeamMember` zusr) (Data.convTeam conv) + maybe (pure Nothing) (`getTeamMember` zusr) (Data.convTeam conv) ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] pure conv @@ -620,11 +612,14 @@ ensureLocal loc = foldQualified loc pure (\_ -> throw FederationNotImplemented) -------------------------------------------------------------------------------- -- Federation -viewFederationDomain :: MonadReader Env m => m Domain -viewFederationDomain = view (options . optSettings . setFederationDomain) +qualifyLocal :: Member (Input (Local ())) r => a -> Sem r (Local a) +qualifyLocal a = toLocalUnsafe <$> fmap getDomain input <*> pure a + where + getDomain :: Local () -> Domain + getDomain = tDomain -qualifyLocal :: MonadReader Env m => a -> m (Local a) -qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a +runLocalInput :: Local x -> Sem (Input (Local ()) ': r) a -> Sem r a +runLocalInput = runInputConst . void -- | Convert an internal conversation representation 'Data.Conversation' to -- 'NewRemoteConversation' to be sent over the wire to a remote backend that will @@ -734,8 +729,8 @@ registerRemoteConversationMemberships :: -- | The domain of the user that created the conversation Domain -> Data.Conversation -> - Galley r () -registerRemoteConversationMemberships now localDomain c = liftSem $ do + Sem r () +registerRemoteConversationMemberships now localDomain c = do let allRemoteMembers = nubOrd (map rmId (Data.convRemoteMembers c)) rc = toNewRemoteConversation now localDomain c runFederatedConcurrently_ allRemoteMembers $ \_ -> @@ -765,7 +760,7 @@ checkConsent :: Member TeamStore r => Map UserId TeamId -> UserId -> - Galley r ConsentGiven + Sem r ConsentGiven checkConsent teamsOfUsers other = do consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other @@ -775,66 +770,75 @@ getLHStatus :: Member TeamStore r => Maybe TeamId -> UserId -> - Galley r UserLegalHoldStatus + Sem r UserLegalHoldStatus getLHStatus teamOfUser other = do case teamOfUser of Nothing -> pure defUserLegalHoldStatus Just team -> do - mMember <- liftSem $ getTeamMember team other + mMember <- getTeamMember team other pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember -anyLegalholdActivated :: Member TeamStore r => [UserId] -> Galley r Bool +anyLegalholdActivated :: + Members '[Input Opts, TeamStore] r => + [UserId] -> + Sem r Bool anyLegalholdActivated uids = do - view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case + opts <- input + case view (optSettings . setFeatureFlags . flagLegalHold) opts of FeatureLegalHoldDisabledPermanently -> pure False FeatureLegalHoldDisabledByDefault -> check FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> check where check = do flip anyM (chunksOf 32 uids) $ \uidsPage -> do - teamsOfUsers <- liftSem $ getUsersTeams uidsPage + teamsOfUsers <- getUsersTeams uidsPage anyM (\uid -> userLHEnabled <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage allLegalholdConsentGiven :: - Members '[LegalHoldStore, TeamStore] r => + Members '[Input Opts, LegalHoldStore, TeamStore] r => [UserId] -> - Galley r Bool + Sem r Bool allLegalholdConsentGiven uids = do - view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case + opts <- input + case view (optSettings . setFeatureFlags . flagLegalHold) opts of FeatureLegalHoldDisabledPermanently -> pure False FeatureLegalHoldDisabledByDefault -> do flip allM (chunksOf 32 uids) $ \uidsPage -> do - teamsOfUsers <- liftSem $ getUsersTeams uidsPage + teamsOfUsers <- getUsersTeams uidsPage allM (\uid -> (== ConsentGiven) . consentGiven <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do -- For this feature the implementation is more efficient. Being part of -- a whitelisted team is equivalent to have given consent to be in a -- conversation with user under legalhold. flip allM (chunksOf 32 uids) $ \uidsPage -> do - teamsPage <- liftSem $ nub . Map.elems <$> getUsersTeams uidsPage - allM (liftSem . isTeamLegalholdWhitelisted) teamsPage + teamsPage <- nub . Map.elems <$> getUsersTeams uidsPage + allM (isTeamLegalholdWhitelisted) teamsPage -- | Add to every uid the legalhold status getLHStatusForUsers :: Member TeamStore r => [UserId] -> - Galley r [(UserId, UserLegalHoldStatus)] + Sem r [(UserId, UserLegalHoldStatus)] getLHStatusForUsers uids = mconcat <$> ( for (chunksOf 32 uids) $ \uidsChunk -> do - teamsOfUsers <- liftSem $ getUsersTeams uidsChunk + teamsOfUsers <- getUsersTeams uidsChunk for uidsChunk $ \uid -> do (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid ) -getTeamMembersForFanout :: Member TeamStore r => TeamId -> Galley r TeamMemberList +getTeamMembersForFanout :: Member TeamStore r => TeamId -> Sem r TeamMemberList getTeamMembersForFanout tid = do lim <- fanoutLimit - liftSem $ getTeamMembersWithLimit tid lim + getTeamMembersWithLimit tid lim -ensureMemberLimit :: (Foldable f, Member (Error ConversationError) r) => [LocalMember] -> f a -> Galley r () +ensureMemberLimit :: + (Foldable f, Members '[Error ConversationError, Input Opts] r) => + [LocalMember] -> + f a -> + Sem r () ensureMemberLimit old new = do - o <- view options + o <- input let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) - liftSem . when (length old + length new > maxSize) $ + 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 3053713219c..7b63c880cbe 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -35,55 +35,35 @@ module Galley.App ExtEnv (..), extGetManager, - -- * Galley monad - Galley, + -- * Running Galley effects GalleyEffects, - Galley0, runGalley, evalGalley, ask, DeleteItem (..), toServantHandler, - - -- * Utilities - fromJsonBody, - fromOptionalJsonBody, - fromProtoBody, - fanoutLimit, - currentFanoutLimit, - - -- * Temporary compatibility functions - fireAndForget, - spawnMany, - liftGalley0, - liftSem, - unGalley, - interpretGalleyToGalley0, ) where import Bilge hiding (Request, header, options, statusCode, statusMessage) -import Bilge.RPC import Cassandra hiding (Set) import qualified Cassandra as C import qualified Cassandra.Settings as C import Control.Error import qualified Control.Exception import Control.Lens hiding ((.=)) -import Control.Monad.Catch (MonadCatch (..), MonadMask (..), MonadThrow (..)) -import Data.Aeson (FromJSON) import qualified Data.Aeson as Aeson import Data.ByteString.Conversion (toByteString') import Data.Default (def) import qualified Data.List.NonEmpty as NE import Data.Metrics.Middleware -import qualified Data.ProtocolBuffers as Proto import Data.Proxy (Proxy (..)) +import Data.Qualified import Data.Range -import Data.Serialize.Get (runGetLazy) import Data.Text (unpack) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import Data.Time.Clock import Galley.API.Error import qualified Galley.Aws as Aws import Galley.Cassandra.Client @@ -100,12 +80,13 @@ import Galley.Cassandra.TeamFeatures import Galley.Cassandra.TeamNotifications import Galley.Effects import Galley.Effects.FireAndForget (interpretFireAndForget) -import qualified Galley.Effects.FireAndForget as E +import Galley.Effects.WaiRoutes.IO import Galley.Env import Galley.External import Galley.Intra.Effects import Galley.Intra.Federator import Galley.Options +import Galley.Queue import qualified Galley.Queue as Q import qualified Galley.Types.Teams as Teams import Imports hiding (forkIO) @@ -115,15 +96,14 @@ import Network.HTTP.Media.RenderHeader (RenderHeader (..)) 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 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.Input import Polysemy.Internal (Append) -import qualified Polysemy.Reader as P import qualified Polysemy.TinyLog as P import qualified Servant import Ssl.Util @@ -131,43 +111,12 @@ import System.Logger.Class import qualified System.Logger.Extended as Logger import qualified UnliftIO.Exception as UnliftIO import Util.Options -import Wire.API.Federation.Client (HasFederatorConfig (..)) --- MTL-style effects derived from the old implementation of the Galley monad. --- They will disappear as we introduce more high-level effects into Galley. -type GalleyEffects0 = '[P.TinyLog, P.Reader ClientState, P.Reader Env, Embed IO, Final IO] +-- Effects needed by the interpretation of other effects +type GalleyEffects0 = '[Input ClientState, Input Env, Embed IO, Final IO] type GalleyEffects = Append GalleyEffects1 GalleyEffects0 -type Galley0 = Galley GalleyEffects0 - -newtype Galley r a = Galley {unGalley :: Members GalleyEffects0 r => Sem r a} - -instance Functor (Galley r) where - fmap f (Galley x) = Galley (fmap f x) - -instance Applicative (Galley r) where - pure x = Galley (pure x) - (<*>) = ap - -instance Monad (Galley r) where - return = pure - Galley m >>= f = Galley (m >>= unGalley . f) - -instance MonadIO (Galley r) where - liftIO action = Galley (liftIO action) - -instance MonadReader Env (Galley r) where - ask = Galley $ P.ask @Env - local f m = Galley $ P.local f (unGalley m) - -instance HasFederatorConfig (Galley r) where - federatorEndpoint = view federator - federationDomain = view (options . optSettings . setFederationDomain) - -fanoutLimit :: Galley r (Range 1 Teams.HardTruncationLimit Int32) -fanoutLimit = view options >>= return . currentFanoutLimit - -- Define some invariants for the options used validateOptions :: Logger -> Opts -> IO () validateOptions l o = do @@ -191,17 +140,6 @@ validateOptions l o = do when (settings ^. setMaxTeamSize < optFanoutLimit) $ error "setMaxTeamSize cannot be < setTruncationLimit" -instance MonadLogger (Galley r) where - log l m = Galley $ P.polylog l m - -instance MonadHttp (Galley r) where - handleRequestWithCont req handler = do - httpManager <- view manager - liftIO $ withResponse req httpManager handler - -instance HasRequestId (Galley r) where - getRequestId = view reqId - createEnv :: Metrics -> Opts -> IO Env createEnv m o = do l <- Logger.mkLogger (o ^. optLogLevel) (o ^. optLogNetStrings) (o ^. optLogFormat) @@ -250,19 +188,11 @@ initHttpManager o = do managerIdleConnectionCount = 3 * (o ^. optSettings . setHttpPoolSize) } -runGalley :: Env -> Request -> Galley GalleyEffects a -> IO a +runGalley :: Env -> Request -> Sem GalleyEffects a -> IO a runGalley e r m = let e' = reqId .~ lookupReqId r $ e in evalGalley e' m -evalGalley0 :: Env -> Sem GalleyEffects0 a -> IO a -evalGalley0 e = - runFinal @IO - . embedToFinal @IO - . P.runReader e - . P.runReader (e ^. cstate) - . interpretTinyLog e - interpretTinyLog :: Members '[Embed IO] r => Env -> @@ -271,32 +201,10 @@ interpretTinyLog :: interpretTinyLog e = interpret $ \case P.Polylog l m -> Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) -evalGalley :: Env -> Galley GalleyEffects a -> IO a -evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 - lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders -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 (Error InvalidInput) r, - FromJSON a - ) => - OptionalJsonRequest a -> - Galley r (Maybe a) -fromOptionalJsonBody r = exceptT (liftSem . throw . InvalidPayload) return (parseOptionalBody r) -{-# INLINE fromOptionalJsonBody #-} - -fromProtoBody :: (Member (Error InvalidInput) r, Proto.Decode a) => Request -> Galley r a -fromProtoBody r = do - b <- readBody r - either (liftSem . throw . InvalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) -{-# INLINE fromProtoBody #-} - -toServantHandler :: Env -> Galley GalleyEffects a -> Servant.Handler a +toServantHandler :: Env -> Sem GalleyEffects a -> Servant.Handler a toServantHandler env galley = do eith <- liftIO $ Control.Exception.try (evalGalley env galley) case eith of @@ -313,39 +221,39 @@ toServantHandler env galley = do mkCode = statusCode . Wai.code mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . Wai.code -withLH :: - Member (P.Reader Env) r => - (Teams.FeatureLegalHold -> Sem (eff ': r) a -> Sem r a) -> - Sem (eff ': r) a -> - Sem r a -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 +evalGalley :: Env -> Sem GalleyEffects a -> IO a +evalGalley e action = do + runFinal @IO + . embedToFinal @IO + . runInputConst e + . runInputConst (e ^. cstate) . interpretErrorToException . mapAllErrors + . interpretTinyLog e + . interpretQueue (e ^. deleteQueue) + . runInputSem (embed getCurrentTime) -- FUTUREWORK: could we take the time only once instead? + . interpretWaiRoutes + . runInputConst (e ^. options) + . runInputConst (toLocalUnsafe (e ^. options . optSettings . setFederationDomain) ()) . interpretInternalTeamListToCassandra . interpretTeamListToCassandra . interpretLegacyConversationListToCassandra . interpretRemoteConversationListToCassandra . interpretConversationListToCassandra - . withLH interpretTeamMemberStoreToCassandra - . withLH interpretTeamStoreToCassandra + . interpretTeamMemberStoreToCassandra lh + . interpretTeamStoreToCassandra lh . interpretTeamNotificationStoreToCassandra . interpretTeamFeatureStoreToCassandra . interpretServiceStoreToCassandra . interpretSearchVisibilityStoreToCassandra . interpretMemberStoreToCassandra - . withLH interpretLegalHoldStoreToCassandra + . interpretLegalHoldStoreToCassandra lh . interpretCustomBackendStoreToCassandra . interpretConversationStoreToCassandra . interpretCodeStoreToCassandra @@ -354,44 +262,9 @@ interpretGalleyToGalley0 = . interpretBotAccess . interpretFederatorAccess . interpretExternalAccess - . interpretSparAccess . interpretGundeckAccess + . interpretSparAccess . interpretBrigAccess - . unGalley - ----------------------------------------------------------------------------------- ----- temporary MonadUnliftIO support code for the polysemy refactoring - -fireAndForget :: Member FireAndForget r => Galley r () -> Galley r () -fireAndForget (Galley m) = Galley $ E.fireAndForget m - -spawnMany :: Member FireAndForget r => [Galley r ()] -> Galley r () -spawnMany ms = Galley $ E.spawnMany (map unGalley ms) - -instance MonadUnliftIO Galley0 where - askUnliftIO = Galley $ do - env <- P.ask @Env - pure $ UnliftIO $ evalGalley0 env . unGalley - -instance MonadMask Galley0 where - mask = UnliftIO.mask - uninterruptibleMask = UnliftIO.uninterruptibleMask - generalBracket acquire release useB = Galley $ do - env <- P.ask @Env - embed @IO $ - generalBracket - (evalGalley0 env (unGalley acquire)) - (\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 - -liftGalley0 :: Galley0 a -> Galley r a -liftGalley0 (Galley m) = Galley $ subsume_ m - -liftSem :: Sem r a -> Galley r a -liftSem m = Galley m + $ action + where + lh = view (options . optSettings . setFeatureFlags . Teams.flagLegalHold) e diff --git a/services/galley/src/Galley/Cassandra/Client.hs b/services/galley/src/Galley/Cassandra/Client.hs index ee0f4e3bda2..f5432f2a927 100644 --- a/services/galley/src/Galley/Cassandra/Client.hs +++ b/services/galley/src/Galley/Cassandra/Client.hs @@ -23,16 +23,20 @@ where import Cassandra import Control.Arrow +import Control.Lens import Data.Id import Data.List.Split (chunksOf) import qualified Galley.Cassandra.Queries as Cql import Galley.Cassandra.Store import Galley.Effects.ClientStore (ClientStore (..)) +import Galley.Env +import Galley.Monad +import Galley.Options import Galley.Types.Clients (Clients) import qualified Galley.Types.Clients as Clients import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import qualified UnliftIO updateClient :: Bool -> UserId -> ClientId -> Client () @@ -54,7 +58,7 @@ eraseClients :: UserId -> Client () eraseClients user = retry x5 (write Cql.rmClients (params LocalQuorum (Identity user))) interpretClientStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState, Input Env] r => Sem (ClientStore ': r) a -> Sem r a interpretClientStoreToCassandra = interpret $ \case @@ -62,3 +66,4 @@ interpretClientStoreToCassandra = interpret $ \case CreateClient uid cid -> embedClient $ updateClient True uid cid DeleteClient uid cid -> embedClient $ updateClient False uid cid DeleteClients uid -> embedClient $ eraseClients uid + UseIntraClientListing -> embedApp . view $ options . optSettings . setIntraListing diff --git a/services/galley/src/Galley/Cassandra/Code.hs b/services/galley/src/Galley/Cassandra/Code.hs index 539c2aaa4ec..b2d41aaf028 100644 --- a/services/galley/src/Galley/Cassandra/Code.hs +++ b/services/galley/src/Galley/Cassandra/Code.hs @@ -22,17 +22,20 @@ where import Brig.Types.Code import Cassandra +import Control.Lens 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 Galley.Env +import Galley.Options import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input interpretCodeStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState, Input Env] r => Sem (CodeStore ': r) a -> Sem r a interpretCodeStoreToCassandra = interpret $ \case @@ -41,6 +44,8 @@ interpretCodeStoreToCassandra = interpret $ \case DeleteCode k s -> embedClient $ deleteCode k s MakeKey cid -> Code.mkKey cid GenerateCode cid s t -> Code.generate cid s t + GetConversationCodeURI -> + view (options . optSettings . setConversationCodeURI) <$> input -- | Insert a conversation code insertCode :: Code -> Client () diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index 04822d1850c..bf394171954 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -44,7 +44,7 @@ import Galley.Types.UserList import Galley.Validation import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import Polysemy.TinyLog import qualified System.Logger as Log import qualified UnliftIO @@ -281,7 +281,7 @@ conversationGC conv = case join (convDeleted <$> conv) of _ -> return conv localConversations :: - (Members '[Embed IO, P.Reader ClientState, TinyLog] r) => + (Members '[Embed IO, Input ClientState, TinyLog] r) => [ConvId] -> Sem r [Conversation] localConversations [] = return [] @@ -345,7 +345,7 @@ toConv cid mms remoteMems conv = f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm interpretConversationStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState, TinyLog] r => + Members '[Embed IO, Input ClientState, TinyLog] r => Sem (ConversationStore ': r) a -> Sem r a interpretConversationStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index 039fc643428..7e5e86ed596 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -44,9 +44,9 @@ import Galley.Types.ToUserRole import Galley.Types.UserList import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import qualified UnliftIO -import Wire.API.Conversation.Member +import Wire.API.Conversation.Member hiding (Member) import Wire.API.Conversation.Role import Wire.API.Provider.Service @@ -340,7 +340,7 @@ removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victim for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) interpretMemberStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (MemberStore ': r) a -> Sem r a interpretMemberStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/ConversationList.hs b/services/galley/src/Galley/Cassandra/ConversationList.hs index 324b7fad34e..a183e209b92 100644 --- a/services/galley/src/Galley/Cassandra/ConversationList.hs +++ b/services/galley/src/Galley/Cassandra/ConversationList.hs @@ -34,7 +34,7 @@ import Galley.Cassandra.Store import Galley.Effects.ListItems import Imports hiding (max) import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input -- | Deprecated, use 'localConversationIdsPageFrom' conversationIdsFrom :: @@ -66,21 +66,21 @@ remoteConversationIdsPageFrom usr pagingState max = uncurry toRemoteUnsafe <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState LocalQuorum (Identity usr) max pagingState) interpretConversationListToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ListItems CassandraPaging ConvId ': r) a -> Sem r a interpretConversationListToCassandra = interpret $ \case ListItems uid ps max -> embedClient $ localConversationIdsPageFrom uid ps max interpretRemoteConversationListToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ListItems CassandraPaging (Remote ConvId) ': r) a -> Sem r a interpretRemoteConversationListToCassandra = interpret $ \case ListItems uid ps max -> embedClient $ remoteConversationIdsPageFrom uid ps (fromRange max) interpretLegacyConversationListToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ListItems LegacyPaging ConvId ': r) a -> Sem r a interpretLegacyConversationListToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/CustomBackend.hs b/services/galley/src/Galley/Cassandra/CustomBackend.hs index fe757271b82..da687a9cac3 100644 --- a/services/galley/src/Galley/Cassandra/CustomBackend.hs +++ b/services/galley/src/Galley/Cassandra/CustomBackend.hs @@ -28,10 +28,10 @@ import Galley.Effects.CustomBackendStore (CustomBackendStore (..)) import Galley.Types import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input interpretCustomBackendStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (CustomBackendStore ': r) a -> Sem r a interpretCustomBackendStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs index 87345d5c79e..aa96b12559b 100644 --- a/services/galley/src/Galley/Cassandra/LegalHold.hs +++ b/services/galley/src/Galley/Cassandra/LegalHold.hs @@ -21,6 +21,7 @@ module Galley.Cassandra.LegalHold -- * Used by tests selectPendingPrekeys, + validateServiceKey, ) where @@ -28,20 +29,33 @@ import Brig.Types.Client.Prekey import Brig.Types.Instances () import Brig.Types.Team.LegalHold import Cassandra +import Control.Exception.Enclosed (handleAny) import Control.Lens (unsnoc) +import Data.ByteString.Conversion.To +import qualified Data.ByteString.Lazy.Char8 as LC8 import Data.Id import Data.LegalHold +import Data.Misc import Galley.Cassandra.Instances () import qualified Galley.Cassandra.Queries as Q import Galley.Cassandra.Store import Galley.Effects.LegalHoldStore (LegalHoldStore (..)) +import Galley.Env +import Galley.External.LegalHoldService.Internal +import Galley.Monad import Galley.Types.Teams import Imports +import qualified OpenSSL.EVP.Digest as SSL +import qualified OpenSSL.EVP.PKey as SSL +import qualified OpenSSL.PEM as SSL +import qualified OpenSSL.RSA as SSL import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input +import qualified Ssl.Util as SSL +import Wire.API.Provider.Service interpretLegalHoldStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState, Input Env] r => FeatureLegalHold -> Sem (LegalHoldStore ': r) a -> Sem r a @@ -56,6 +70,12 @@ interpretLegalHoldStoreToCassandra lh = interpret $ \case SetTeamLegalholdWhitelisted tid -> embedClient $ setTeamLegalholdWhitelisted tid UnsetTeamLegalholdWhitelisted tid -> embedClient $ unsetTeamLegalholdWhitelisted tid IsTeamLegalholdWhitelisted tid -> embedClient $ isTeamLegalholdWhitelisted lh tid + -- FUTUREWORK: should this action be part of a separate effect? + MakeVerifiedRequestFreshManager fpr url r -> + embedApp $ makeVerifiedRequestFreshManager fpr url r + MakeVerifiedRequest fpr url r -> + embedApp $ makeVerifiedRequest fpr url r + ValidateServiceKey sk -> embed @IO $ validateServiceKey sk -- | Returns 'False' if legal hold is not enabled for this team -- The Caller is responsible for checking whether legal hold is enabled for this team @@ -114,3 +134,33 @@ isTeamLegalholdWhitelisted FeatureLegalHoldDisabledPermanently _ = pure False isTeamLegalholdWhitelisted FeatureLegalHoldDisabledByDefault _ = pure False isTeamLegalholdWhitelisted FeatureLegalHoldWhitelistTeamsAndImplicitConsent tid = isJust <$> (runIdentity <$$> retry x5 (query1 Q.selectLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid)))) + +-- | Copied unchanged from "Brig.Provider.API". Interpret a service certificate and extract +-- key and fingerprint. (This only has to be in 'MonadIO' because the FFI in OpenSSL works +-- like that.) +-- +-- FUTUREWORK: It would be nice to move (part of) this to ssl-util, but it has types from +-- brig-types and types-common. +validateServiceKey :: MonadIO m => ServiceKeyPEM -> m (Maybe (ServiceKey, Fingerprint Rsa)) +validateServiceKey pem = + liftIO $ + readPublicKey >>= \pk -> + case join (SSL.toPublicKey <$> pk) of + Nothing -> return Nothing + Just pk' -> do + Just sha <- SSL.getDigestByName "SHA256" + let size = SSL.rsaSize (pk' :: SSL.RSAPubKey) + if size < minRsaKeySize + then return Nothing + else do + fpr <- Fingerprint <$> SSL.rsaFingerprint sha pk' + let bits = fromIntegral size * 8 + let key = ServiceKey RsaServiceKey bits pem + return $ Just (key, fpr) + where + readPublicKey = + handleAny + (const $ return Nothing) + (SSL.readPublicKey (LC8.unpack (toByteString pem)) >>= return . Just) + minRsaKeySize :: Int + minRsaKeySize = 256 -- Bytes (= 2048 bits) diff --git a/services/galley/src/Galley/Cassandra/SearchVisibility.hs b/services/galley/src/Galley/Cassandra/SearchVisibility.hs index cd3905ad4ce..136ac414c0d 100644 --- a/services/galley/src/Galley/Cassandra/SearchVisibility.hs +++ b/services/galley/src/Galley/Cassandra/SearchVisibility.hs @@ -26,10 +26,10 @@ import Galley.Effects.SearchVisibilityStore (SearchVisibilityStore (..)) import Galley.Types.Teams.SearchVisibility import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input interpretSearchVisibilityStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (SearchVisibilityStore ': r) a -> Sem r a interpretSearchVisibilityStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/Services.hs b/services/galley/src/Galley/Cassandra/Services.hs index 724c5dab5f5..785502a988f 100644 --- a/services/galley/src/Galley/Cassandra/Services.hs +++ b/services/galley/src/Galley/Cassandra/Services.hs @@ -29,7 +29,7 @@ import Galley.Types.Bot import Galley.Types.Conversations.Members (newMember) import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input -- FUTUREWORK: support adding bots to a remote conversation addBotMember :: ServiceRef -> BotId -> ConvId -> Client BotMember @@ -48,7 +48,7 @@ addBotMember s bot cnv = do -- Service -------------------------------------------------------------------- interpretServiceStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ServiceStore ': r) a -> Sem r a interpretServiceStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/Store.hs b/services/galley/src/Galley/Cassandra/Store.hs index d610321fcc0..07a876e02aa 100644 --- a/services/galley/src/Galley/Cassandra/Store.hs +++ b/services/galley/src/Galley/Cassandra/Store.hs @@ -23,9 +23,9 @@ where import Cassandra import Imports import Polysemy -import Polysemy.Reader as P +import Polysemy.Input -embedClient :: Members '[Embed IO, P.Reader ClientState] r => Client a -> Sem r a +embedClient :: Members '[Embed IO, Input ClientState] r => Client a -> Sem r a embedClient client = do - cs <- P.ask + cs <- input embed @IO $ runClient cs client diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index 9e5ece8d008..7d0f373a290 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -36,6 +36,7 @@ import qualified Data.Map.Strict as Map import Data.Range import qualified Data.Set as Set import Data.UUID.V4 (nextRandom) +import qualified Galley.Aws as Aws import qualified Galley.Cassandra.Conversation as C import Galley.Cassandra.LegalHold (isTeamLegalholdWhitelisted) import Galley.Cassandra.Paging @@ -45,6 +46,9 @@ import Galley.Cassandra.Store import Galley.Effects.ListItems import Galley.Effects.TeamMemberStore import Galley.Effects.TeamStore (TeamStore (..)) +import Galley.Env +import Galley.Monad +import Galley.Options import Galley.Types.Teams hiding ( DeleteTeam, GetTeamConversations, @@ -54,12 +58,12 @@ import qualified Galley.Types.Teams as Teams import Galley.Types.Teams.Intra import Imports hiding (Set, max) import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import qualified UnliftIO import Wire.API.Team.Member interpretTeamStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input Env, Input ClientState] r => FeatureLegalHold -> Sem (TeamStore ': r) a -> Sem r a @@ -89,16 +93,23 @@ interpretTeamStoreToCassandra lh = interpret $ \case DeleteTeamConversation tid cid -> embedClient $ removeTeamConv tid cid SetTeamData tid upd -> embedClient $ updateTeam tid upd SetTeamStatus tid st -> embedClient $ updateTeamStatus tid st + FanoutLimit -> embedApp $ currentFanoutLimit <$> view options + GetLegalHoldFlag -> + view (options . optSettings . setFeatureFlags . flagLegalHold) <$> input + EnqueueTeamEvent e -> do + menv <- inputs (view aEnv) + for_ menv $ \env -> + embed @IO $ Aws.execute env (Aws.enqueue e) interpretTeamListToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ListItems LegacyPaging TeamId ': r) a -> Sem r a interpretTeamListToCassandra = interpret $ \case ListItems uid ps lim -> embedClient $ teamIdsFrom uid ps lim interpretInternalTeamListToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (ListItems InternalPaging TeamId ': r) a -> Sem r a interpretInternalTeamListToCassandra = interpret $ \case @@ -109,7 +120,7 @@ interpretInternalTeamListToCassandra = interpret $ \case Just ps -> ipNext ps interpretTeamMemberStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => FeatureLegalHold -> Sem (TeamMemberStore InternalPaging ': r) a -> Sem r a diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 7ef181c87af..e723fe47689 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -26,7 +26,7 @@ import Galley.Data.TeamFeatures import Galley.Effects.TeamFeatureStore (TeamFeatureStore (..)) import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import Wire.API.Team.Feature getFeatureStatusNoConfig :: @@ -141,7 +141,7 @@ setSelfDeletingMessagesStatus tid status = do <> "values (?, ?, ?)" interpretTeamFeatureStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (TeamFeatureStore ': r) a -> Sem r a interpretTeamFeatureStoreToCassandra = interpret $ \case diff --git a/services/galley/src/Galley/Cassandra/TeamNotifications.hs b/services/galley/src/Galley/Cassandra/TeamNotifications.hs index 2a12e347371..dc0cb800c78 100644 --- a/services/galley/src/Galley/Cassandra/TeamNotifications.hs +++ b/services/galley/src/Galley/Cassandra/TeamNotifications.hs @@ -27,27 +27,44 @@ module Galley.Cassandra.TeamNotifications where import Cassandra +import Control.Monad.Catch +import Control.Retry (exponentialBackoff, limitRetries, retrying) import qualified Data.Aeson as JSON import Data.Id import Data.List1 (List1) import Data.Range (Range, fromRange) import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (><)) import qualified Data.Sequence as Seq +import qualified Data.UUID.V1 as UUID import Galley.Cassandra.Store import Galley.Data.TeamNotifications -import Galley.Effects.TeamNotificationStore +import Galley.Effects +import Galley.Effects.TeamNotificationStore (TeamNotificationStore (..)) import Gundeck.Types.Notification import Imports +import Network.HTTP.Types +import Network.Wai.Utilities hiding (Error) import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input interpretTeamNotificationStoreToCassandra :: - Members '[Embed IO, P.Reader ClientState] r => + Members '[Embed IO, Input ClientState] r => Sem (TeamNotificationStore ': r) a -> Sem r a interpretTeamNotificationStoreToCassandra = interpret $ \case CreateTeamNotification tid nid objs -> embedClient $ add tid nid objs GetTeamNotifications tid mnid lim -> embedClient $ fetch tid mnid lim + MkNotificationId -> embed mkNotificationId + +-- | 'Data.UUID.V1.nextUUID' is sometimes unsuccessful, so we try a few times. +mkNotificationId :: IO NotificationId +mkNotificationId = do + ni <- fmap Id <$> retrying x10 fun (const (liftIO UUID.nextUUID)) + maybe (throwM err) return ni + where + x10 = limitRetries 10 <> exponentialBackoff 10 + fun = const (return . isNothing) + err = mkError status500 "internal-error" "unable to generate notification ID" -- FUTUREWORK: the magic 32 should be made configurable, so it can be tuned add :: diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index f56cde0885b..68912c86c94 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -49,6 +49,10 @@ module Galley.Effects -- * Paging effects ListItems, + -- * Other effects + Queue, + WaiRoutes, + -- * Polysemy re-exports Member, Members, @@ -57,6 +61,7 @@ where import Data.Id import Data.Qualified +import Data.Time.Clock import Galley.API.Error import Galley.Cassandra.Paging import Galley.Effects.BotAccess @@ -72,6 +77,7 @@ import Galley.Effects.GundeckAccess import Galley.Effects.LegalHoldStore import Galley.Effects.ListItems import Galley.Effects.MemberStore +import Galley.Effects.Queue import Galley.Effects.SearchVisibilityStore import Galley.Effects.ServiceStore import Galley.Effects.SparAccess @@ -79,15 +85,20 @@ import Galley.Effects.TeamFeatureStore import Galley.Effects.TeamMemberStore import Galley.Effects.TeamNotificationStore import Galley.Effects.TeamStore +import Galley.Effects.WaiRoutes +import Galley.Env +import Galley.Options import qualified Network.Wai.Utilities as Wai import Polysemy import Polysemy.Error +import Polysemy.Input import Polysemy.Internal +import Polysemy.TinyLog type NonErrorGalleyEffects1 = '[ BrigAccess, - GundeckAccess, SparAccess, + GundeckAccess, ExternalAccess, FederatorAccess, BotAccess, @@ -108,7 +119,13 @@ type NonErrorGalleyEffects1 = ListItems CassandraPaging (Remote ConvId), ListItems LegacyPaging ConvId, ListItems LegacyPaging TeamId, - ListItems InternalPaging TeamId + ListItems InternalPaging TeamId, + Input (Local ()), + Input Opts, + WaiRoutes, + Input UTCTime, + Queue DeleteItem, + TinyLog ] -- All the possible high-level effects. diff --git a/services/galley/src/Galley/Effects/BrigAccess.hs b/services/galley/src/Galley/Effects/BrigAccess.hs index 5741e3b8b15..7ff6b448b00 100644 --- a/services/galley/src/Galley/Effects/BrigAccess.hs +++ b/services/galley/src/Galley/Effects/BrigAccess.hs @@ -44,6 +44,9 @@ module Galley.Effects.BrigAccess getLegalHoldAuthToken, addLegalHoldClientToUser, removeLegalHoldClientFromUser, + + -- * Features + getAccountFeatureConfigClient, ) where @@ -59,6 +62,7 @@ import Imports import Network.HTTP.Types.Status import Polysemy import Wire.API.Routes.Internal.Brig.Connection +import Wire.API.Team.Feature import Wire.API.Team.Size import Wire.API.User.Client import Wire.API.User.RichInfo @@ -106,6 +110,7 @@ data BrigAccess m a where LastPrekey -> BrigAccess m ClientId RemoveLegalHoldClientFromUser :: UserId -> BrigAccess m () + GetAccountFeatureConfigClient :: UserId -> BrigAccess m TeamFeatureStatusNoConfig makeSem ''BrigAccess diff --git a/services/galley/src/Galley/Effects/ClientStore.hs b/services/galley/src/Galley/Effects/ClientStore.hs index 451716d66a5..26250ba3a4b 100644 --- a/services/galley/src/Galley/Effects/ClientStore.hs +++ b/services/galley/src/Galley/Effects/ClientStore.hs @@ -28,11 +28,15 @@ module Galley.Effects.ClientStore -- * Delete client deleteClient, deleteClients, + + -- * Configuration + useIntraClientListing, ) where import Data.Id import Galley.Types.Clients +import Imports import Polysemy data ClientStore m a where @@ -40,5 +44,6 @@ data ClientStore m a where CreateClient :: UserId -> ClientId -> ClientStore m () DeleteClient :: UserId -> ClientId -> ClientStore m () DeleteClients :: UserId -> ClientStore m () + UseIntraClientListing :: ClientStore m Bool makeSem ''ClientStore diff --git a/services/galley/src/Galley/Effects/CodeStore.hs b/services/galley/src/Galley/Effects/CodeStore.hs index d06105ce5f4..0920da520a7 100644 --- a/services/galley/src/Galley/Effects/CodeStore.hs +++ b/services/galley/src/Galley/Effects/CodeStore.hs @@ -31,11 +31,15 @@ module Galley.Effects.CodeStore -- * Code generation makeKey, generateCode, + + -- * Configuration + getConversationCodeURI, ) where import Brig.Types.Code import Data.Id +import Data.Misc import Galley.Data.Types import Imports import Polysemy @@ -46,5 +50,6 @@ data CodeStore m a where DeleteCode :: Key -> Scope -> CodeStore m () MakeKey :: ConvId -> CodeStore m Key GenerateCode :: ConvId -> Scope -> Timeout -> CodeStore m Code + GetConversationCodeURI :: CodeStore m HttpsUrl makeSem ''CodeStore diff --git a/services/galley/src/Galley/Effects/FederatorAccess.hs b/services/galley/src/Galley/Effects/FederatorAccess.hs index 9a31cd3e097..9aa1db8c315 100644 --- a/services/galley/src/Galley/Effects/FederatorAccess.hs +++ b/services/galley/src/Galley/Effects/FederatorAccess.hs @@ -21,7 +21,9 @@ module Galley.Effects.FederatorAccess runFederated, runFederatedEither, runFederatedConcurrently, + runFederatedConcurrentlyEither, runFederatedConcurrently_, + isFederationConfigured, ) where @@ -49,6 +51,13 @@ data FederatorAccess m a where f (Remote x) -> (Remote [x] -> FederatedRPC c a) -> FederatorAccess m [Remote a] + RunFederatedConcurrentlyEither :: + forall (c :: Component) f a m x. + (Foldable f, Functor f) => + f (Remote x) -> + (Remote [x] -> FederatedRPC c a) -> + FederatorAccess m [Either (Remote [x], FederationError) (Remote a)] + IsFederationConfigured :: FederatorAccess m Bool makeSem ''FederatorAccess diff --git a/services/galley/src/Galley/Effects/GundeckAccess.hs b/services/galley/src/Galley/Effects/GundeckAccess.hs index 1f035ff1a87..93308d6e635 100644 --- a/services/galley/src/Galley/Effects/GundeckAccess.hs +++ b/services/galley/src/Galley/Effects/GundeckAccess.hs @@ -20,6 +20,7 @@ module Galley.Effects.GundeckAccess GundeckAccess (..), push, push1, + pushSlowly, ) where @@ -29,6 +30,7 @@ import Polysemy data GundeckAccess m a where Push :: Foldable f => f G.Push -> GundeckAccess m () + PushSlowly :: Foldable f => f G.Push -> GundeckAccess m () makeSem ''GundeckAccess diff --git a/services/galley/src/Galley/Effects/LegalHoldStore.hs b/services/galley/src/Galley/Effects/LegalHoldStore.hs index 28b70fcf1f8..4dab3fbefb7 100644 --- a/services/galley/src/Galley/Effects/LegalHoldStore.hs +++ b/services/galley/src/Galley/Effects/LegalHoldStore.hs @@ -16,7 +16,10 @@ -- with this program. If not, see . module Galley.Effects.LegalHoldStore - ( LegalHoldStore (..), + ( -- * LegalHold store effect + LegalHoldStore (..), + + -- * Store actions createSettings, getSettings, removeSettings, @@ -27,14 +30,23 @@ module Galley.Effects.LegalHoldStore setTeamLegalholdWhitelisted, unsetTeamLegalholdWhitelisted, isTeamLegalholdWhitelisted, + validateServiceKey, + + -- * Intra actions + makeVerifiedRequest, + makeVerifiedRequestFreshManager, ) where +import qualified Data.ByteString.Lazy.Char8 as LC8 import Data.Id import Data.LegalHold +import Data.Misc import Galley.External.LegalHoldService.Types import Imports +import qualified Network.HTTP.Client as Http import Polysemy +import Wire.API.Provider.Service import Wire.API.User.Client.Prekey data LegalHoldStore m a where @@ -48,5 +60,17 @@ data LegalHoldStore m a where SetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m () UnsetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m () IsTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m Bool + -- intra actions + MakeVerifiedRequestFreshManager :: + Fingerprint Rsa -> + HttpsUrl -> + (Http.Request -> Http.Request) -> + LegalHoldStore m (Http.Response LC8.ByteString) + MakeVerifiedRequest :: + Fingerprint Rsa -> + HttpsUrl -> + (Http.Request -> Http.Request) -> + LegalHoldStore m (Http.Response LC8.ByteString) + ValidateServiceKey :: ServiceKeyPEM -> LegalHoldStore m (Maybe (ServiceKey, Fingerprint Rsa)) makeSem ''LegalHoldStore diff --git a/services/galley/src/Galley/Effects/Queue.hs b/services/galley/src/Galley/Effects/Queue.hs new file mode 100644 index 00000000000..111ab6d2946 --- /dev/null +++ b/services/galley/src/Galley/Effects/Queue.hs @@ -0,0 +1,32 @@ +-- 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.Effects.Queue + ( Queue (..), + tryPush, + pop, + ) +where + +import Imports +import Polysemy + +data Queue a m x where + TryPush :: a -> Queue a m Bool + Pop :: Queue a m a + +makeSem ''Queue diff --git a/services/galley/src/Galley/Effects/TeamNotificationStore.hs b/services/galley/src/Galley/Effects/TeamNotificationStore.hs index 5e553315d44..23f4d7ed846 100644 --- a/services/galley/src/Galley/Effects/TeamNotificationStore.hs +++ b/services/galley/src/Galley/Effects/TeamNotificationStore.hs @@ -15,7 +15,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Effects.TeamNotificationStore where +module Galley.Effects.TeamNotificationStore + ( TeamNotificationStore (..), + createTeamNotification, + getTeamNotifications, + mkNotificationId, + ) +where import qualified Data.Aeson as JSON import Data.Id @@ -37,5 +43,6 @@ data TeamNotificationStore m a where Maybe NotificationId -> Range 1 10000 Int32 -> TeamNotificationStore m ResultPage + MkNotificationId :: TeamNotificationStore m NotificationId makeSem ''TeamNotificationStore diff --git a/services/galley/src/Galley/Effects/TeamStore.hs b/services/galley/src/Galley/Effects/TeamStore.hs index 541d87f39dc..18eee5f98ca 100644 --- a/services/galley/src/Galley/Effects/TeamStore.hs +++ b/services/galley/src/Galley/Effects/TeamStore.hs @@ -63,6 +63,13 @@ module Galley.Effects.TeamStore -- ** Delete team members deleteTeamMember, + + -- * Configuration + fanoutLimit, + getLegalHoldFlag, + + -- * Events + enqueueTeamEvent, ) where @@ -74,6 +81,7 @@ import Galley.Types.Teams import Galley.Types.Teams.Intra import Imports import Polysemy +import qualified Proto.TeamEvents as E data TeamStore m a where CreateTeamMember :: TeamId -> TeamMember -> TeamStore m () @@ -107,6 +115,9 @@ data TeamStore m a where DeleteTeamConversation :: TeamId -> ConvId -> TeamStore m () SetTeamData :: TeamId -> TeamUpdateData -> TeamStore m () SetTeamStatus :: TeamId -> TeamStatus -> TeamStore m () + FanoutLimit :: TeamStore m (Range 1 HardTruncationLimit Int32) + GetLegalHoldFlag :: TeamStore m FeatureLegalHold + EnqueueTeamEvent :: E.TeamEvent -> TeamStore m () makeSem ''TeamStore diff --git a/services/galley/src/Galley/Effects/WaiRoutes.hs b/services/galley/src/Galley/Effects/WaiRoutes.hs new file mode 100644 index 00000000000..3e3a43a5389 --- /dev/null +++ b/services/galley/src/Galley/Effects/WaiRoutes.hs @@ -0,0 +1,38 @@ +-- 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.Effects.WaiRoutes + ( WaiRoutes (..), + fromJsonBody, + fromOptionalJsonBody, + fromProtoBody, + ) +where + +import Data.Aeson (FromJSON) +import qualified Data.ProtocolBuffers as Proto +import Imports +import Network.Wai +import Network.Wai.Utilities hiding (Error) +import Polysemy + +data WaiRoutes m a where + FromJsonBody :: FromJSON a => JsonRequest a -> WaiRoutes m a + FromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> WaiRoutes m (Maybe a) + FromProtoBody :: Proto.Decode a => Request -> WaiRoutes m a + +makeSem ''WaiRoutes diff --git a/services/galley/src/Galley/Effects/WaiRoutes/IO.hs b/services/galley/src/Galley/Effects/WaiRoutes/IO.hs new file mode 100644 index 00000000000..a71aba6080b --- /dev/null +++ b/services/galley/src/Galley/Effects/WaiRoutes/IO.hs @@ -0,0 +1,39 @@ +-- 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.Effects.WaiRoutes.IO where + +import Control.Error +import qualified Data.ProtocolBuffers as Proto +import Data.Serialize.Get +import Galley.API.Error +import Galley.Effects.WaiRoutes +import Imports +import Network.Wai.Utilities hiding (Error) +import Polysemy +import Polysemy.Error + +interpretWaiRoutes :: + Members '[Embed IO, Error InvalidInput] r => + Sem (WaiRoutes ': r) a -> + Sem r a +interpretWaiRoutes = interpret $ \case + FromJsonBody r -> exceptT (throw . InvalidPayload) return (parseBody r) + FromOptionalJsonBody r -> exceptT (throw . InvalidPayload) return (parseOptionalBody r) + FromProtoBody r -> do + b <- readBody r + either (throw . InvalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index e325f3da587..d25d3db1900 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -30,7 +30,7 @@ import Galley.Effects import Galley.Effects.ExternalAccess (ExternalAccess (..)) import Galley.Env import Galley.Intra.User -import Galley.Intra.Util +import Galley.Monad import Galley.Types (Event) import Galley.Types.Bot import Imports @@ -38,7 +38,7 @@ import qualified Network.HTTP.Client as Http import Network.HTTP.Types.Method import Network.HTTP.Types.Status (status410) import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import Ssl.Util (withVerifiedSslConnection) import qualified System.Logger.Class as Log import System.Logger.Message (field, msg, val, (~~)) @@ -46,37 +46,37 @@ import URI.ByteString import UnliftIO (Async, async, waitCatch) interpretExternalAccess :: - Members '[Embed IO, P.Reader Env] r => + Members '[Embed IO, Input Env] r => Sem (ExternalAccess ': r) a -> Sem r a interpretExternalAccess = interpret $ \case - Deliver pp -> embedIntra $ deliver (toList pp) - DeliverAsync pp -> embedIntra $ deliverAsync (toList pp) - DeliverAndDeleteAsync cid pp -> embedIntra $ deliverAndDeleteAsync cid (toList pp) + Deliver pp -> embedApp $ deliver (toList pp) + DeliverAsync pp -> embedApp $ deliverAsync (toList pp) + DeliverAndDeleteAsync cid pp -> embedApp $ deliverAndDeleteAsync cid (toList pp) -- | Like deliver, but ignore orphaned bots and return immediately. -- -- FUTUREWORK: Check if this can be removed. -deliverAsync :: [(BotMember, Event)] -> IntraM () +deliverAsync :: [(BotMember, Event)] -> App () deliverAsync = void . forkIO . void . deliver -- | Like deliver, but remove orphaned bots and return immediately. -deliverAndDeleteAsync :: ConvId -> [(BotMember, Event)] -> IntraM () +deliverAndDeleteAsync :: ConvId -> [(BotMember, Event)] -> App () deliverAndDeleteAsync cnv pushes = void . forkIO $ do gone <- deliver pushes mapM_ (deleteBot cnv . botMemId) gone -deliver :: [(BotMember, Event)] -> IntraM [BotMember] +deliver :: [(BotMember, Event)] -> App [BotMember] deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) where - exec :: (BotMember, Event) -> IntraM Bool + exec :: (BotMember, Event) -> App Bool exec (b, e) = lookupService (botMemService b) >>= \case Nothing -> return False Just s -> do deliver1 s b e return True - eval :: [BotMember] -> (BotMember, Async Bool) -> IntraM [BotMember] + eval :: [BotMember] -> (BotMember, Async Bool) -> App [BotMember] eval gone (b, a) = do let s = botMemService b r <- waitCatch a @@ -115,7 +115,7 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) -- Internal ------------------------------------------------------------------- -deliver1 :: Service -> BotMember -> Event -> IntraM () +deliver1 :: Service -> BotMember -> Event -> App () deliver1 s bm e | s ^. serviceEnabled = do let t = toByteString' (s ^. serviceToken) @@ -145,7 +145,7 @@ urlPort (HttpsUrl u) = do p <- a ^. authorityPortL return (fromIntegral (p ^. portNumberL)) -sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> IntraM () +sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> App () sendMessage fprs reqBuilder = do (man, verifyFingerprints) <- view (extEnv . extGetManager) liftIO . withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index affafacf2ee..14dee18e6ac 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -29,55 +29,40 @@ where import qualified Bilge import Bilge.Response -import Bilge.Retry import Brig.Types.Provider import Brig.Types.Team.LegalHold -import Control.Exception.Enclosed (handleAny) -import Control.Lens hiding ((#), (.=)) -import Control.Monad.Catch -import Control.Retry import Data.Aeson -import qualified Data.ByteString as BS import Data.ByteString.Conversion.To import qualified Data.ByteString.Lazy.Char8 as LC8 import Data.Id import Data.Misc import Galley.API.Error -import Galley.App import Galley.Effects.LegalHoldStore as LegalHoldData -import Galley.Env import Galley.External.LegalHoldService.Types import Imports import qualified Network.HTTP.Client as Http import Network.HTTP.Types -import qualified OpenSSL.EVP.Digest as SSL -import qualified OpenSSL.EVP.PKey as SSL -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 Polysemy.TinyLog as P import qualified System.Logger.Class as Log -import URI.ByteString (uriPath) ---------------------------------------------------------------------- -- api -- | Get /status from legal hold service; throw 'Wai.Error' if things go wrong. checkLegalHoldServiceStatus :: - Member (Error LegalHoldError) r => + Members '[Error LegalHoldError, LegalHoldStore, P.TinyLog] r => Fingerprint Rsa -> HttpsUrl -> - Galley r () + Sem 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 + P.info . Log.msg $ showResponse resp + throw LegalHoldServiceBadResponse where reqBuilder :: Http.Request -> Http.Request reqBuilder = @@ -87,16 +72,16 @@ checkLegalHoldServiceStatus fpr url = do -- | @POST /initiate@. requestNewDevice :: - Members '[Error LegalHoldError, LegalHoldStore] r => + Members '[Error LegalHoldError, LegalHoldStore, P.TinyLog] r => TeamId -> UserId -> - Galley r NewLegalHoldClient + Sem r NewLegalHoldClient requestNewDevice tid uid = do resp <- makeLegalHoldServiceRequest tid reqParams case eitherDecode (responseBody resp) of Left e -> do - Log.info . Log.msg $ "Error decoding NewLegalHoldClient: " <> e - liftSem $ throw LegalHoldServiceBadResponse + P.info . Log.msg $ "Error decoding NewLegalHoldClient: " <> e + throw LegalHoldServiceBadResponse Right client -> pure client where reqParams = @@ -115,7 +100,7 @@ confirmLegalHold :: UserId -> -- | TODO: Replace with 'LegalHold' token type OpaqueAuthToken -> - Galley r () + Sem r () confirmLegalHold clientId tid uid legalHoldAuthToken = do void $ makeLegalHoldServiceRequest tid reqParams where @@ -132,7 +117,7 @@ removeLegalHold :: Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> UserId -> - Galley r () + Sem r () removeLegalHold tid uid = do void $ makeLegalHoldServiceRequest tid reqParams where @@ -153,11 +138,11 @@ makeLegalHoldServiceRequest :: Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> (Http.Request -> Http.Request) -> - Galley r (Http.Response LC8.ByteString) + Sem r (Http.Response LC8.ByteString) makeLegalHoldServiceRequest tid reqBuilder = do - maybeLHSettings <- liftSem $ LegalHoldData.getSettings tid + maybeLHSettings <- LegalHoldData.getSettings tid lhSettings <- case maybeLHSettings of - Nothing -> liftSem $ throw LegalHoldServiceNotRegistered + Nothing -> throw LegalHoldServiceNotRegistered Just lhSettings -> pure lhSettings let LegalHoldService { legalHoldServiceUrl = baseUrl, @@ -169,84 +154,3 @@ makeLegalHoldServiceRequest tid reqBuilder = do mkReqBuilder token = reqBuilder . Bilge.header "Authorization" ("Bearer " <> toByteString' token) - -makeVerifiedRequest :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) -makeVerifiedRequest fpr url reqBuilder = do - (mgr, verifyFingerprints) <- view (extEnv . extGetManager) - makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder - --- | NOTE: Use this function wisely - this creates a new manager _every_ time it is called. --- We should really _only_ use it in `checkLegalHoldServiceStatus` for the time being because --- this is where we check for signatures, etc. If we reuse the manager, we are likely to reuse --- an existing connection which will _not_ cause the new public key to be verified. -makeVerifiedRequestFreshManager :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) -makeVerifiedRequestFreshManager fpr url reqBuilder = do - ExtEnv (mgr, verifyFingerprints) <- liftIO initExtEnv - makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder - --- | Check that the given fingerprint is valid and make the request over ssl. --- If the team has a device registered use 'makeLegalHoldServiceRequest' instead. -makeVerifiedRequestWithManager :: Http.Manager -> ([Fingerprint Rsa] -> SSL.SSL -> IO ()) -> Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) -makeVerifiedRequestWithManager mgr verifyFingerprints fpr (HttpsUrl url) reqBuilder = do - let verified = verifyFingerprints [fpr] - liftGalley0 $ - extHandleAll errHandler $ do - recovering x3 httpHandlers $ - const $ - liftIO $ - withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ - \req -> - Http.httpLbs req mgr - where - reqBuilderMods = - maybe id Bilge.host (Bilge.extHost url) - . Bilge.port (fromMaybe 443 (Bilge.extPort url)) - . Bilge.secure - . prependPath (uriPath url) - errHandler e = do - Log.info . Log.msg $ "error making request to legalhold service: " <> show e - throwM legalHoldServiceUnavailable - prependPath :: ByteString -> Http.Request -> Http.Request - prependPath pth req = req {Http.path = pth Http.path req} - -- append two paths with exactly one slash - () :: ByteString -> ByteString -> ByteString - a b = fromMaybe a (BS.stripSuffix "/" a) <> "/" <> fromMaybe b (BS.stripPrefix "/" b) - x3 :: RetryPolicy - x3 = limitRetries 3 <> exponentialBackoff 100000 - extHandleAll :: MonadCatch m => (SomeException -> m a) -> m a -> m a - extHandleAll f ma = - catches - ma - [ Handler $ \(ex :: SomeAsyncException) -> throwM ex, - Handler $ \(ex :: SomeException) -> f ex - ] - --- | Copied unchanged from "Brig.Provider.API". Interpret a service certificate and extract --- key and fingerprint. (This only has to be in 'MonadIO' because the FFI in OpenSSL works --- like that.) --- --- FUTUREWORK: It would be nice to move (part of) this to ssl-util, but it has types from --- brig-types and types-common. -validateServiceKey :: MonadIO m => ServiceKeyPEM -> m (Maybe (ServiceKey, Fingerprint Rsa)) -validateServiceKey pem = - liftIO $ - readPublicKey >>= \pk -> - case join (SSL.toPublicKey <$> pk) of - Nothing -> return Nothing - Just pk' -> do - Just sha <- SSL.getDigestByName "SHA256" - let size = SSL.rsaSize (pk' :: SSL.RSAPubKey) - if size < minRsaKeySize - then return Nothing - else do - fpr <- Fingerprint <$> SSL.rsaFingerprint sha pk' - let bits = fromIntegral size * 8 - let key = ServiceKey RsaServiceKey bits pem - return $ Just (key, fpr) - where - readPublicKey = - handleAny - (const $ return Nothing) - (SSL.readPublicKey (LC8.unpack (toByteString pem)) >>= return . Just) - minRsaKeySize :: Int - minRsaKeySize = 256 -- Bytes (= 2048 bits) diff --git a/services/galley/src/Galley/External/LegalHoldService/Internal.hs b/services/galley/src/Galley/External/LegalHoldService/Internal.hs new file mode 100644 index 00000000000..47836150ad4 --- /dev/null +++ b/services/galley/src/Galley/External/LegalHoldService/Internal.hs @@ -0,0 +1,99 @@ +-- 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.External.LegalHoldService.Internal + ( makeVerifiedRequest, + makeVerifiedRequestFreshManager, + ) +where + +import qualified Bilge +import Bilge.Retry +import Brig.Types.Provider +import Control.Lens (view) +import Control.Monad.Catch +import Control.Retry +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as LC8 +import Data.Misc +import Galley.API.Error +import Galley.Env +import Galley.Monad +import Imports +import qualified Network.HTTP.Client as Http +import qualified OpenSSL.Session as SSL +import Ssl.Util +import qualified System.Logger.Class as Log +import URI.ByteString (uriPath) + +-- | Check that the given fingerprint is valid and make the request over ssl. +-- If the team has a device registered use 'makeLegalHoldServiceRequest' instead. +makeVerifiedRequestWithManager :: Http.Manager -> ([Fingerprint Rsa] -> SSL.SSL -> IO ()) -> Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> App (Http.Response LC8.ByteString) +makeVerifiedRequestWithManager mgr verifyFingerprints fpr (HttpsUrl url) reqBuilder = do + let verified = verifyFingerprints [fpr] + extHandleAll errHandler $ do + recovering x3 httpHandlers $ + const $ + liftIO $ + withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ + \req -> + Http.httpLbs req mgr + where + reqBuilderMods = + maybe id Bilge.host (Bilge.extHost url) + . Bilge.port (fromMaybe 443 (Bilge.extPort url)) + . Bilge.secure + . prependPath (uriPath url) + errHandler e = do + Log.info . Log.msg $ "error making request to legalhold service: " <> show e + throwM legalHoldServiceUnavailable + prependPath :: ByteString -> Http.Request -> Http.Request + prependPath pth req = req {Http.path = pth Http.path req} + -- append two paths with exactly one slash + () :: ByteString -> ByteString -> ByteString + a b = fromMaybe a (BS.stripSuffix "/" a) <> "/" <> fromMaybe b (BS.stripPrefix "/" b) + x3 :: RetryPolicy + x3 = limitRetries 3 <> exponentialBackoff 100000 + extHandleAll :: MonadCatch m => (SomeException -> m a) -> m a -> m a + extHandleAll f ma = + catches + ma + [ Handler $ \(ex :: SomeAsyncException) -> throwM ex, + Handler $ \(ex :: SomeException) -> f ex + ] + +makeVerifiedRequest :: + Fingerprint Rsa -> + HttpsUrl -> + (Http.Request -> Http.Request) -> + App (Http.Response LC8.ByteString) +makeVerifiedRequest fpr url reqBuilder = do + (mgr, verifyFingerprints) <- view (extEnv . extGetManager) + makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder + +-- | NOTE: Use this function wisely - this creates a new manager _every_ time it is called. +-- We should really _only_ use it in `checkLegalHoldServiceStatus` for the time being because +-- this is where we check for signatures, etc. If we reuse the manager, we are likely to reuse +-- an existing connection which will _not_ cause the new public key to be verified. +makeVerifiedRequestFreshManager :: + Fingerprint Rsa -> + HttpsUrl -> + (Http.Request -> Http.Request) -> + App (Http.Response LC8.ByteString) +makeVerifiedRequestFreshManager fpr url reqBuilder = do + ExtEnv (mgr, verifyFingerprints) <- liftIO initExtEnv + makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder diff --git a/services/galley/src/Galley/Intra/Client.hs b/services/galley/src/Galley/Intra/Client.hs index 52a783513c7..59587ed99c7 100644 --- a/services/galley/src/Galley/Intra/Client.hs +++ b/services/galley/src/Galley/Intra/Client.hs @@ -31,7 +31,6 @@ import Brig.Types.Client import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.Types.User.Auth (LegalHoldLogin (..)) -import Control.Monad.Catch import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Misc @@ -42,18 +41,20 @@ import Galley.Effects import Galley.Env import Galley.External.LegalHoldService.Types import Galley.Intra.Util +import Galley.Monad import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status -import Network.Wai.Utilities.Error +import Network.Wai.Utilities.Error hiding (Error) import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Error +import Polysemy.Input import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Logger import Wire.API.User.Client (UserClients, UserClientsFull, filterClients, filterClientsFull) -- | Calls 'Brig.API.internalListClientsH'. -lookupClients :: [UserId] -> IntraM UserClients +lookupClients :: [UserId] -> App UserClients lookupClients uids = do r <- call Brig $ @@ -67,7 +68,7 @@ lookupClients uids = do -- | Calls 'Brig.API.internalListClientsFullH'. lookupClientsFull :: [UserId] -> - IntraM UserClientsFull + App UserClientsFull lookupClientsFull uids = do r <- call Brig $ @@ -83,7 +84,7 @@ notifyClientsAboutLegalHoldRequest :: UserId -> UserId -> LastPrekey -> - IntraM () + App () notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do void . call Brig $ method POST @@ -93,13 +94,13 @@ notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do -- | Calls 'Brig.User.API.Auth.legalHoldLoginH'. getLegalHoldAuthToken :: - Members '[Embed IO, P.TinyLog, P.Reader Env] r => + Members '[Embed IO, Error InternalError, P.TinyLog, Input Env] r => UserId -> Maybe PlainTextPassword -> Sem r OpaqueAuthToken getLegalHoldAuthToken uid pw = do r <- - embedIntra . call Brig $ + embedApp . call Brig $ method POST . path "/i/legalhold-login" . queryItem "persist" "true" @@ -108,7 +109,7 @@ getLegalHoldAuthToken uid pw = do case getCookieValue "zuid" r of Nothing -> do P.warn $ Logger.msg @Text "Response from login missing auth cookie" - embed $ throwM internalError + throw $ InternalErrorWithDescription "internal error" Just c -> pure . OpaqueAuthToken . decodeUtf8 $ c -- | Calls 'Brig.API.addClientInternalH'. @@ -117,7 +118,7 @@ addLegalHoldClientToUser :: ConnId -> [Prekey] -> LastPrekey -> - IntraM ClientId + App ClientId addLegalHoldClientToUser uid connId prekeys lastPrekey' = do clientId <$> brigAddClient uid connId lhClient where @@ -136,7 +137,7 @@ addLegalHoldClientToUser uid connId prekeys lastPrekey' = do -- | Calls 'Brig.API.removeLegalHoldClientH'. removeLegalHoldClientFromUser :: UserId -> - IntraM () + App () removeLegalHoldClientFromUser targetUid = do void . call Brig $ method DELETE @@ -145,7 +146,7 @@ removeLegalHoldClientFromUser targetUid = do . expect2xx -- | Calls 'Brig.API.addClientInternalH'. -brigAddClient :: UserId -> ConnId -> NewClient -> IntraM Client +brigAddClient :: UserId -> ConnId -> NewClient -> App Client brigAddClient uid connId client = do r <- call Brig $ diff --git a/services/galley/src/Galley/Intra/Effects.hs b/services/galley/src/Galley/Intra/Effects.hs index 26191832bfa..a282b00d04d 100644 --- a/services/galley/src/Galley/Intra/Effects.hs +++ b/services/galley/src/Galley/Intra/Effects.hs @@ -23,6 +23,7 @@ module Galley.Intra.Effects ) where +import Galley.API.Error import Galley.Effects.BotAccess (BotAccess (..)) import Galley.Effects.BrigAccess (BrigAccess (..)) import Galley.Effects.GundeckAccess (GundeckAccess (..)) @@ -33,63 +34,67 @@ import qualified Galley.Intra.Push.Internal as G import Galley.Intra.Spar import Galley.Intra.Team import Galley.Intra.User -import Galley.Intra.Util +import Galley.Monad import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Error +import Polysemy.Input import qualified Polysemy.TinyLog as P import qualified UnliftIO interpretBrigAccess :: - Members '[Embed IO, P.TinyLog, P.Reader Env] r => + Members '[Embed IO, Error InternalError, P.TinyLog, Input Env] r => Sem (BrigAccess ': r) a -> Sem r a interpretBrigAccess = interpret $ \case GetConnectionsUnqualified uids muids mrel -> - embedIntra $ getConnectionsUnqualified uids muids mrel + embedApp $ getConnectionsUnqualified uids muids mrel GetConnectionsUnqualifiedBidi uids1 uids2 mrel1 mrel2 -> - embedIntra $ + embedApp $ UnliftIO.concurrently (getConnectionsUnqualified uids1 (Just uids2) mrel1) (getConnectionsUnqualified uids2 (Just uids1) mrel2) GetConnections uids mquids mrel -> - embedIntra $ + embedApp $ getConnections uids mquids mrel - PutConnectionInternal uc -> embedIntra $ putConnectionInternal uc - ReauthUser uid reauth -> embedIntra $ reAuthUser uid reauth - LookupActivatedUsers uids -> embedIntra $ lookupActivatedUsers uids - GetUsers uids -> embedIntra $ getUsers uids - DeleteUser uid -> embedIntra $ deleteUser uid - GetContactList uid -> embedIntra $ getContactList uid - GetRichInfoMultiUser uids -> embedIntra $ getRichInfoMultiUser uids - GetSize tid -> embedIntra $ getSize tid - LookupClients uids -> embedIntra $ lookupClients uids - LookupClientsFull uids -> embedIntra $ lookupClientsFull uids + PutConnectionInternal uc -> embedApp $ putConnectionInternal uc + ReauthUser uid reauth -> embedApp $ reAuthUser uid reauth + LookupActivatedUsers uids -> embedApp $ lookupActivatedUsers uids + GetUsers uids -> embedApp $ getUsers uids + DeleteUser uid -> embedApp $ deleteUser uid + GetContactList uid -> embedApp $ getContactList uid + GetRichInfoMultiUser uids -> embedApp $ getRichInfoMultiUser uids + GetSize tid -> embedApp $ getSize tid + LookupClients uids -> embedApp $ lookupClients uids + LookupClientsFull uids -> embedApp $ lookupClientsFull uids NotifyClientsAboutLegalHoldRequest self other pk -> - embedIntra $ notifyClientsAboutLegalHoldRequest self other pk + embedApp $ notifyClientsAboutLegalHoldRequest self other pk GetLegalHoldAuthToken uid mpwd -> getLegalHoldAuthToken uid mpwd AddLegalHoldClientToUser uid conn pks lpk -> - embedIntra $ addLegalHoldClientToUser uid conn pks lpk + embedApp $ addLegalHoldClientToUser uid conn pks lpk RemoveLegalHoldClientFromUser uid -> - embedIntra $ removeLegalHoldClientFromUser uid + embedApp $ removeLegalHoldClientFromUser uid + GetAccountFeatureConfigClient uid -> + embedApp $ getAccountFeatureConfigClient uid interpretSparAccess :: - Members '[Embed IO, P.Reader Env] r => + Members '[Embed IO, Input Env] r => Sem (SparAccess ': r) a -> Sem r a interpretSparAccess = interpret $ \case - DeleteTeam tid -> embedIntra $ deleteTeam tid + DeleteTeam tid -> embedApp $ deleteTeam tid interpretBotAccess :: - Members '[Embed IO, P.Reader Env] r => + Members '[Embed IO, Input Env] r => Sem (BotAccess ': r) a -> Sem r a interpretBotAccess = interpret $ \case - DeleteBot cid bid -> embedIntra $ deleteBot cid bid + DeleteBot cid bid -> embedApp $ deleteBot cid bid interpretGundeckAccess :: - Members '[Embed IO, P.TinyLog, P.Reader Env] r => + Members '[Embed IO, Input Env] r => Sem (GundeckAccess ': r) a -> Sem r a interpretGundeckAccess = interpret $ \case - Push ps -> embedIntra $ G.push ps + Push ps -> embedApp $ G.push ps + PushSlowly ps -> embedApp $ G.pushSlowly ps diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs index cd08fb32572..b4bf53c6c26 100644 --- a/services/galley/src/Galley/Intra/Federator.hs +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -20,46 +20,44 @@ module Galley.Intra.Federator (interpretFederatorAccess) where import Control.Monad.Except +import Data.Bifunctor import Data.Qualified import Galley.Effects.FederatorAccess (FederatorAccess (..)) import Galley.Env import Galley.Intra.Federator.Types +import Galley.Monad import Imports import Polysemy -import qualified Polysemy.Reader as P +import Polysemy.Input import UnliftIO import Wire.API.Federation.Client import Wire.API.Federation.Error -embedFederationM :: - Members '[Embed IO, P.Reader Env] r => - FederationM a -> - Sem r a -embedFederationM action = do - env <- P.ask - embed $ runFederationM env action - interpretFederatorAccess :: - Members '[Embed IO, P.Reader Env] r => + Members '[Embed IO, Input Env] r => Sem (FederatorAccess ': r) a -> Sem r a interpretFederatorAccess = interpret $ \case - RunFederated dom rpc -> embedFederationM $ runFederated dom rpc - RunFederatedEither dom rpc -> embedFederationM $ runFederatedEither dom rpc - RunFederatedConcurrently rs f -> embedFederationM $ runFederatedConcurrently rs f + RunFederated dom rpc -> embedApp $ runFederated dom rpc + RunFederatedEither dom rpc -> embedApp $ runFederatedEither dom rpc + RunFederatedConcurrently rs f -> embedApp $ runFederatedConcurrently rs f + RunFederatedConcurrentlyEither rs f -> + embedApp $ + runFederatedConcurrentlyEither rs f + IsFederationConfigured -> embedApp $ isJust <$> federatorEndpoint runFederatedEither :: Remote x -> FederatedRPC c a -> - FederationM (Either FederationError a) + App (Either FederationError a) runFederatedEither (tDomain -> remoteDomain) rpc = do env <- ask - liftIO $ runFederationM env (runExceptT (executeFederated remoteDomain rpc)) + liftIO $ runApp env (runExceptT (executeFederated remoteDomain rpc)) runFederated :: Remote x -> FederatedRPC c a -> - FederationM a + App a runFederated dom rpc = runFederatedEither dom rpc >>= either (throwIO . federationErrorToWai) pure @@ -68,7 +66,16 @@ runFederatedConcurrently :: (Foldable f, Functor f) => f (Remote a) -> (Remote [a] -> FederatedRPC c b) -> - FederationM [Remote b] + App [Remote b] runFederatedConcurrently xs rpc = pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> qualifyAs r <$> runFederated r (rpc r) + +runFederatedConcurrentlyEither :: + (Foldable f, Functor f) => + f (Remote a) -> + (Remote [a] -> FederatedRPC c b) -> + App [Either (Remote [a], FederationError) (Remote b)] +runFederatedConcurrentlyEither xs rpc = + pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> + bimap (r,) (qualifyAs r) <$> runFederatedEither r (rpc r) diff --git a/services/galley/src/Galley/Intra/Federator/Types.hs b/services/galley/src/Galley/Intra/Federator/Types.hs index 40c0b892680..7a316f7ce80 100644 --- a/services/galley/src/Galley/Intra/Federator/Types.hs +++ b/services/galley/src/Galley/Intra/Federator/Types.hs @@ -17,42 +17,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Intra.Federator.Types - ( FederatedRPC, - FederationM, - runFederationM, - ) -where +module Galley.Intra.Federator.Types (FederatedRPC) where -import Control.Lens -import Control.Monad.Catch import Control.Monad.Except -import Galley.Env -import Galley.Options -import Imports +import Galley.Monad import Wire.API.Federation.Client import Wire.API.Federation.GRPC.Types type FederatedRPC (c :: Component) = - FederatorClient c (ExceptT FederationClientFailure FederationM) - -newtype FederationM a = FederationM - {unFederationM :: ReaderT Env IO a} - deriving - ( Functor, - Applicative, - Monad, - MonadIO, - MonadReader Env, - MonadUnliftIO, - MonadThrow, - MonadCatch, - MonadMask - ) - -runFederationM :: Env -> FederationM a -> IO a -runFederationM env = flip runReaderT env . unFederationM - -instance HasFederatorConfig FederationM where - federatorEndpoint = view federator - federationDomain = view (options . optSettings . setFederationDomain) + FederatorClient c (ExceptT FederationClientFailure App) diff --git a/services/galley/src/Galley/Intra/Journal.hs b/services/galley/src/Galley/Intra/Journal.hs index f4bf8cd0c77..7cfd6eb8f8f 100644 --- a/services/galley/src/Galley/Intra/Journal.hs +++ b/services/galley/src/Galley/Intra/Journal.hs @@ -29,61 +29,84 @@ import Control.Lens import Data.ByteString.Conversion import qualified Data.Currency as Currency import Data.Id -import Data.Proto import Data.Proto.Id import Data.ProtoLens (defMessage) import Data.Text (pack) +import Data.Time.Clock +import Data.Time.Clock.POSIX import Galley.API.Util -import Galley.App -import qualified Galley.Aws as Aws import Galley.Effects.TeamStore import qualified Galley.Options as Opts import Galley.Types.Teams import Imports hiding (head) import Numeric.Natural import Polysemy +import Polysemy.Input +import qualified Polysemy.TinyLog as P import Proto.TeamEvents (TeamEvent'EventData, TeamEvent'EventType (..)) import qualified Proto.TeamEvents_Fields as T import System.Logger (field, msg, val) -import qualified System.Logger.Class as Log -- [Note: journaling] -- Team journal operations to SQS are a no-op when the service -- is started without journaling arguments teamActivate :: - Member TeamStore r => + Members + '[ Input Opts.Opts, + Input UTCTime, + TeamStore, + P.TinyLog + ] + r => TeamId -> Natural -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> - Galley r () + Sem r () teamActivate tid teamSize cur time = do billingUserIds <- getBillingUserIds tid Nothing journalEvent TeamEvent'TEAM_ACTIVATE tid (Just $ evData teamSize billingUserIds cur) time -teamUpdate :: TeamId -> Natural -> [UserId] -> Galley r () +teamUpdate :: + Members '[TeamStore, Input UTCTime] r => + TeamId -> + Natural -> + [UserId] -> + Sem r () teamUpdate tid teamSize billingUserIds = journalEvent TeamEvent'TEAM_UPDATE tid (Just $ evData teamSize billingUserIds Nothing) Nothing -teamDelete :: TeamId -> Galley r () +teamDelete :: + Members '[TeamStore, Input UTCTime] r => + TeamId -> + Sem r () teamDelete tid = journalEvent TeamEvent'TEAM_DELETE tid Nothing Nothing -teamSuspend :: TeamId -> Galley r () +teamSuspend :: + Members '[TeamStore, Input UTCTime] r => + TeamId -> + Sem r () teamSuspend tid = journalEvent TeamEvent'TEAM_SUSPEND tid Nothing Nothing -journalEvent :: TeamEvent'EventType -> TeamId -> Maybe TeamEvent'EventData -> Maybe TeamCreationTime -> Galley r () -journalEvent typ tid dat tim = - view aEnv >>= \mEnv -> for_ mEnv $ \e -> do - -- writetime is in microseconds in cassandra 3.11 - ts <- maybe now (return . (`div` 1000000) . view tcTime) tim - let ev = - defMessage - & T.eventType .~ typ - & T.teamId .~ toBytes tid - & T.utcTime .~ ts - & T.maybe'eventData .~ dat - Aws.execute e (Aws.enqueue ev) +journalEvent :: + Members '[TeamStore, Input UTCTime] r => + TeamEvent'EventType -> + TeamId -> + Maybe TeamEvent'EventData -> + Maybe TeamCreationTime -> + Sem r () +journalEvent typ tid dat tim = do + -- writetime is in microseconds in cassandra 3.11 + now <- round . utcTimeToPOSIXSeconds <$> input + let ts = maybe now ((`div` 1000000) . view tcTime) tim + ev = + defMessage + & T.eventType .~ typ + & T.teamId .~ toBytes tid + & T.utcTime .~ ts + & T.maybe'eventData .~ dat + enqueueTeamEvent ev ---------------------------------------------------------------------------- -- utils @@ -99,16 +122,23 @@ evData memberCount billingUserIds cur = -- 'getBillingTeamMembers'. This is required only until data is backfilled in the -- 'billing_team_user' table. getBillingUserIds :: - Member TeamStore r => + Members '[Input Opts.Opts, TeamStore, P.TinyLog] r => TeamId -> Maybe TeamMemberList -> - Galley r [UserId] + Sem r [UserId] getBillingUserIds tid maybeMemberList = do - enableIndexedBillingTeamMembers <- view (options . Opts.optSettings . Opts.setEnableIndexedBillingTeamMembers . to (fromMaybe False)) + opts <- input + let enableIndexedBillingTeamMembers = + view + ( Opts.optSettings + . Opts.setEnableIndexedBillingTeamMembers + . to (fromMaybe False) + ) + opts case maybeMemberList of Nothing -> if enableIndexedBillingTeamMembers - then liftSem $ fetchFromDB + then fetchFromDB else do mems <- getTeamMembersForFanout tid handleList enableIndexedBillingTeamMembers mems @@ -117,18 +147,18 @@ getBillingUserIds tid maybeMemberList = do fetchFromDB :: Member TeamStore r => Sem r [UserId] fetchFromDB = getBillingTeamMembers tid - filterFromMembers :: TeamMemberList -> Galley r [UserId] + filterFromMembers :: TeamMemberList -> Sem r [UserId] filterFromMembers list = pure $ map (view userId) $ filter (`hasPermission` SetBilling) (list ^. teamMembers) - handleList :: Member TeamStore r => Bool -> TeamMemberList -> Galley r [UserId] + handleList :: Members '[TeamStore, P.TinyLog] r => Bool -> TeamMemberList -> Sem r [UserId] handleList enableIndexedBillingTeamMembers list = case list ^. teamMemberListType of ListTruncated -> if enableIndexedBillingTeamMembers - then liftSem $ fetchFromDB + then fetchFromDB else do - Log.warn $ + P.warn $ field "team" (toByteString tid) . msg (val "TeamMemberList is incomplete, you may not see all the admin users in team. Please enable the indexedBillingTeamMembers feature.") filterFromMembers list diff --git a/services/galley/src/Galley/Intra/Push/Internal.hs b/services/galley/src/Galley/Intra/Push/Internal.hs index 6c4c7aefbca..7204753a8b9 100644 --- a/services/galley/src/Galley/Intra/Push/Internal.hs +++ b/services/galley/src/Galley/Intra/Push/Internal.hs @@ -22,7 +22,6 @@ module Galley.Intra.Push.Internal where import Bilge hiding (options) import Control.Lens (makeLenses, set, view, (.~)) import Data.Aeson (Object) -import Data.Domain import Data.Id (ConnId, UserId) import Data.Json.Util import Data.List.Extra (chunksOf) @@ -33,6 +32,8 @@ import Data.Range import qualified Data.Set as Set import Galley.Env import Galley.Intra.Util +import Galley.Monad +import Galley.Options import Galley.Types import qualified Galley.Types.Teams as Teams import Gundeck.Types.Push.V2 (RecipientClients (..)) @@ -79,7 +80,7 @@ makeLenses ''PushTo type Push = PushTo UserId -push :: Foldable f => f Push -> IntraM () +push :: Foldable f => f Push -> App () push ps = do let pushes = foldMap (toList . mkPushTo) ps traverse_ pushLocal (nonEmpty pushes) @@ -92,7 +93,7 @@ push ps = do -- | Asynchronously send multiple pushes, aggregating them into as -- few requests as possible, such that no single request targets -- more than 128 recipients. -pushLocal :: NonEmpty (PushTo UserId) -> IntraM () +pushLocal :: NonEmpty (PushTo UserId) -> App () pushLocal ps = do opts <- view options let limit = currentFanoutLimit opts @@ -162,7 +163,15 @@ newPush t u e (r : rr) = Just $ newPush1 t u e (list1 r rr) newPushLocal :: Teams.ListType -> UserId -> PushEvent -> [Recipient] -> Maybe Push newPushLocal lt uid e rr = newPush lt (Just uid) e rr -newConversationEventPush :: Domain -> Event -> [UserId] -> Maybe Push -newConversationEventPush localDomain e users = - let musr = guard (localDomain == qDomain (evtFrom e)) $> qUnqualified (evtFrom e) - in newPush Teams.ListComplete musr (ConvEvent e) (map userRecipient users) +newConversationEventPush :: Event -> Local [UserId] -> Maybe Push +newConversationEventPush e users = + let musr = guard (tDomain users == qDomain (evtFrom e)) $> qUnqualified (evtFrom e) + in newPush Teams.ListComplete musr (ConvEvent e) (map userRecipient (tUnqualified users)) + +pushSlowly :: Foldable f => f Push -> App () +pushSlowly ps = do + mmillis <- view (options . optSettings . setDeleteConvThrottleMillis) + let delay = 1000 * (fromMaybe defDeleteConvThrottleMillis mmillis) + forM_ ps $ \p -> do + push [p] + threadDelay delay diff --git a/services/galley/src/Galley/Intra/Spar.hs b/services/galley/src/Galley/Intra/Spar.hs index ce9f569a60d..73836adee43 100644 --- a/services/galley/src/Galley/Intra/Spar.hs +++ b/services/galley/src/Galley/Intra/Spar.hs @@ -24,11 +24,12 @@ import Bilge import Data.ByteString.Conversion import Data.Id import Galley.Intra.Util +import Galley.Monad import Imports import Network.HTTP.Types.Method -- | Notify Spar that a team is being deleted. -deleteTeam :: TeamId -> IntraM () +deleteTeam :: TeamId -> App () deleteTeam tid = do void . call Spar $ method DELETE diff --git a/services/galley/src/Galley/Intra/Team.hs b/services/galley/src/Galley/Intra/Team.hs index a6b8d96af1a..ad6f0e0ebf4 100644 --- a/services/galley/src/Galley/Intra/Team.hs +++ b/services/galley/src/Galley/Intra/Team.hs @@ -23,12 +23,13 @@ import Brig.Types.Team import Data.ByteString.Conversion import Data.Id import Galley.Intra.Util +import Galley.Monad import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error -getSize :: TeamId -> IntraM TeamSize +getSize :: TeamId -> App TeamSize getSize tid = do r <- call Brig $ diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index 0a08a634e0e..70a0483ebc7 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -27,6 +27,7 @@ module Galley.Intra.User getContactList, chunkify, getRichInfoMultiUser, + getAccountFeatureConfigClient, ) where @@ -35,20 +36,31 @@ import Bilge.RPC import Brig.Types.Connection (Relation (..), UpdateConnectionsInternal (..), UserIds (..)) import qualified Brig.Types.Intra as Brig import Brig.Types.User (User) +import Control.Lens (view, (^.)) import Control.Monad.Catch (throwM) import Data.ByteString.Char8 (pack) import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Conversion import Data.Id +import Data.Proxy import Data.Qualified +import Data.String.Conversions +import Galley.API.Error +import Galley.Env import Galley.Intra.Util +import Galley.Monad import Imports import Network.HTTP.Client (HttpExceptionContent (..)) import qualified Network.HTTP.Client.Internal as Http import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error +import Servant.API ((:<|>) ((:<|>))) +import qualified Servant.Client as Client +import Util.Options +import qualified Wire.API.Routes.Internal.Brig as IAPI import Wire.API.Routes.Internal.Brig.Connection +import Wire.API.Team.Feature import Wire.API.User.RichInfo (RichInfo) -- | Get statuses of all connections between two groups of users (the usual @@ -61,7 +73,7 @@ getConnectionsUnqualified :: [UserId] -> Maybe [UserId] -> Maybe Relation -> - IntraM [ConnectionStatus] + App [ConnectionStatus] getConnectionsUnqualified uFrom uTo rlt = do r <- call Brig $ @@ -84,7 +96,7 @@ getConnections :: [UserId] -> Maybe [Qualified UserId] -> Maybe Relation -> - IntraM [ConnectionStatusV2] + App [ConnectionStatusV2] getConnections [] _ _ = pure [] getConnections uFrom uTo rlt = do r <- @@ -97,7 +109,7 @@ getConnections uFrom uTo rlt = do putConnectionInternal :: UpdateConnectionsInternal -> - IntraM Status + App Status putConnectionInternal updateConn = do response <- call Brig $ @@ -109,7 +121,7 @@ putConnectionInternal updateConn = do deleteBot :: ConvId -> BotId -> - IntraM () + App () deleteBot cid bot = do void $ call Brig $ @@ -124,7 +136,7 @@ deleteBot cid bot = do reAuthUser :: UserId -> Brig.ReAuthUser -> - IntraM Bool + App Bool reAuthUser uid auth = do let req = method GET @@ -143,7 +155,7 @@ check allowed r = } -- | Calls 'Brig.API.listActivatedAccountsH'. -lookupActivatedUsers :: [UserId] -> IntraM [User] +lookupActivatedUsers :: [UserId] -> App [User] lookupActivatedUsers = chunkify $ \uids -> do let users = BSC.intercalate "," $ toByteString' <$> uids r <- @@ -169,7 +181,7 @@ chunkify doChunk keys = mconcat <$> (doChunk `mapM` chunks keys) chunks uids = case splitAt maxSize uids of (h, t) -> h : chunks t -- | Calls 'Brig.API.listActivatedAccountsH'. -getUsers :: [UserId] -> IntraM [Brig.UserAccount] +getUsers :: [UserId] -> App [Brig.UserAccount] getUsers = chunkify $ \uids -> do resp <- call Brig $ @@ -180,7 +192,7 @@ getUsers = chunkify $ \uids -> do pure . fromMaybe [] . responseJsonMaybe $ resp -- | Calls 'Brig.API.deleteUserNoVerifyH'. -deleteUser :: UserId -> IntraM () +deleteUser :: UserId -> App () deleteUser uid = do void $ call Brig $ @@ -189,7 +201,7 @@ deleteUser uid = do . expect2xx -- | Calls 'Brig.API.getContactListH'. -getContactList :: UserId -> IntraM [UserId] +getContactList :: UserId -> App [UserId] getContactList uid = do r <- call Brig $ @@ -199,7 +211,7 @@ getContactList uid = do cUsers <$> parseResponse (mkError status502 "server-error") r -- | Calls 'Brig.API.Internal.getRichInfoMultiH' -getRichInfoMultiUser :: [UserId] -> IntraM [(UserId, RichInfo)] +getRichInfoMultiUser :: [UserId] -> App [(UserId, RichInfo)] getRichInfoMultiUser = chunkify $ \uids -> do resp <- call Brig $ @@ -208,3 +220,30 @@ getRichInfoMultiUser = chunkify $ \uids -> do . queryItem "ids" (toByteString' (List uids)) . expect2xx parseResponse (mkError status502 "server-error") resp + +getAccountFeatureConfigClient :: HasCallStack => UserId -> App TeamFeatureStatusNoConfig +getAccountFeatureConfigClient uid = + runHereClientM (getAccountFeatureConfigClientM uid) + >>= handleResp + where + handleResp :: + Either Client.ClientError TeamFeatureStatusNoConfig -> + App TeamFeatureStatusNoConfig + handleResp (Right cfg) = pure cfg + handleResp (Left errmsg) = throwM . internalErrorWithDescription . cs . show $ errmsg + +getAccountFeatureConfigClientM :: + UserId -> Client.ClientM TeamFeatureStatusNoConfig +( _ + :<|> getAccountFeatureConfigClientM + :<|> _ + :<|> _ + ) = Client.client (Proxy @IAPI.API) + +runHereClientM :: HasCallStack => Client.ClientM a -> App (Either Client.ClientError a) +runHereClientM action = do + mgr <- view manager + brigep <- view brig + let env = Client.mkClientEnv mgr baseurl + baseurl = Client.BaseUrl Client.Http (cs $ brigep ^. epHost) (fromIntegral $ brigep ^. epPort) "" + liftIO $ Client.runClientM action env diff --git a/services/galley/src/Galley/Intra/Util.hs b/services/galley/src/Galley/Intra/Util.hs index 203c6ab3901..17c83c5b0a8 100644 --- a/services/galley/src/Galley/Intra/Util.hs +++ b/services/galley/src/Galley/Intra/Util.hs @@ -19,8 +19,6 @@ module Galley.Intra.Util ( IntraComponent (..), - IntraM, - embedIntra, call, asyncCall, ) @@ -29,8 +27,7 @@ where import Bilge hiding (getHeader, options, statusCode) import Bilge.RPC import Bilge.Retry -import Cassandra (MonadClient (..), runClient) -import Control.Lens (locally, view, (^.)) +import Control.Lens (view, (^.)) import Control.Monad.Catch import Control.Retry import qualified Data.ByteString.Lazy as LB @@ -38,11 +35,10 @@ import Data.Misc (portNumber) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import Galley.Env +import Galley.Monad import Galley.Options import Imports hiding (log) import Network.HTTP.Types -import Polysemy -import qualified Polysemy.Reader as P import System.Logger import qualified System.Logger.Class as LC import Util.Options @@ -74,53 +70,17 @@ componentRetryPolicy Brig = x1 componentRetryPolicy Spar = x1 componentRetryPolicy Gundeck = x3 -embedIntra :: - Members '[Embed IO, P.Reader Env] r => - IntraM a -> - Sem r a -embedIntra action = do - env <- P.ask - embed $ runHttpT (env ^. manager) (runReaderT (unIntraM action) env) - -newtype IntraM a = IntraM {unIntraM :: ReaderT Env Http a} - deriving - ( Functor, - Applicative, - Monad, - MonadIO, - MonadHttp, - MonadThrow, - MonadCatch, - MonadMask, - MonadReader Env, - MonadUnliftIO - ) - -instance HasRequestId IntraM where - getRequestId = IntraM $ view reqId - -instance MonadClient IntraM where - liftClient m = do - cs <- view cstate - liftIO $ runClient cs m - localState f = locally cstate f - -instance LC.MonadLogger IntraM where - log lvl m = do - env <- ask - log (env ^. applog) lvl (reqIdMsg (env ^. reqId) . m) - call :: IntraComponent -> (Request -> Request) -> - IntraM (Response (Maybe LB.ByteString)) + App (Response (Maybe LB.ByteString)) call comp r = do o <- view options let r0 = componentRequest comp o let n = LT.pack (componentName comp) recovering (componentRetryPolicy comp) rpcHandlers (const (rpc n (r . r0))) -asyncCall :: IntraComponent -> (Request -> Request) -> IntraM () +asyncCall :: IntraComponent -> (Request -> Request) -> App () asyncCall comp req = void $ do let n = LT.pack (componentName comp) forkIO $ catches (void (call comp req)) (handlers n) diff --git a/services/galley/src/Galley/Monad.hs b/services/galley/src/Galley/Monad.hs new file mode 100644 index 00000000000..fe8a19eb9a6 --- /dev/null +++ b/services/galley/src/Galley/Monad.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- 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.Monad where + +import Bilge.IO hiding (options) +import Bilge.RPC +import Cassandra +import Control.Lens +import Control.Monad.Catch +import Control.Monad.Except +import Galley.Env +import Galley.Options +import Imports hiding (log) +import Polysemy +import Polysemy.Input +import System.Logger +import qualified System.Logger.Class as LC +import Wire.API.Federation.Client + +newtype App a = App {unApp :: ReaderT Env IO a} + deriving + ( Functor, + Applicative, + Monad, + MonadCatch, + MonadIO, + MonadMask, + MonadReader Env, + MonadThrow, + MonadUnliftIO + ) + +runApp :: Env -> App a -> IO a +runApp env = flip runReaderT env . unApp + +instance HasFederatorConfig App where + federatorEndpoint = view federator + federationDomain = view (options . optSettings . setFederationDomain) + +instance HasRequestId App where + getRequestId = App $ view reqId + +instance MonadHttp App where + handleRequestWithCont req h = do + m <- view manager + liftIO $ withResponse req m h + +instance MonadClient App where + liftClient m = do + cs <- view cstate + liftIO $ runClient cs m + localState f = locally cstate f + +instance LC.MonadLogger App where + log lvl m = do + env <- ask + log (env ^. applog) lvl (reqIdMsg (env ^. reqId) . m) + +embedApp :: + Members '[Embed IO, Input Env] r => + App a -> + Sem r a +embedApp action = do + env <- input + embed $ runApp env action diff --git a/services/galley/src/Galley/Queue.hs b/services/galley/src/Galley/Queue.hs index f143dadae73..96534fc84bd 100644 --- a/services/galley/src/Galley/Queue.hs +++ b/services/galley/src/Galley/Queue.hs @@ -23,12 +23,15 @@ module Galley.Queue tryPush, pop, len, + interpretQueue, ) where import qualified Control.Concurrent.STM as Stm +import qualified Galley.Effects.Queue as E import Imports import Numeric.Natural (Natural) +import Polysemy data Queue a = Queue { _len :: Stm.TVar Word, @@ -53,3 +56,12 @@ pop q = liftIO . atomically $ do len :: MonadIO m => Queue a -> m Word len q = liftIO $ Stm.readTVarIO (_len q) + +interpretQueue :: + Member (Embed IO) r => + Queue a -> + Sem (E.Queue a ': r) x -> + Sem r x +interpretQueue q = interpret $ \case + E.TryPush a -> embed @IO $ tryPush q a + E.Pop -> embed @IO $ pop q diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index a6e2e751531..907bd8c7cbd 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -27,6 +27,7 @@ import qualified Control.Concurrent.Async as Async import Control.Exception (finally) import Control.Lens (view, (^.)) import qualified Data.Aeson as Aeson +import Data.Domain import qualified Data.Metrics.Middleware as M import Data.Metrics.Servant (servantPlusWAIPrometheusMiddleware) import Data.Misc (portNumber) @@ -38,20 +39,17 @@ import qualified Galley.API.Internal as Internal import Galley.App import qualified Galley.App as App import Galley.Cassandra -import Galley.Options (Opts, optGalley) +import Galley.Monad +import Galley.Options import qualified Galley.Queue as Q import Imports import qualified Network.HTTP.Media.RenderHeader as HTTPMedia import qualified Network.HTTP.Types as HTTP -import Network.Wai (Application) import qualified Network.Wai.Middleware.Gunzip as GZip import qualified Network.Wai.Middleware.Gzip as GZip import Network.Wai.Utilities.Server -import Servant (Context ((:.)), Proxy (Proxy)) -import Servant.API ((:<|>) ((:<|>))) -import qualified Servant.API as Servant -import Servant.API.Generic (ToServantApi, genericApi) -import qualified Servant.Server as Servant +import Servant hiding (route) +import Servant.API.Generic (ToServantApi) import qualified System.Logger as Log import Util.Options import qualified Wire.API.Federation.API.Galley as FederationGalley @@ -68,8 +66,8 @@ run o = do (portNumber $ fromIntegral $ o ^. optGalley . epPort) l (e ^. monitor) - deleteQueueThread <- Async.async $ evalGalley e Internal.deleteLoop - refreshMetricsThread <- Async.async $ evalGalley e refreshMetrics + deleteQueueThread <- Async.async $ runApp e Internal.deleteLoop + refreshMetricsThread <- Async.async $ runApp e refreshMetrics runSettingsWithShutdown s app 5 `finally` do Async.cancel deleteQueueThread Async.cancel refreshMetricsThread @@ -100,22 +98,39 @@ mkApp o = do servantApp e r = Servant.serveWithContext (Proxy @CombinedAPI) - (customFormatters :. Servant.EmptyContext) - ( Servant.hoistServer (Proxy @GalleyAPI.ServantAPI) (toServantHandler e) API.servantSitemap - :<|> Servant.hoistServer (Proxy @Internal.ServantAPI) (toServantHandler e) Internal.servantSitemap - :<|> Servant.hoistServer (genericApi (Proxy @FederationGalley.Api)) (toServantHandler e) federationSitemap + ( view (options . optSettings . setFederationDomain) e + :. customFormatters + :. Servant.EmptyContext + ) + ( hoistServer' @GalleyAPI.ServantAPI (toServantHandler e) API.servantSitemap + :<|> hoistServer' @Internal.ServantAPI (toServantHandler e) Internal.servantSitemap + :<|> hoistServer' @(ToServantApi FederationGalley.Api) (toServantHandler e) federationSitemap :<|> Servant.Tagged (app e) ) r +-- Servant needs a context type argument here that contains *at least* the +-- context types required by all the HasServer instances. In reality, this should +-- not be necessary, because the contexts are only used by the @route@ functions, +-- but unfortunately the 'hoistServerWithContext' function is also part of the +-- 'HasServer' typeclass, even though it cannot possibly make use of its @context@ +-- type argument. +hoistServer' :: + forall api m n. + HasServer api '[Domain] => + (forall x. m x -> n x) -> + ServerT api m -> + ServerT api n +hoistServer' = hoistServerWithContext (Proxy @api) (Proxy @'[Domain]) + customFormatters :: Servant.ErrorFormatters customFormatters = - Servant.defaultErrorFormatters - { Servant.bodyParserErrorFormatter = bodyParserErrorFormatter + defaultErrorFormatters + { bodyParserErrorFormatter = bodyParserErrorFormatter' } -bodyParserErrorFormatter :: Servant.ErrorFormatter -bodyParserErrorFormatter _ _ errMsg = +bodyParserErrorFormatter' :: Servant.ErrorFormatter +bodyParserErrorFormatter' _ _ errMsg = Servant.ServerError { Servant.errHTTPCode = HTTP.statusCode HTTP.status400, Servant.errReasonPhrase = cs $ HTTP.statusMessage HTTP.status400, @@ -131,8 +146,8 @@ bodyParserErrorFormatter _ _ errMsg = type CombinedAPI = GalleyAPI.ServantAPI :<|> Internal.ServantAPI :<|> ToServantApi FederationGalley.Api :<|> Servant.Raw -refreshMetrics :: Galley r () -refreshMetrics = liftGalley0 $ do +refreshMetrics :: App () +refreshMetrics = do m <- view monitor q <- view deleteQueue Internal.safeForever "refreshMetrics" $ do diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 3bdb964a400..40c5be5010f 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -2264,8 +2264,8 @@ testBulkGetQualifiedConvs = do let expectedFound = sortOn cnvQualifiedId - $ maybeToList (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainA mockConversationA)) - <> maybeToList (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainB mockConversationB)) + $ pure (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainA mockConversationA)) + <> pure (remoteConversationView lAlice defMemberStatus (toRemoteUnsafe remoteDomainB mockConversationB)) <> [localConv] actualFound = sortOn cnvQualifiedId $ crFound convs assertEqual "found conversations" expectedFound actualFound diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 8a15a7a255c..43985abb00b 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -51,7 +51,7 @@ import qualified Data.UUID as UUID import qualified Data.UUID.Util as UUID import qualified Data.UUID.V1 as UUID import qualified Data.Vector as V -import qualified Galley.App as Galley +import qualified Galley.Env as Galley import Galley.Options (optSettings, setEnableIndexedBillingTeamMembers, setFeatureFlags, setMaxConvSize, setMaxFanoutSize) import Galley.Types hiding (EventData (..), EventType (..), MemberUpdate (..)) import Galley.Types.Conversations.Roles diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index b5d4cd24deb..7ccefd4ea6a 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -64,10 +64,10 @@ import qualified Data.Set as Set import Data.String.Conversions (LBS, cs) import Data.Text.Encoding (encodeUtf8) import qualified Data.Time.Clock as Time -import qualified Galley.App as Galley import Galley.Cassandra.Client +import Galley.Cassandra.LegalHold import qualified Galley.Cassandra.LegalHold as LegalHoldData -import Galley.External.LegalHoldService (validateServiceKey) +import qualified Galley.Env as Galley import Galley.Options (optSettings, setFeatureFlags) import qualified Galley.Types.Clients as Clients import Galley.Types.Teams diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index f7ce8108228..69059bff248 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -58,10 +58,10 @@ import Data.Range import qualified Data.Set as Set import Data.String.Conversions (LBS, cs) import Data.Text.Encoding (encodeUtf8) -import qualified Galley.App as Galley import Galley.Cassandra.Client +import Galley.Cassandra.LegalHold import qualified Galley.Cassandra.LegalHold as LegalHoldData -import Galley.External.LegalHoldService (validateServiceKey) +import qualified Galley.Env as Galley import Galley.Options (optSettings, setFeatureFlags) import qualified Galley.Types.Clients as Clients import Galley.Types.Teams diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 2f7c43f6814..42a18927fb9 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -128,7 +128,7 @@ import Wire.API.User.Identity (mkSimpleSampleUref) ------------------------------------------------------------------------------- -- API Operations --- | A class for monads with access to a Galley r instance +-- | A class for monads with access to a Sem r instance class HasGalley m where viewGalley :: m GalleyR viewGalleyOpts :: m Opts.Opts