diff --git a/changelog.d/5-internal/galley-polysemy b/changelog.d/5-internal/galley-polysemy new file mode 100644 index 00000000000..528c615de11 --- /dev/null +++ b/changelog.d/5-internal/galley-polysemy @@ -0,0 +1 @@ +Turn `Galley` into a polysemy monad stack. diff --git a/libs/bilge/src/Bilge/RPC.hs b/libs/bilge/src/Bilge/RPC.hs index 50d8a6507b4..04cb232ec31 100644 --- a/libs/bilge/src/Bilge/RPC.hs +++ b/libs/bilge/src/Bilge/RPC.hs @@ -33,7 +33,7 @@ import Bilge.IO import Bilge.Request import Bilge.Response import Control.Error hiding (err) -import Control.Monad.Catch (MonadThrow (..)) +import Control.Monad.Catch (MonadCatch, MonadThrow (..), try) import Control.Monad.Except import Data.Aeson (FromJSON, eitherDecode') import Data.CaseInsensitive (original) @@ -41,7 +41,6 @@ import Data.Text.Lazy (pack) import Imports hiding (log) import qualified Network.HTTP.Client as HTTP import System.Logger.Class -import UnliftIO.Exception (try) class HasRequestId m where getRequestId :: m RequestId @@ -69,7 +68,7 @@ instance Show RPCException where . showString "}" rpc :: - (MonadUnliftIO m, MonadHttp m, HasRequestId m, MonadLogger m, MonadThrow m) => + (MonadIO m, MonadCatch m, MonadHttp m, HasRequestId m) => LText -> (Request -> Request) -> m (Response (Maybe LByteString)) @@ -81,7 +80,7 @@ rpc sys = rpc' sys empty -- Note: 'syncIO' is wrapped around the IO action performing the request -- and any exceptions caught are re-thrown in an 'RPCException'. rpc' :: - (MonadUnliftIO m, MonadHttp m, HasRequestId m, MonadThrow m) => + (MonadIO m, MonadCatch m, MonadHttp m, HasRequestId m) => -- | A label for the remote system in case of 'RPCException's. LText -> Request -> diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index e2181ca099a..8986d39e897 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -170,7 +170,7 @@ compile routes = Route.prepare (Route.renderer predicateError >> routes) messageStr (Just t) = char7 ':' <> char7 ' ' <> byteString t messageStr Nothing = mempty -route :: (MonadCatch m, MonadIO m) => Tree (App m) -> Request -> Continue IO -> m ResponseReceived +route :: MonadIO m => Tree (App m) -> Request -> Continue IO -> m ResponseReceived route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (liftIO . k) where noEndpoint = Wai.mkError status404 "no-endpoint" "The requested endpoint does not exist" diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 0c6dbd6d86c..81c99088c3a 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: 1daf2eec8d6d9666168a442a3c2856c2d453361e3bbffcc4a17c55d8bbf914f4 +-- hash: 8bf007e90cc28a7b92252e0fccfb998d850e30df040205e1bc7316b9008a0c9f name: galley version: 0.83.0 @@ -55,6 +55,8 @@ library Galley.Data.TeamFeatures Galley.Data.TeamNotifications Galley.Data.Types + Galley.Effects + Galley.Effects.FireAndForget Galley.External Galley.External.LegalHoldService Galley.Intra.Client @@ -121,6 +123,7 @@ library , mtl >=2.2 , optparse-applicative >=0.10 , pem + , polysemy , proto-lens >=0.2 , protobuf >=0.2 , raw-strings-qq >=1.0 @@ -146,7 +149,7 @@ library , time >=1.4 , tinylog >=0.10 , tls >=1.3.10 - , transformers >=0.3 + , transformers , types-common >=0.16 , types-common-journal >=0.1 , unliftio >=0.2 @@ -186,6 +189,7 @@ executable galley , servant-client , ssl-util , tagged + , transformers , types-common , wire-api , wire-api-federation @@ -283,6 +287,7 @@ executable galley-integration , time , tinylog , tls >=1.3.8 + , transformers , types-common , types-common-journal , unliftio @@ -334,6 +339,7 @@ executable galley-migrate-data , text , time , tinylog + , transformers , types-common , unliftio , wire-api @@ -400,6 +406,7 @@ executable galley-schema , tagged , text , tinylog + , transformers , wire-api , wire-api-federation if flag(static) @@ -444,6 +451,7 @@ test-suite galley-types-tests , tasty-hspec , tasty-hunit , tasty-quickcheck + , transformers , types-common , wai , wai-predicates diff --git a/services/galley/package.yaml b/services/galley/package.yaml index ead7824b388..03a557c84e7 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -22,6 +22,7 @@ dependencies: - tagged - servant-client - saml2-web-sso >=0.18 +- transformers library: source-dirs: src @@ -64,6 +65,7 @@ library: - mtl >=2.2 - optparse-applicative >=0.10 - pem + - polysemy - protobuf >=0.2 - proto-lens >=0.2 - QuickCheck >=2.14 @@ -85,7 +87,6 @@ library: - time >=1.4 - tinylog >=0.10 - tls >=1.3.10 - - transformers >=0.3 - types-common >=0.16 - types-common-journal >=0.1 - unliftio >=0.2 diff --git a/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index 6e964ad9826..122c06859f1 100644 --- a/services/galley/src/Galley/API.hs +++ b/services/galley/src/Galley/API.hs @@ -24,10 +24,10 @@ 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) +import Galley.App (Galley, GalleyEffects) import Network.Wai.Routing (Routes) -sitemap :: Routes Doc.ApiBuilder Galley () +sitemap :: Routes Doc.ApiBuilder (Galley GalleyEffects) () sitemap = do Public.sitemap Public.apiDocs diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 526c7530517..e9c90bf5a29 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -26,6 +26,7 @@ import Control.Lens (view) import Data.Id import Galley.App import qualified Galley.Data as Data +import Galley.Effects import qualified Galley.Intra.Client as Intra import Galley.Options import Galley.Types.Clients (clientIds, fromUserClients) @@ -34,11 +35,11 @@ import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities -getClientsH :: UserId -> Galley Response +getClientsH :: Member BrigAccess r => UserId -> Galley r Response getClientsH usr = do json <$> getClients usr -getClients :: UserId -> Galley [ClientId] +getClients :: Member BrigAccess r => UserId -> Galley r [ClientId] getClients usr = do isInternal <- view $ options . optSettings . setIntraListing clts <- @@ -47,12 +48,12 @@ getClients usr = do else Data.lookupClients [usr] return $ clientIds usr clts -addClientH :: UserId ::: ClientId -> Galley Response +addClientH :: UserId ::: ClientId -> Galley r Response addClientH (usr ::: clt) = do Data.updateClient True usr clt return empty -rmClientH :: UserId ::: ClientId -> Galley Response +rmClientH :: UserId ::: ClientId -> Galley r Response rmClientH (usr ::: clt) = do Data.updateClient False usr clt return empty diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index a23e127b57e..182deff3267 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -40,6 +40,7 @@ import Galley.API.One2One import Galley.API.Util import Galley.App import qualified Galley.Data as Data +import Galley.Effects import Galley.Intra.Push import Galley.Types import Galley.Types.Teams (ListType (..), Perm (..), TeamBinding (Binding), notTeamMember) @@ -64,10 +65,11 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotIm -- -- See Note [managed conversations]. createGroupConversation :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => UserId -> ConnId -> Public.NewConvUnmanaged -> - Galley ConversationResponse + Galley r ConversationResponse createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = case newConvTeam body of Nothing -> createRegularGroupConv user conn wrapped @@ -75,18 +77,29 @@ createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = -- | An internal endpoint for creating managed group conversations. Will -- throw an error for everything else. -internalCreateManagedConversationH :: UserId ::: ConnId ::: JsonRequest NewConvManaged -> Galley Response +internalCreateManagedConversationH :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId ::: ConnId ::: JsonRequest NewConvManaged -> + Galley r Response internalCreateManagedConversationH (zusr ::: zcon ::: req) = do newConv <- fromJsonBody req handleConversationResponse <$> internalCreateManagedConversation zusr zcon newConv -internalCreateManagedConversation :: UserId -> ConnId -> NewConvManaged -> Galley ConversationResponse +internalCreateManagedConversation :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + NewConvManaged -> + Galley r ConversationResponse internalCreateManagedConversation zusr zcon (NewConvManaged body) = do case newConvTeam body of Nothing -> throwM internalError Just tinfo -> createTeamGroupConv zusr zcon tinfo body -ensureNoLegalholdConflicts :: [Remote UserId] -> [UserId] -> Galley () +ensureNoLegalholdConflicts :: + [Remote UserId] -> + [UserId] -> + Galley r () ensureNoLegalholdConflicts remotes locals = do let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes whenM (anyLegalholdActivated locals) $ @@ -94,7 +107,12 @@ ensureNoLegalholdConflicts remotes locals = do throwErrorDescriptionType @MissingLegalholdConsent -- | A helper for creating a regular (non-team) group conversation. -createRegularGroupConv :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse +createRegularGroupConv :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + NewConvUnmanaged -> + Galley r ConversationResponse createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do lusr <- qualifyLocal zusr name <- rangeCheckedMaybe (newConvName body) @@ -118,7 +136,13 @@ createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do -- | A helper for creating a team group conversation, used by the endpoint -- handlers above. Only supports unmanaged conversations. -createTeamGroupConv :: UserId -> ConnId -> Public.ConvTeamInfo -> Public.NewConv -> Galley ConversationResponse +createTeamGroupConv :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.ConvTeamInfo -> + Public.NewConv -> + Galley r ConversationResponse createTeamGroupConv zusr zcon tinfo body = do lusr <- qualifyLocal zusr name <- rangeCheckedMaybe (newConvName body) @@ -166,7 +190,7 @@ createTeamGroupConv zusr zcon tinfo body = do ---------------------------------------------------------------------------- -- Other kinds of conversations -createSelfConversation :: UserId -> Galley ConversationResponse +createSelfConversation :: UserId -> Galley r ConversationResponse createSelfConversation zusr = do lusr <- qualifyLocal zusr c <- Data.conversation (Id . toUUID $ zusr) @@ -176,7 +200,12 @@ createSelfConversation zusr = do c <- Data.createSelfConversation lusr Nothing conversationCreated zusr c -createOne2OneConversation :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse +createOne2OneConversation :: + Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + UserId -> + ConnId -> + NewConvUnmanaged -> + Galley r ConversationResponse createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do lusr <- qualifyLocal zusr let allUsers = newConvMembers lusr j @@ -216,12 +245,13 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do Nothing -> throwM teamNotFound createLegacyOne2OneConversationUnchecked :: + Members '[FederatorAccess, GundeckAccess] r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> Maybe TeamId -> Local UserId -> - Galley ConversationResponse + Galley r ConversationResponse createLegacyOne2OneConversationUnchecked self zcon name mtid other = do lcnv <- localOne2OneConvId self other mc <- Data.conversation (tUnqualified lcnv) @@ -234,12 +264,13 @@ createLegacyOne2OneConversationUnchecked self zcon name mtid other = do conversationCreated (tUnqualified self) c createOne2OneConversationUnchecked :: + Members '[FederatorAccess, GundeckAccess] r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley ConversationResponse + Galley r ConversationResponse createOne2OneConversationUnchecked self zcon name mtid other = do let create = foldQualified @@ -249,13 +280,14 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId (qUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: + Members '[FederatorAccess, GundeckAccess] r => Local ConvId -> Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley ConversationResponse + Galley r ConversationResponse createOne2OneConversationLocally lcnv self zcon name mtid other = do mc <- Data.conversation (tUnqualified lcnv) case mc of @@ -272,15 +304,16 @@ createOne2OneConversationRemotely :: Maybe (Range 1 256 Text) -> Maybe TeamId -> Qualified UserId -> - Galley ConversationResponse + Galley r ConversationResponse createOne2OneConversationRemotely _ _ _ _ _ _ = throwM federationNotImplemented createConnectConversation :: + Members '[FederatorAccess, GundeckAccess] r => UserId -> Maybe ConnId -> Connect -> - Galley ConversationResponse + Galley r ConversationResponse createConnectConversation usr conn j = do lusr <- qualifyLocal usr foldQualified @@ -293,16 +326,17 @@ createConnectConversationWithRemote :: Local UserId -> Maybe ConnId -> Remote UserId -> - Galley ConversationResponse + Galley r ConversationResponse createConnectConversationWithRemote _ _ _ = throwM federationNotImplemented createLegacyConnectConversation :: + Members '[FederatorAccess, GundeckAccess] r => Local UserId -> Maybe ConnId -> Local UserId -> Connect -> - Galley ConversationResponse + Galley r ConversationResponse createLegacyConnectConversation lusr conn lrecipient j = do (x, y) <- toUUIDs (tUnqualified lusr) (tUnqualified lrecipient) n <- rangeCheckedMaybe (cName j) @@ -367,10 +401,10 @@ createLegacyConnectConversation lusr conn lrecipient j = do ------------------------------------------------------------------------------- -- Helpers -conversationCreated :: UserId -> Data.Conversation -> Galley ConversationResponse +conversationCreated :: UserId -> Data.Conversation -> Galley r ConversationResponse conversationCreated usr cnv = Created <$> conversationView usr cnv -conversationExisted :: UserId -> Data.Conversation -> Galley ConversationResponse +conversationExisted :: UserId -> Data.Conversation -> Galley r ConversationResponse conversationExisted usr cnv = Existed <$> conversationView usr cnv handleConversationResponse :: ConversationResponse -> Response @@ -378,7 +412,13 @@ handleConversationResponse = \case Created cnv -> json cnv & setStatus status201 . location (qUnqualified . cnvQualifiedId $ cnv) Existed cnv -> json cnv & setStatus status200 . location (qUnqualified . cnvQualifiedId $ cnv) -notifyCreatedConversation :: Maybe UTCTime -> UserId -> Maybe ConnId -> Data.Conversation -> Galley () +notifyCreatedConversation :: + Members '[FederatorAccess, GundeckAccess] r => + Maybe UTCTime -> + UserId -> + Maybe ConnId -> + Data.Conversation -> + Galley r () notifyCreatedConversation dtime usr conn c = do localDomain <- viewFederationDomain now <- maybe (liftIO getCurrentTime) pure dtime @@ -404,12 +444,12 @@ notifyCreatedConversation dtime usr conn c = do & pushConn .~ conn & pushRoute .~ route -localOne2OneConvId :: Local UserId -> Local UserId -> Galley (Local ConvId) +localOne2OneConvId :: Local UserId -> Local UserId -> Galley r (Local ConvId) localOne2OneConvId self other = do (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) pure . qualifyAs self $ Data.localOne2OneConvId x y -toUUIDs :: UserId -> UserId -> Galley (U.UUID U.V4, U.UUID U.V4) +toUUIDs :: UserId -> UserId -> Galley r (U.UUID U.V4, U.UUID U.V4) toUUIDs a b = do a' <- U.fromUUID (toUUID a) & ifNothing invalidUUID4 b' <- U.fromUUID (toUUID b) & ifNothing invalidUUID4 @@ -428,6 +468,6 @@ newConvMembers loc body = UserList (newConvUsers body) [] <> toUserList loc (newConvQualifiedUsers body) -ensureOne :: [a] -> Galley a +ensureOne :: [a] -> Galley r a ensureOne [x] = pure x ensureOne _ = throwM (invalidRange "One-to-one conversations can only have a single invited member") diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index ab75da493ab..fa98803c799 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -38,11 +38,11 @@ import qualified Wire.API.CustomBackend as Public -- PUBLIC --------------------------------------------------------------------- -getCustomBackendByDomainH :: Domain ::: JSON -> Galley Response +getCustomBackendByDomainH :: Domain ::: JSON -> Galley r Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain -getCustomBackendByDomain :: Domain -> Galley Public.CustomBackend +getCustomBackendByDomain :: Domain -> Galley r Public.CustomBackend getCustomBackendByDomain domain = Data.getCustomBackend domain >>= \case Nothing -> throwM (customBackendNotFound domain) @@ -50,14 +50,14 @@ getCustomBackendByDomain domain = -- INTERNAL ------------------------------------------------------------------- -internalPutCustomBackendByDomainH :: Domain ::: JsonRequest CustomBackend -> Galley Response +internalPutCustomBackendByDomainH :: Domain ::: JsonRequest CustomBackend -> Galley r Response internalPutCustomBackendByDomainH (domain ::: req) = do customBackend <- fromJsonBody req -- simple enough to not need a separate function Data.setCustomBackend domain customBackend pure (empty & setStatus status201) -internalDeleteCustomBackendByDomainH :: Domain ::: JSON -> Galley Response +internalDeleteCustomBackendByDomainH :: Domain ::: JSON -> Galley r Response internalDeleteCustomBackendByDomainH (domain ::: _) = do Data.deleteCustomBackend domain pure (empty & setStatus status200) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index b26697a00bb..5889cb12a1a 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -38,8 +38,9 @@ import Galley.API.Message (MessageMetadata (..), UserType (..), postQualifiedOtr import Galley.API.Update (notifyConversationMetadataUpdate) import qualified Galley.API.Update as API import Galley.API.Util -import Galley.App (Galley) +import Galley.App import qualified Galley.Data as Data +import Galley.Effects import Galley.Intra.User (getConnections) import Galley.Types.Conversations.Members (LocalMember (..), defMemberStatus) import Imports @@ -47,7 +48,6 @@ import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) import qualified System.Logger.Class as Log -import UnliftIO.Async (pooledForConcurrentlyN_) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember (..)) @@ -72,7 +72,7 @@ import Wire.API.Routes.Public.Galley.Responses (RemoveFromConversationError (..) import Wire.API.ServantProto (FromProto (..)) import Wire.API.User.Client (userClientMap) -federationSitemap :: ServerT (ToServantApi FederationAPIGalley.Api) Galley +federationSitemap :: ServerT (ToServantApi FederationAPIGalley.Api) (Galley GalleyEffects) federationSitemap = genericServerT $ FederationAPIGalley.Api @@ -85,7 +85,11 @@ federationSitemap = FederationAPIGalley.onUserDeleted = onUserDeleted } -onConversationCreated :: Domain -> NewRemoteConversation ConvId -> Galley () +onConversationCreated :: + Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Domain -> + NewRemoteConversation ConvId -> + Galley r () onConversationCreated domain rc = do let qrc = fmap (toRemoteUnsafe domain) rc loc <- qualifyLocal () @@ -119,7 +123,10 @@ onConversationCreated domain rc = do (EdConversation c) pushConversationEvent Nothing event [qUnqualified . Public.memId $ mem] [] -getConversations :: Domain -> GetConversationsRequest -> Galley GetConversationsResponse +getConversations :: + Domain -> + GetConversationsRequest -> + Galley r GetConversationsResponse getConversations domain (GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid localDomain <- viewFederationDomain @@ -132,7 +139,11 @@ 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 :: Domain -> ConversationUpdate -> Galley () +onConversationUpdated :: + Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Domain -> + ConversationUpdate -> + Galley r () onConversationUpdated requestingDomain cu = do localDomain <- viewFederationDomain loc <- qualifyLocal () @@ -191,7 +202,12 @@ onConversationUpdated requestingDomain cu = do -- FUTUREWORK: support bots? pushConversationEvent Nothing event targets [] -addLocalUsersToRemoteConv :: Remote ConvId -> Qualified UserId -> [UserId] -> Galley (Set UserId) +addLocalUsersToRemoteConv :: + Member BrigAccess r => + Remote ConvId -> + Qualified UserId -> + [UserId] -> + Galley r (Set UserId) addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do connStatus <- getConnections localUsers (Just [qAdder]) (Just Accepted) let localUserIdsSet = Set.fromList localUsers @@ -214,9 +230,10 @@ addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do -- FUTUREWORK: actually return errors as part of the response instead of throwing leaveConversation :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => Domain -> LeaveConversationRequest -> - Galley LeaveConversationResponse + Galley r LeaveConversationResponse leaveConversation requestingDomain lc = do let leaver = Qualified (lcLeaver lc) requestingDomain lcnv <- qualifyLocal (lcConvId lc) @@ -233,7 +250,11 @@ leaveConversation requestingDomain lc = do -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients -onMessageSent :: Domain -> RemoteMessage ConvId -> Galley () +onMessageSent :: + Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Domain -> + RemoteMessage ConvId -> + Galley r () onMessageSent domain rmUnqualified = do let rm = fmap (toRemoteUnsafe domain) rmUnqualified convId = qUntagged $ rmConversation rm @@ -260,7 +281,7 @@ onMessageSent domain rmUnqualified = do void $ sendLocalMessages (rmTime rm) (rmSender rm) (rmSenderClient rm) Nothing convId localMembers msgMetadata msgs where -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-875 - mkLocalMember :: UserId -> Galley LocalMember + mkLocalMember :: UserId -> Galley r LocalMember mkLocalMember m = pure $ LocalMember @@ -270,7 +291,11 @@ onMessageSent domain rmUnqualified = do lmConvRoleName = Public.roleNameWireMember } -sendMessage :: Domain -> MessageSendRequest -> Galley MessageSendResponse +sendMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Domain -> + MessageSendRequest -> + Galley r MessageSendResponse sendMessage originDomain msr = do let sender = Qualified (msrSender msr) originDomain msg <- either err pure (fromProto (fromBase64ByteString (msrRawMessage msr))) @@ -278,28 +303,34 @@ sendMessage originDomain msr = do where err = throwM . invalidPayload . LT.pack -onUserDeleted :: Domain -> UserDeletedConversationsNotification -> Galley EmptyResponse +onUserDeleted :: + Members '[FederatorAccess, FireAndForget, ExternalAccess, GundeckAccess] r => + Domain -> + UserDeletedConversationsNotification -> + Galley r EmptyResponse onUserDeleted origDomain udcn = do let deletedUser = toRemoteUnsafe origDomain (FederationAPIGalley.udcnUser udcn) untaggedDeletedUser = qUntagged deletedUser convIds = FederationAPIGalley.udcnConversations udcn - pooledForConcurrentlyN_ 16 (fromRange convIds) $ \c -> do - lc <- qualifyLocal c - mconv <- Data.conversation c - Data.removeRemoteMembersFromLocalConv c (pure deletedUser) - for_ mconv $ \conv -> do - when (isRemoteMember deletedUser (Data.convRemoteMembers conv)) $ - case Data.convType conv of - -- No need for a notification on One2One conv as the user is being - -- deleted and that notification should suffice. - Public.One2OneConv -> pure () - -- No need for a notification on Connect Conv as there should be no - -- other user in the conv. - Public.ConnectConv -> pure () - -- The self conv cannot be on a remote backend. - Public.SelfConv -> pure () - Public.RegularConv -> do - let action = ConversationActionRemoveMembers (pure untaggedDeletedUser) - botsAndMembers = convBotsAndMembers conv - void $ notifyConversationMetadataUpdate untaggedDeletedUser Nothing lc botsAndMembers action + + spawnMany $ + fromRange convIds <&> \c -> do + lc <- qualifyLocal c + mconv <- Data.conversation c + Data.removeRemoteMembersFromLocalConv c (pure deletedUser) + for_ mconv $ \conv -> do + when (isRemoteMember deletedUser (Data.convRemoteMembers conv)) $ + case Data.convType conv of + -- No need for a notification on One2One conv as the user is being + -- deleted and that notification should suffice. + Public.One2OneConv -> pure () + -- No need for a notification on Connect Conv as there should be no + -- other user in the conv. + Public.ConnectConv -> pure () + -- The self conv cannot be on a remote backend. + Public.SelfConv -> pure () + Public.RegularConv -> do + let action = ConversationActionRemoveMembers (pure untaggedDeletedUser) + botsAndMembers = convBotsAndMembers conv + void $ notifyConversationMetadataUpdate untaggedDeletedUser Nothing lc botsAndMembers action pure EmptyResponse diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 400f7d775ab..5cc940a4579 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -28,8 +28,7 @@ where import qualified Cassandra as Cql import Control.Exception.Safe (catchAny) import Control.Lens hiding ((.=)) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Except (runExceptT) import Data.Data (Proxy (Proxy)) import Data.Id as Id import Data.List1 (maybeList1) @@ -55,6 +54,7 @@ import qualified Galley.API.Update as Update import Galley.API.Util (JSON, isMember, qualifyLocal, viewFederationDomain) import Galley.App import qualified Galley.Data as Data +import Galley.Effects import qualified Galley.Intra.Push as Intra import qualified Galley.Queue as Q import Galley.Types @@ -252,7 +252,7 @@ type IFeatureStatusDeprecatedPut featureName = :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus featureName) :> Put '[Servant.JSON] (Public.TeamFeatureStatus featureName) -servantSitemap :: ServerT ServantAPI Galley +servantSitemap :: ServerT ServantAPI (Galley GalleyEffects) servantSitemap = genericServerT $ InternalApi @@ -287,23 +287,23 @@ servantSitemap = } iGetTeamFeature :: - forall a. + forall a r. Public.KnownTeamFeatureName a => - (Features.GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> + (Features.GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: - forall a. + forall a r. Public.KnownTeamFeatureName a => - (TeamId -> Public.TeamFeatureStatus a -> Galley (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Public.TeamFeatureStatus a -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) iPutTeamFeature setter = Features.setFeatureStatus @a setter DontDoAuth -sitemap :: Routes a Galley () +sitemap :: Routes a (Galley GalleyEffects) () sitemap = do -- Conversation API (internal) ---------------------------------------- @@ -465,7 +465,12 @@ sitemap = do get "/i/legalhold/whitelisted-teams/:tid" (continue getTeamLegalholdWhitelistedH) $ capture "tid" -rmUser :: UserId -> Maybe ConnId -> Galley () +rmUser :: + forall r. + Members '[BrigAccess, ExternalAccess, FederatorAccess, GundeckAccess] r => + UserId -> + Maybe ConnId -> + Galley r () rmUser user conn = do let n = toRange (Proxy @100) :: Range 1 100 Int32 nRange1000 = rcast n :: Range 1 1000 Int32 @@ -476,7 +481,7 @@ rmUser user conn = do goConvPages lusr nRange1000 allConvIds Data.eraseClients user where - goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley () + goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley r () goConvPages lusr range page = do let (localConvs, remoteConvs) = partitionQualified lusr (mtpResults page) leaveLocalConversations localConvs @@ -494,7 +499,7 @@ rmUser user conn = do leaveTeams =<< Cql.liftClient (Cql.nextPage tids) -- FUTUREWORK: Ensure that remote members of local convs get notified of this activity - leaveLocalConversations :: [ConvId] -> Galley () + leaveLocalConversations :: [ConvId] -> Galley r () leaveLocalConversations ids = do localDomain <- viewFederationDomain cc <- Data.localConversations ids @@ -522,7 +527,7 @@ rmUser user conn = do (maybeList1 (catMaybes pp)) Intra.push - leaveRemoteConversations :: Local UserId -> Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Galley () + leaveRemoteConversations :: Local UserId -> Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Galley r () leaveRemoteConversations lusr cids = do for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) @@ -542,12 +547,13 @@ rmUser user conn = do pure () Right _ -> pure () -deleteLoop :: Galley () -deleteLoop = do +deleteLoop :: Galley r () +deleteLoop = liftGalley0 $ do q <- view deleteQueue safeForever "deleteLoop" $ do i@(TeamItem tid usr con) <- Q.pop q - Teams.uncheckedDeleteTeam usr con tid `catchAny` someError q i + interpretGalleyToGalley0 (Teams.uncheckedDeleteTeam usr con tid) + `catchAny` someError q i where someError q i x = do err $ "error" .= show x ~~ msg (val "failed to delete") @@ -556,14 +562,17 @@ deleteLoop = do err (msg (val "delete queue is full, dropping item") ~~ "item" .= show i) liftIO $ threadDelay 1000000 -safeForever :: (MonadIO m, MonadLogger m, MonadCatch m) => String -> m () -> m () +safeForever :: String -> Galley0 () -> Galley0 () safeForever funName action = forever $ action `catchAny` \exc -> do err $ "error" .= show exc ~~ msg (val $ cs funName <> " failed") threadDelay 60000000 -- pause to keep worst-case noise in logs manageable -guardLegalholdPolicyConflictsH :: (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> Galley Response +guardLegalholdPolicyConflictsH :: + Member BrigAccess r => + (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> + Galley r Response guardLegalholdPolicyConflictsH (req ::: _) = do glh <- fromJsonBody req guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index bd40fa575f6..48d9eed39a9 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -56,6 +56,7 @@ import qualified Galley.Data as Data import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import qualified Galley.Data.LegalHold as LegalHoldData import qualified Galley.Data.TeamFeatures as TeamFeatures +import Galley.Effects import qualified Galley.External.LegalHoldService as LHService import qualified Galley.Intra.Client as Client import Galley.Intra.User (getConnectionsUnqualified, putConnectionInternal) @@ -69,7 +70,6 @@ import Network.Wai import Network.Wai.Predicate hiding (or, result, setStatus, _3) import Network.Wai.Utilities as Wai import qualified System.Logger.Class as Log -import UnliftIO.Async (pooledMapConcurrentlyN_) import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.Routes.Internal.Brig.Connection @@ -77,10 +77,10 @@ import qualified Wire.API.Team.Feature as Public import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import qualified Wire.API.Team.LegalHold as Public -assertLegalHoldEnabledForTeam :: TeamId -> Galley () +assertLegalHoldEnabledForTeam :: TeamId -> Galley r () assertLegalHoldEnabledForTeam tid = unlessM (isLegalHoldEnabledForTeam tid) $ throwM legalHoldNotEnabled -isLegalHoldEnabledForTeam :: TeamId -> Galley Bool +isLegalHoldEnabledForTeam :: TeamId -> Galley r Bool isLegalHoldEnabledForTeam tid = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> do @@ -94,12 +94,12 @@ isLegalHoldEnabledForTeam tid = do FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> isTeamLegalholdWhitelisted tid -createSettingsH :: UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley Response +createSettingsH :: UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley r Response createSettingsH (zusr ::: tid ::: req ::: _) = do newService <- fromJsonBody req setStatus status201 . json <$> createSettings zusr tid newService -createSettings :: UserId -> TeamId -> Public.NewLegalHoldService -> Galley Public.ViewLegalHoldService +createSettings :: UserId -> TeamId -> Public.NewLegalHoldService -> Galley r Public.ViewLegalHoldService createSettings zusr tid newService = do assertLegalHoldEnabledForTeam tid zusrMembership <- Data.teamMember tid zusr @@ -116,11 +116,11 @@ createSettings zusr tid newService = do LegalHoldData.createSettings service pure . viewLegalHoldService $ service -getSettingsH :: UserId ::: TeamId ::: JSON -> Galley Response +getSettingsH :: UserId ::: TeamId ::: JSON -> Galley r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid -getSettings :: UserId -> TeamId -> Galley Public.ViewLegalHoldService +getSettings :: UserId -> TeamId -> Galley r Public.ViewLegalHoldService getSettings zusr tid = do zusrMembership <- Data.teamMember tid zusr void $ permissionCheck (ViewTeamFeature Public.TeamFeatureLegalHold) zusrMembership @@ -131,13 +131,21 @@ getSettings zusr tid = do (True, Nothing) -> Public.ViewLegalHoldServiceNotConfigured (True, Just result) -> viewLegalHoldService result -removeSettingsH :: UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> Galley Response +removeSettingsH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> + Galley r Response removeSettingsH (zusr ::: tid ::: req ::: _) = do removeSettingsRequest <- fromJsonBody req removeSettings zusr tid removeSettingsRequest pure noContent -removeSettings :: UserId -> TeamId -> Public.RemoveLegalHoldSettingsRequest -> Galley () +removeSettings :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + Public.RemoveLegalHoldSettingsRequest -> + Galley r () removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do assertNotWhitelisting assertLegalHoldEnabledForTeam tid @@ -150,7 +158,7 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do ensureReAuthorised zusr mPassword removeSettings' tid where - assertNotWhitelisting :: Galley () + assertNotWhitelisting :: Galley r () assertNotWhitelisting = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure () @@ -160,23 +168,24 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do -- | Remove legal hold settings from team; also disabling for all users and removing LH devices removeSettings' :: + forall r. + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => TeamId -> - Galley () + Galley r () removeSettings' tid = do -- Loop through team members and run this action. Data.withTeamMembersWithChunks tid action LegalHoldData.removeSettings tid where - action :: [TeamMember] -> Galley () + action :: [TeamMember] -> Galley r () action membs = do let zothers = map (view userId) membs let lhMembers = filter ((== UserLegalHoldEnabled) . view legalHoldStatus) membs Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "LegalHold.removeSettings'") - -- I picked this number by fair dice roll, feel free to change it :P - pooledMapConcurrentlyN_ 8 removeLHForUser lhMembers - removeLHForUser :: TeamMember -> Galley () + spawnMany (map removeLHForUser lhMembers) + removeLHForUser :: TeamMember -> Galley r () removeLHForUser member = do let uid = member ^. Team.userId Client.removeLegalHoldClientFromUser uid @@ -185,11 +194,11 @@ removeSettings' tid = do -- | 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 :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +getUserStatusH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do json <$> getUserStatus tid uid -getUserStatus :: TeamId -> UserId -> Galley Public.UserLegalHoldStatusResponse +getUserStatus :: TeamId -> UserId -> Galley r Public.UserLegalHoldStatusResponse getUserStatus tid uid = do mTeamMember <- Data.teamMember tid uid teamMember <- maybe (throwM teamMemberNotFound) pure mTeamMember @@ -201,7 +210,7 @@ getUserStatus tid uid = do UserLegalHoldEnabled -> makeResponseDetails pure $ UserLegalHoldStatusResponse status mlk lcid where - makeResponseDetails :: Galley (Maybe LastPrekey, Maybe ClientId) + makeResponseDetails :: Galley r (Maybe LastPrekey, Maybe ClientId) makeResponseDetails = do mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid lastKey <- case mLastKey of @@ -218,7 +227,10 @@ getUserStatus tid uid = do -- | Change 'UserLegalHoldStatus' from no consent to disabled. FUTUREWORK: -- @withdrawExplicitConsentH@ (lots of corner cases we'd have to implement for that to pan -- out). -grantConsentH :: UserId ::: TeamId ::: JSON -> Galley Response +grantConsentH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId ::: TeamId ::: JSON -> + Galley r Response grantConsentH (zusr ::: tid ::: _) = do grantConsent zusr tid >>= \case GrantConsentSuccess -> pure $ empty & setStatus status201 @@ -228,7 +240,11 @@ data GrantConsentResult = GrantConsentSuccess | GrantConsentAlreadyGranted -grantConsent :: UserId -> TeamId -> Galley GrantConsentResult +grantConsent :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + Galley r GrantConsentResult grantConsent zusr tid = do userLHStatus <- fmap (view legalHoldStatus) <$> Data.teamMember tid zusr case userLHStatus of @@ -241,7 +257,10 @@ grantConsent zusr tid = do Just UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted -- | Request to provision a device on the legal hold service for a user -requestDeviceH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +requestDeviceH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId ::: TeamId ::: UserId ::: JSON -> + Galley r Response requestDeviceH (zusr ::: tid ::: uid ::: _) = do requestDevice zusr tid uid <&> \case RequestDeviceSuccess -> empty & setStatus status201 @@ -251,7 +270,13 @@ data RequestDeviceResult = RequestDeviceSuccess | RequestDeviceAlreadyPending -requestDevice :: UserId -> TeamId -> UserId -> Galley RequestDeviceResult +requestDevice :: + forall r. + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + UserId -> + Galley r RequestDeviceResult requestDevice zusr tid uid = do assertLegalHoldEnabledForTeam tid Log.debug $ @@ -273,7 +298,7 @@ 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 () + provisionLHDevice :: UserLegalHoldStatus -> Galley r () provisionLHDevice userLHStatus = do (lastPrekey', prekeys) <- requestDeviceFromService -- We don't distinguish the last key here; brig will do so when the device is added @@ -281,7 +306,7 @@ requestDevice zusr tid uid = do changeLegalholdStatus tid uid userLHStatus UserLegalHoldPending Client.notifyClientsAboutLegalHoldRequest zusr uid lastPrekey' - requestDeviceFromService :: Galley (LastPrekey, [Prekey]) + requestDeviceFromService :: Galley r (LastPrekey, [Prekey]) requestDeviceFromService = do LegalHoldData.dropPendingPrekeys uid lhDevice <- LHService.requestNewDevice tid uid @@ -294,14 +319,22 @@ requestDevice zusr tid uid = do -- it gets interupted. There's really no reason to delete them anyways -- since they are replaced if needed when registering new LH devices. approveDeviceH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => UserId ::: TeamId ::: UserId ::: ConnId ::: JsonRequest Public.ApproveLegalHoldForUserRequest ::: JSON -> - Galley Response + Galley r Response approveDeviceH (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do approve <- fromJsonBody req approveDevice zusr tid uid connId approve pure empty -approveDevice :: UserId -> TeamId -> UserId -> ConnId -> Public.ApproveLegalHoldForUserRequest -> Galley () +approveDevice :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + UserId -> + ConnId -> + Public.ApproveLegalHoldForUserRequest -> + Galley r () approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPassword) = do assertLegalHoldEnabledForTeam tid Log.debug $ @@ -330,7 +363,7 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) changeLegalholdStatus tid uid userLHStatus UserLegalHoldEnabled where - assertUserLHPending :: UserLegalHoldStatus -> Galley () + assertUserLHPending :: UserLegalHoldStatus -> Galley r () assertUserLHPending userLHStatus = do case userLHStatus of UserLegalHoldEnabled -> throwM userLegalHoldAlreadyEnabled @@ -339,8 +372,9 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo UserLegalHoldNoConsent -> throwM userLegalHoldNotPending disableForUserH :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => UserId ::: TeamId ::: UserId ::: JsonRequest Public.DisableLegalHoldForUserRequest ::: JSON -> - Galley Response + Galley r Response disableForUserH (zusr ::: tid ::: uid ::: req ::: _) = do disable <- fromJsonBody req disableForUser zusr tid uid disable <&> \case @@ -351,7 +385,14 @@ data DisableLegalHoldForUserResponse = DisableLegalHoldSuccess | DisableLegalHoldWasNotEnabled -disableForUser :: UserId -> TeamId -> UserId -> Public.DisableLegalHoldForUserRequest -> Galley DisableLegalHoldForUserResponse +disableForUser :: + forall r. + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + TeamId -> + UserId -> + Public.DisableLegalHoldForUserRequest -> + Galley r DisableLegalHoldForUserResponse disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = do Log.debug $ Log.field "targets" (toByteString uid) @@ -364,7 +405,7 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = then pure DisableLegalHoldWasNotEnabled else disableLH userLHStatus $> DisableLegalHoldSuccess where - disableLH :: UserLegalHoldStatus -> Galley () + disableLH :: UserLegalHoldStatus -> Galley r () disableLH userLHStatus = do ensureReAuthorised zusr mPassword Client.removeLegalHoldClientFromUser uid @@ -377,7 +418,13 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = -- | 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 :: TeamId -> UserId -> UserLegalHoldStatus -> UserLegalHoldStatus -> Galley () +changeLegalholdStatus :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + TeamId -> + UserId -> + UserLegalHoldStatus -> + UserLegalHoldStatus -> + Galley r () changeLegalholdStatus tid uid old new = do case old of UserLegalHoldEnabled -> case new of @@ -413,7 +460,7 @@ changeLegalholdStatus tid uid old new = do illegal = throwM userLegalHoldIllegalOperation -- FUTUREWORK: make this async? -blockNonConsentingConnections :: UserId -> Galley () +blockNonConsentingConnections :: forall r. Member BrigAccess r => UserId -> Galley r () blockNonConsentingConnections uid = do conns <- getConnectionsUnqualified [uid] Nothing Nothing errmsgs <- do @@ -425,7 +472,7 @@ blockNonConsentingConnections uid = do Log.warn $ Log.msg @String msgs throwM legalHoldCouldNotBlockConnections where - findConflicts :: [ConnectionStatus] -> Galley [[UserId]] + findConflicts :: [ConnectionStatus] -> Galley r [[UserId]] findConflicts conns = do let (FutureWork @'Public.LegalholdPlusFederationNotImplemented -> _remoteUids, localUids) = (undefined, csTo <$> conns) -- FUTUREWORK: Handle remoteUsers here when federation is implemented @@ -433,25 +480,25 @@ blockNonConsentingConnections uid = do teamsOfUsers <- Data.usersTeams others filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others - blockConflicts :: UserId -> [UserId] -> Galley [String] + blockConflicts :: UserId -> [UserId] -> Galley r [String] blockConflicts _ [] = pure [] blockConflicts userLegalhold othersToBlock@(_ : _) = do status <- putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) pure $ ["blocking users failed: " <> show (status, othersToBlock) | status /= status200] -setTeamLegalholdWhitelisted :: TeamId -> Galley () +setTeamLegalholdWhitelisted :: TeamId -> Galley r () setTeamLegalholdWhitelisted tid = do LegalHoldData.setTeamLegalholdWhitelisted tid -setTeamLegalholdWhitelistedH :: TeamId -> Galley Response +setTeamLegalholdWhitelistedH :: TeamId -> Galley r Response setTeamLegalholdWhitelistedH tid = do empty <$ setTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelisted :: TeamId -> Galley () +unsetTeamLegalholdWhitelisted :: TeamId -> Galley r () unsetTeamLegalholdWhitelisted tid = do LegalHoldData.unsetTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelistedH :: TeamId -> Galley Response +unsetTeamLegalholdWhitelistedH :: TeamId -> Galley r Response unsetTeamLegalholdWhitelistedH tid = do () <- error @@ -460,7 +507,7 @@ unsetTeamLegalholdWhitelistedH tid = do \before you enable the end-point." setStatus status204 empty <$ unsetTeamLegalholdWhitelisted tid -getTeamLegalholdWhitelistedH :: TeamId -> Galley Response +getTeamLegalholdWhitelistedH :: TeamId -> Galley r Response getTeamLegalholdWhitelistedH tid = do lhEnabled <- isTeamLegalholdWhitelisted tid pure $ @@ -482,7 +529,11 @@ getTeamLegalholdWhitelistedH tid = do -- which may cause wrong behavior. In order to guarantee correct behavior, the first argument -- contains the hypothetical new LH status of `uid`'s so it can be consulted instead of the -- one from the database. -handleGroupConvPolicyConflicts :: UserId -> UserLegalHoldStatus -> Galley () +handleGroupConvPolicyConflicts :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + UserLegalHoldStatus -> + Galley r () handleGroupConvPolicyConflicts uid hypotheticalLHStatus = void $ iterateConversations uid (toRange (Proxy @500)) $ \convs -> do diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index 89e774d8379..42bebf1fe3b 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -30,6 +30,7 @@ import qualified Data.Set as Set import Galley.API.Util import Galley.App import qualified Galley.Data as Data +import Galley.Effects import qualified Galley.Intra.Client as Intra import Galley.Intra.User (getUser) import Galley.Options @@ -42,7 +43,11 @@ import Wire.API.User.Client as Client data LegalholdConflicts = LegalholdConflicts -guardQualifiedLegalholdPolicyConflicts :: LegalholdProtectee -> QualifiedUserClients -> Galley (Either LegalholdConflicts ()) +guardQualifiedLegalholdPolicyConflicts :: + Member BrigAccess r => + LegalholdProtectee -> + QualifiedUserClients -> + Galley r (Either LegalholdConflicts ()) guardQualifiedLegalholdPolicyConflicts protectee qclients = do localDomain <- viewFederationDomain guardLegalholdPolicyConflicts protectee @@ -57,7 +62,11 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do -- -- This is a fallback safeguard that shouldn't get triggered if backend and clients work as -- intended. -guardLegalholdPolicyConflicts :: LegalholdProtectee -> UserClients -> Galley (Either LegalholdConflicts ()) +guardLegalholdPolicyConflicts :: + Member BrigAccess r => + LegalholdProtectee -> + UserClients -> + Galley r (Either LegalholdConflicts ()) guardLegalholdPolicyConflicts LegalholdPlusFederationNotImplemented _otherClients = pure . pure $ () guardLegalholdPolicyConflicts UnprotectedBot _otherClients = pure . pure $ () guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do @@ -67,7 +76,12 @@ guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do FeatureLegalHoldDisabledByDefault -> guardLegalholdPolicyConflictsUid self otherClients FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> guardLegalholdPolicyConflictsUid self otherClients -guardLegalholdPolicyConflictsUid :: UserId -> UserClients -> Galley (Either LegalholdConflicts ()) +guardLegalholdPolicyConflictsUid :: + forall r. + Member BrigAccess r => + UserId -> + UserClients -> + Galley r (Either LegalholdConflicts ()) guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do let otherCids :: [ClientId] otherCids = Set.toList . Set.unions . Map.elems . userClients $ otherClients @@ -111,7 +125,7 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do . Client.fromClientCapabilityList . Client.clientCapabilities - checkConsentMissing :: Galley Bool + checkConsentMissing :: Galley 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?) diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index f118658f04a..9ee604c32b2 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -46,7 +46,7 @@ import Wire.API.Federation.API.Galley -- | View for a given user of a stored conversation. -- -- Throws "bad-state" when the user is not part of the conversation. -conversationView :: UserId -> Data.Conversation -> Galley Conversation +conversationView :: UserId -> Data.Conversation -> Galley r Conversation conversationView uid conv = do luid <- qualifyLocal uid let mbConv = conversationViewMaybe luid conv diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 1df97be4f34..5f03241147f 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -23,24 +23,19 @@ import Data.Set.Lens import Data.Time.Clock (UTCTime, getCurrentTime) import Galley.API.LegalHold.Conflicts (guardQualifiedLegalholdPolicyConflicts) import Galley.API.Util - ( runFederatedBrig, - runFederatedGalley, - viewFederationDomain, - ) import Galley.App import qualified Galley.Data as Data import Galley.Data.Services as Data +import Galley.Effects import qualified Galley.External as External import qualified Galley.Intra.Client as Intra import Galley.Intra.Push -import Galley.Intra.User import Galley.Options (optSettings, setIntraListing) import qualified Galley.Types.Clients as Clients import Galley.Types.Conversations.Members import Gundeck.Types.Push.V2 (RecipientClients (..)) -import Imports +import Imports hiding (forkIO) import qualified System.Logger.Class as Log -import UnliftIO.Async import Wire.API.Event.Conversation import qualified Wire.API.Federation.API.Brig as FederatedBrig import qualified Wire.API.Federation.API.Galley as FederatedGalley @@ -179,24 +174,25 @@ checkMessageClients sender participantMap recipientMap mismatchStrat = mkQualifiedMismatch reportedMissing redundant deleted ) -getRemoteClients :: [RemoteMember] -> Galley (Map (Domain, UserId) (Set ClientId)) -getRemoteClients remoteMembers = do - fmap mconcat -- concatenating maps is correct here, because their sets of keys are disjoint - . pooledMapConcurrentlyN 8 getRemoteClientsFromDomain - . bucketRemote - . map rmId - $ remoteMembers +getRemoteClients :: + Member FederatorAccess r => + [RemoteMember] -> + Galley r (Map (Domain, UserId) (Set ClientId)) +getRemoteClients remoteMembers = + -- concatenating maps is correct here, because their sets of keys are disjoint + mconcat . map tUnqualified + <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain where - getRemoteClientsFromDomain :: Remote [UserId] -> Galley (Map (Domain, UserId) (Set ClientId)) - getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = do - let rpc = FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) - Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap <$> runFederatedBrig domain rpc + getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = + Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap + <$> FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) postRemoteOtrMessage :: + Member FederatorAccess r => Qualified UserId -> Qualified ConvId -> LByteString -> - Galley (PostOtrResponse MessageSendingStatus) + Galley r (PostOtrResponse MessageSendingStatus) postRemoteOtrMessage sender conv rawMsg = do let msr = FederatedGalley.MessageSendRequest @@ -207,9 +203,16 @@ postRemoteOtrMessage sender conv rawMsg = do rpc = FederatedGalley.sendMessage FederatedGalley.clientRoutes (qDomain sender) msr FederatedGalley.msResponse <$> runFederatedGalley (qDomain conv) rpc -postQualifiedOtrMessage :: UserType -> Qualified UserId -> Maybe ConnId -> ConvId -> QualifiedNewOtrMessage -> Galley (PostOtrResponse MessageSendingStatus) +postQualifiedOtrMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + UserType -> + Qualified UserId -> + Maybe ConnId -> + ConvId -> + QualifiedNewOtrMessage -> + Galley r (PostOtrResponse MessageSendingStatus) postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do - alive <- Data.isConvAlive convId + alive <- lift $ Data.isConvAlive convId localDomain <- viewFederationDomain now <- liftIO getCurrentTime let nowMillis = toUTCTimeMillis now @@ -222,7 +225,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- conversation members localMembers <- lift $ Data.members convId - remoteMembers <- Data.lookupRemoteMembers convId + remoteMembers <- lift $ Data.lookupRemoteMembers convId let localMemberIds = lmId <$> localMembers localMemberMap :: Map UserId LocalMember @@ -297,6 +300,7 @@ 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] r => UTCTime -> Qualified UserId -> ClientId -> @@ -305,7 +309,7 @@ sendMessages :: Map UserId LocalMember -> MessageMetadata -> Map (Domain, UserId, ClientId) ByteString -> - Galley QualifiedUserClients + Galley r QualifiedUserClients sendMessages now sender senderClient mconn conv localMemberMap metadata messages = do localDomain <- viewFederationDomain let messageMap = byDomain $ fmap toBase64Text messages @@ -323,6 +327,7 @@ sendMessages now sender senderClient mconn conv localMemberMap metadata messages mempty sendLocalMessages :: + Members '[BotAccess, GundeckAccess, ExternalAccess] r => UTCTime -> Qualified UserId -> ClientId -> @@ -331,7 +336,7 @@ sendLocalMessages :: Map UserId LocalMember -> MessageMetadata -> Map (UserId, ClientId) Text -> - Galley (Set (UserId, ClientId)) + Galley r (Set (UserId, ClientId)) sendLocalMessages now sender senderClient mconn conv localMemberMap metadata localMessages = do localDomain <- viewFederationDomain let events = @@ -356,7 +361,7 @@ sendRemoteMessages :: ConvId -> MessageMetadata -> Map (UserId, ClientId) Text -> - Galley (Set (UserId, ClientId)) + Galley r (Set (UserId, ClientId)) sendRemoteMessages domain now sender senderClient conv metadata messages = handle <=< runExceptT $ do let rcpts = foldr @@ -381,7 +386,7 @@ sendRemoteMessages domain now sender senderClient conv metadata messages = handl let rpc = FederatedGalley.onMessageSent FederatedGalley.clientRoutes originDomain rm executeFederated domain rpc where - handle :: Either FederationError a -> Galley (Set (UserId, ClientId)) + handle :: Either FederationError a -> Galley r (Set (UserId, ClientId)) handle (Right _) = pure mempty handle (Left e) = do Log.warn $ @@ -419,20 +424,23 @@ newUserPush p = MessagePush {userPushes = pure p, botPushes = mempty} newBotPush :: BotMember -> Event -> MessagePush newBotPush b e = MessagePush {userPushes = mempty, botPushes = pure (b, e)} -runMessagePush :: Qualified ConvId -> MessagePush -> Galley () +runMessagePush :: + forall r. + Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Qualified ConvId -> + MessagePush -> + Galley r () runMessagePush cnv mp = do pushSome (userPushes mp) pushToBots (botPushes mp) where - pushToBots :: [(BotMember, Event)] -> Galley () + pushToBots :: [(BotMember, Event)] -> Galley r () pushToBots pushes = do localDomain <- viewFederationDomain if localDomain /= qDomain cnv 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 void . forkIO $ do - gone <- External.deliver pushes - mapM_ (deleteBot (qUnqualified cnv) . botMemId) gone + else External.deliverAndDeleteAsync (qUnqualified cnv) pushes newMessageEvent :: Qualified ConvId -> Qualified UserId -> ClientId -> Maybe Text -> UTCTime -> ClientId -> Text -> Event newMessageEvent convId sender senderClient dat time receiverClient cipherText = diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs index d9be593d5f0..d9978a18b2d 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/services/galley/src/Galley/API/One2One.hs @@ -31,11 +31,11 @@ import Galley.Types.Conversations.One2One (one2OneConvId) import Galley.Types.UserList (UserList (..)) import Imports -iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> Galley UpsertOne2OneConversationResponse +iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> Galley r UpsertOne2OneConversationResponse iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do let convId = fromMaybe (one2OneConvId (qUntagged uooLocalUser) (qUntagged uooRemoteUser)) uooConvId - let dolocal :: Local ConvId -> Galley () + let dolocal :: Local ConvId -> Galley r () dolocal lconvId = do mbConv <- Data.conversation (tUnqualified lconvId) case mbConv of @@ -60,7 +60,7 @@ iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do unless (null (Data.convLocalMembers conv)) $ Data.acceptConnect (tUnqualified lconvId) (RemoteActor, Excluded) -> Data.removeRemoteMembersFromLocalConv (tUnqualified lconvId) (pure uooRemoteUser) - doremote :: Remote ConvId -> Galley () + doremote :: Remote ConvId -> Galley r () doremote rconvId = case (uooActor, uooActorDesiredMembership) of (LocalActor, Included) -> do diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index a5422585473..900e4b052ff 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -72,7 +72,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 +servantSitemap :: ServerT GalleyAPI.ServantAPI (Galley GalleyEffects) servantSitemap = genericServerT $ GalleyAPI.Api @@ -174,7 +174,7 @@ servantSitemap = GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal } -sitemap :: Routes ApiBuilder Galley () +sitemap :: Routes ApiBuilder (Galley GalleyEffects) () sitemap = do -- Team API ----------------------------------------------------------- @@ -731,7 +731,7 @@ sitemap = do errorResponse (Error.errorDescriptionTypeToWai @Error.UnknownClient) errorResponse Error.broadcastLimitExceeded -apiDocs :: Routes ApiBuilder Galley () +apiDocs :: Routes ApiBuilder (Galley r) () apiDocs = get "/conversations/api-docs" (continue docs) $ accept "application" "json" @@ -739,7 +739,7 @@ apiDocs = type JSON = Media "application" "json" -docs :: JSON ::: ByteString -> Galley Response +docs :: JSON ::: ByteString -> Galley 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 d98c99598de..0666e32b506 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -53,6 +53,7 @@ import Galley.API.Util import Galley.App import qualified Galley.Data as Data import qualified Galley.Data.Types as Data +import Galley.Effects import Galley.Types import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles @@ -75,11 +76,11 @@ import Wire.API.Federation.Error import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public -getBotConversationH :: BotId ::: ConvId ::: JSON -> Galley Response +getBotConversationH :: BotId ::: ConvId ::: JSON -> Galley r Response getBotConversationH (zbot ::: zcnv ::: _) = do json <$> getBotConversation zbot zcnv -getBotConversation :: BotId -> ConvId -> Galley Public.BotConvView +getBotConversation :: BotId -> ConvId -> Galley r Public.BotConvView getBotConversation zbot zcnv = do (c, _) <- getConversationAndMemberWithError (errorDescriptionTypeToWai @ConvNotFound) (botUserId zbot) zcnv domain <- viewFederationDomain @@ -93,12 +94,12 @@ getBotConversation zbot zcnv = do | otherwise = Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) -getUnqualifiedConversation :: UserId -> ConvId -> Galley Public.Conversation +getUnqualifiedConversation :: UserId -> ConvId -> Galley r Public.Conversation getUnqualifiedConversation zusr cnv = do c <- getConversationAndCheckMembership zusr cnv Mapping.conversationView zusr c -getConversation :: UserId -> Qualified ConvId -> Galley Public.Conversation +getConversation :: UserId -> Qualified ConvId -> Galley r Public.Conversation getConversation zusr cnv = do lusr <- qualifyLocal zusr foldQualified @@ -107,7 +108,7 @@ getConversation zusr cnv = do getRemoteConversation cnv where - getRemoteConversation :: Remote ConvId -> Galley Public.Conversation + getRemoteConversation :: Remote ConvId -> Galley r Public.Conversation getRemoteConversation remoteConvId = do conversations <- getRemoteConversations zusr [remoteConvId] case conversations of @@ -115,7 +116,7 @@ getConversation zusr cnv = do [conv] -> pure conv _convs -> throwM (federationUnexpectedBody "expected one conversation, got multiple") -getRemoteConversations :: UserId -> [Remote ConvId] -> Galley [Public.Conversation] +getRemoteConversations :: UserId -> [Remote ConvId] -> Galley r [Public.Conversation] getRemoteConversations zusr remoteConvs = getRemoteConversationsWithFailures zusr remoteConvs >>= \case -- throw first error @@ -158,7 +159,7 @@ partitionGetConversationFailures = bimap concat concat . partitionEithers . map getRemoteConversationsWithFailures :: UserId -> [Remote ConvId] -> - Galley ([FailedGetConversation], [Public.Conversation]) + Galley r ([FailedGetConversation], [Public.Conversation]) getRemoteConversationsWithFailures zusr convs = do localDomain <- viewFederationDomain lusr <- qualifyLocal zusr @@ -181,7 +182,8 @@ getRemoteConversationsWithFailures zusr convs = do | otherwise = [failedGetConversationLocally (map qUntagged locallyNotFound)] -- request conversations from remote backends - fmap (bimap (localFailures <>) concat . partitionEithers) + liftGalley0 + . fmap (bimap (localFailures <>) concat . partitionEithers) . pooledForConcurrentlyN 8 (bucketRemote locallyFound) $ \someConvs -> do let req = FederatedGalley.GetConversationsRequest zusr (tUnqualified someConvs) @@ -192,8 +194,8 @@ getRemoteConversationsWithFailures zusr convs = do where handleFailures :: [Remote ConvId] -> - ExceptT FederationError Galley a -> - Galley (Either FailedGetConversation a) + ExceptT FederationError Galley0 a -> + Galley0 (Either FailedGetConversation a) handleFailures rconvs action = runExceptT . withExceptT (failedGetConversationRemotely rconvs) . catchE action @@ -203,14 +205,14 @@ getRemoteConversationsWithFailures zusr convs = do . Logger.field "error" (show e) throwE e -getConversationRoles :: UserId -> ConvId -> Galley Public.ConversationRolesList +getConversationRoles :: UserId -> ConvId -> Galley r Public.ConversationRolesList getConversationRoles zusr cnv = do void $ getConversationAndCheckMembership zusr 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 :: UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> Galley (Public.ConversationList ConvId) +conversationIdsPageFromUnqualified :: UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> Galley r (Public.ConversationList ConvId) conversationIdsPageFromUnqualified zusr start msize = do let size = fromMaybe (toRange (Proxy @1000)) msize ids <- Data.conversationIdsFrom zusr start size @@ -227,7 +229,7 @@ conversationIdsPageFromUnqualified zusr start msize = do -- -- - After local conversations, remote conversations are listed ordered -- - lexicographically by their domain and then by their id. -conversationIdsPageFrom :: UserId -> Public.GetPaginatedConversationIds -> Galley Public.ConvIdsPage +conversationIdsPageFrom :: UserId -> Public.GetPaginatedConversationIds -> Galley r Public.ConvIdsPage conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do localDomain <- viewFederationDomain case gmtprState of @@ -237,7 +239,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do mkState :: ByteString -> C.PagingState mkState = C.PagingState . LBS.fromStrict - localsAndRemotes :: Domain -> Maybe C.PagingState -> Range 1 1000 Int32 -> Galley Public.ConvIdsPage + localsAndRemotes :: Domain -> Maybe C.PagingState -> Range 1 1000 Int32 -> Galley r Public.ConvIdsPage localsAndRemotes localDomain pagingState size = do localPage <- pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) <$> Data.localConversationIdsPageFrom zusr pagingState size let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) @@ -247,7 +249,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do remotePage <- remotesOnly Nothing remainingSize pure $ remotePage {Public.mtpResults = Public.mtpResults localPage <> Public.mtpResults remotePage} - remotesOnly :: Maybe C.PagingState -> Int32 -> Galley Public.ConvIdsPage + remotesOnly :: Maybe C.PagingState -> Int32 -> Galley r Public.ConvIdsPage remotesOnly pagingState size = pageToConvIdPage Public.PagingRemotes <$> Data.remoteConversationIdsPageFrom zusr pagingState size @@ -259,12 +261,22 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do mtpPagingState = Public.ConversationPagingState table (LBS.toStrict . C.unPagingState <$> pwsState) } -getConversations :: UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley (Public.ConversationList Public.Conversation) +getConversations :: + 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 -getConversationsInternal :: UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley (Public.ConversationList Data.Conversation) +getConversationsInternal :: + 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) <- getIds mids let localConvIds = ids @@ -291,7 +303,10 @@ getConversationsInternal user mids mstart msize = do | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False | otherwise = pure True -listConversations :: UserId -> Public.ListConversations -> Galley Public.ConversationsResponse +listConversations :: + UserId -> + Public.ListConversations -> + Galley r Public.ConversationsResponse listConversations user (Public.ListConversations ids) = do luser <- qualifyLocal user @@ -328,7 +343,7 @@ listConversations user (Public.ListConversations ids) = do crFailed = failedConvsRemotely } where - removeDeleted :: Data.Conversation -> Galley Bool + removeDeleted :: Data.Conversation -> Galley r Bool removeDeleted c | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False | otherwise = pure True @@ -338,10 +353,13 @@ listConversations user (Public.ListConversations ids) = do let notFounds = xs \\ founds pure (founds, notFounds) -iterateConversations :: forall a. UserId -> Range 1 500 Int32 -> ([Data.Conversation] -> Galley a) -> Galley [a] +iterateConversations :: + UserId -> + Range 1 500 Int32 -> + ([Data.Conversation] -> Galley r a) -> + Galley r [a] iterateConversations uid pageSize handleConvs = go Nothing where - go :: Maybe ConvId -> Galley [a] go mbConv = do convResult <- getConversationsInternal uid Nothing mbConv (Just pageSize) resultHead <- handleConvs (convList convResult) @@ -353,11 +371,11 @@ iterateConversations uid pageSize handleConvs = go Nothing _ -> pure [] pure $ resultHead : resultTail -internalGetMemberH :: ConvId ::: UserId -> Galley Response +internalGetMemberH :: ConvId ::: UserId -> Galley r Response internalGetMemberH (cnv ::: usr) = do json <$> getLocalSelf usr cnv -getLocalSelf :: UserId -> ConvId -> Galley (Maybe Public.Member) +getLocalSelf :: UserId -> ConvId -> Galley r (Maybe Public.Member) getLocalSelf usr cnv = do lusr <- qualifyLocal usr alive <- Data.isConvAlive cnv @@ -365,13 +383,13 @@ getLocalSelf usr cnv = do then Mapping.localMemberToSelf lusr <$$> Data.member cnv usr else Nothing <$ Data.deleteConversation cnv -getConversationMetaH :: ConvId -> Galley Response +getConversationMetaH :: ConvId -> Galley r Response getConversationMetaH cnv = do getConversationMeta cnv <&> \case Nothing -> setStatus status404 empty Just meta -> json meta -getConversationMeta :: ConvId -> Galley (Maybe ConversationMetadata) +getConversationMeta :: ConvId -> Galley r (Maybe ConversationMetadata) getConversationMeta cnv = do alive <- Data.isConvAlive cnv localDomain <- viewFederationDomain @@ -381,7 +399,12 @@ getConversationMeta cnv = do Data.deleteConversation cnv pure Nothing -getConversationByReusableCode :: UserId -> Key -> Value -> Galley ConversationCoverView +getConversationByReusableCode :: + Member BrigAccess r => + UserId -> + Key -> + Value -> + Galley r ConversationCoverView getConversationByReusableCode zusr key value = do c <- verifyReusableCode (ConversationCode key value Nothing) conv <- ensureConversationAccess zusr (Data.codeConversation c) CodeAccess diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index dd1c93e023f..b2d8f0681da 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -90,6 +90,7 @@ import qualified Galley.Data.LegalHold as Data import qualified Galley.Data.SearchVisibility as SearchVisibilityData import Galley.Data.Services (BotMember) import qualified Galley.Data.TeamFeatures as TeamFeatures +import Galley.Effects import qualified Galley.External as External import qualified Galley.Intra.Journal as Journal import Galley.Intra.Push @@ -105,14 +106,14 @@ import Galley.Types.Conversations.Roles as Roles import Galley.Types.Teams hiding (newTeam) import Galley.Types.Teams.Intra import Galley.Types.Teams.SearchVisibility -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (or, result, setStatus) import Network.Wai.Utilities import qualified SAML2.WebSSO as SAML import qualified System.Logger.Class as Log -import UnliftIO (mapConcurrently) +import UnliftIO.Async (mapConcurrently) import qualified Wire.API.Conversation.Role as Public import Wire.API.ErrorDescription (ConvNotFound, NotATeamMember, operationDenied) import qualified Wire.API.Notification as Public @@ -128,35 +129,35 @@ import qualified Wire.API.User as U import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) -getTeamH :: UserId ::: TeamId ::: JSON -> Galley Response +getTeamH :: UserId ::: TeamId ::: JSON -> Galley r Response getTeamH (zusr ::: tid ::: _) = maybe (throwM teamNotFound) (pure . json) =<< lookupTeam zusr tid -getTeamInternalH :: TeamId ::: JSON -> Galley Response +getTeamInternalH :: TeamId ::: JSON -> Galley r Response getTeamInternalH (tid ::: _) = maybe (throwM teamNotFound) (pure . json) =<< getTeamInternal tid -getTeamInternal :: TeamId -> Galley (Maybe TeamData) +getTeamInternal :: TeamId -> Galley r (Maybe TeamData) getTeamInternal = Data.team -getTeamNameInternalH :: TeamId ::: JSON -> Galley Response +getTeamNameInternalH :: TeamId ::: JSON -> Galley r Response getTeamNameInternalH (tid ::: _) = maybe (throwM teamNotFound) (pure . json) =<< getTeamNameInternal tid -getTeamNameInternal :: TeamId -> Galley (Maybe TeamName) +getTeamNameInternal :: TeamId -> Galley r (Maybe TeamName) getTeamNameInternal = fmap (fmap TeamName) . Data.teamName -getManyTeamsH :: UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> Galley Response +getManyTeamsH :: UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> Galley r Response getManyTeamsH (zusr ::: range ::: size ::: _) = json <$> getManyTeams zusr range size -getManyTeams :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> Galley Public.TeamList +getManyTeams :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> Galley 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 :: UserId -> TeamId -> Galley (Maybe Public.Team) +lookupTeam :: UserId -> TeamId -> Galley r (Maybe Public.Team) lookupTeam zusr tid = do tm <- Data.teamMember tid zusr if isJust tm @@ -168,13 +169,21 @@ lookupTeam zusr tid = do pure (tdTeam <$> t) else pure Nothing -createNonBindingTeamH :: UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> Galley Response +createNonBindingTeamH :: + Members '[GundeckAccess, BrigAccess] r => + UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> + Galley r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do newTeam <- fromJsonBody req newTeamId <- createNonBindingTeam zusr zcon newTeam pure (empty & setStatus status201 . location newTeamId) -createNonBindingTeam :: UserId -> ConnId -> Public.NonBindingNewTeam -> Galley TeamId +createNonBindingTeam :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.NonBindingNewTeam -> + Galley r TeamId createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus let others = @@ -191,26 +200,34 @@ createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do finishCreateTeam team owner others (Just zcon) pure (team ^. teamId) -createBindingTeamH :: UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley Response +createBindingTeamH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> + Galley r Response createBindingTeamH (zusr ::: tid ::: req ::: _) = do newTeam <- fromJsonBody req newTeamId <- createBindingTeam zusr tid newTeam pure (empty & setStatus status201 . location newTeamId) -createBindingTeam :: UserId -> TeamId -> BindingNewTeam -> Galley TeamId +createBindingTeam :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + TeamId -> + BindingNewTeam -> + Galley r TeamId createBindingTeam zusr tid (BindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus team <- Data.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding finishCreateTeam team owner [] Nothing pure tid -updateTeamStatusH :: TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley Response +updateTeamStatusH :: Member BrigAccess r => TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley r Response updateTeamStatusH (tid ::: req ::: _) = do teamStatusUpdate <- fromJsonBody req updateTeamStatus tid teamStatusUpdate return empty -updateTeamStatus :: TeamId -> TeamStatusUpdate -> Galley () +updateTeamStatus :: Member BrigAccess r => TeamId -> TeamStatusUpdate -> Galley r () updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do oldStatus <- tdStatus <$> (Data.team tid >>= ifNothing teamNotFound) valid <- validateTransition (oldStatus, newStatus) @@ -231,7 +248,7 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do else possiblyStaleSize Journal.teamActivate tid size c teamCreationTime journal _ _ = throwM invalidTeamStatusUpdate - validateTransition :: (TeamStatus, TeamStatus) -> Galley Bool + validateTransition :: (TeamStatus, TeamStatus) -> Galley r Bool validateTransition = \case (PendingActive, Active) -> return True (Active, Active) -> return False @@ -240,13 +257,22 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do (Suspended, Suspended) -> return False (_, _) -> throwM invalidTeamStatusUpdate -updateTeamH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> Galley Response +updateTeamH :: + Member GundeckAccess r => + UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> + Galley r Response updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do updateData <- fromJsonBody req updateTeam zusr zcon tid updateData pure empty -updateTeam :: UserId -> ConnId -> TeamId -> Public.TeamUpdateData -> Galley () +updateTeam :: + Member GundeckAccess r => + UserId -> + ConnId -> + TeamId -> + Public.TeamUpdateData -> + Galley r () updateTeam zusr zcon tid updateData = do zusrMembership <- Data.teamMember tid zusr -- let zothers = map (view userId) membs @@ -261,14 +287,23 @@ updateTeam zusr zcon tid updateData = do let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon -deleteTeamH :: UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> Galley Response +deleteTeamH :: + Member BrigAccess r => + UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> + Galley r Response deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do mBody <- fromOptionalJsonBody req deleteTeam zusr zcon tid mBody pure (empty & setStatus status202) -- | 'TeamDeleteData' is only required for binding teams -deleteTeam :: UserId -> ConnId -> TeamId -> Maybe Public.TeamDeleteData -> Galley () +deleteTeam :: + Member BrigAccess r => + UserId -> + ConnId -> + TeamId -> + Maybe Public.TeamDeleteData -> + Galley r () deleteTeam zusr zcon tid mBody = do team <- Data.team tid >>= ifNothing teamNotFound case tdStatus team of @@ -287,7 +322,7 @@ deleteTeam zusr zcon tid mBody = do ensureReAuthorised zusr (body ^. tdAuthPassword) -- This can be called by stern -internalDeleteBindingTeamWithOneMember :: TeamId -> Galley () +internalDeleteBindingTeamWithOneMember :: TeamId -> Galley r () internalDeleteBindingTeamWithOneMember tid = do team <- Data.team tid unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ @@ -298,7 +333,13 @@ internalDeleteBindingTeamWithOneMember tid = do _ -> throwM notAOneMemberTeam -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. -uncheckedDeleteTeam :: UserId -> Maybe ConnId -> TeamId -> Galley () +uncheckedDeleteTeam :: + forall r. + Members '[BrigAccess, ExternalAccess, GundeckAccess, SparAccess] r => + UserId -> + Maybe ConnId -> + TeamId -> + Galley r () uncheckedDeleteTeam zusr zcon tid = do team <- Data.team tid when (isJust team) $ do @@ -314,7 +355,7 @@ uncheckedDeleteTeam zusr zcon tid = do (ue, be) <- foldrM (createConvDeleteEvents now membs) ([], []) convs let e = newEvent TeamDelete tid now pushDeleteEvents membs e ue - void . forkIO $ void $ External.deliver be + External.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. @@ -324,7 +365,7 @@ uncheckedDeleteTeam zusr zcon tid = do Data.unsetTeamLegalholdWhitelisted tid Data.deleteTeam tid where - pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley () + pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley r () pushDeleteEvents membs e ue = do o <- view $ options . optSettings let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) membs) @@ -347,7 +388,7 @@ uncheckedDeleteTeam zusr zcon tid = do [TeamMember] -> TeamConversation -> ([Push], [(BotMember, Conv.Event)]) -> - Galley ([Push], [(BotMember, Conv.Event)]) + Galley r ([Push], [(BotMember, Conv.Event)]) createConvDeleteEvents now teamMembs c (pp, ee) = do localDomain <- viewFederationDomain let qconvId = Qualified (c ^. conversationId) localDomain @@ -364,7 +405,7 @@ uncheckedDeleteTeam zusr zcon tid = do let pp' = maybe pp (\x -> (x & pushConn .~ zcon) : pp) p pure (pp', ee' ++ ee) -getTeamConversationRoles :: UserId -> TeamId -> Galley Public.ConversationRolesList +getTeamConversationRoles :: UserId -> TeamId -> Galley r Public.ConversationRolesList getTeamConversationRoles zusr tid = do mem <- Data.teamMember tid zusr case mem of @@ -374,12 +415,12 @@ getTeamConversationRoles zusr tid = do -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles -getTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley Response +getTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley r Response getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do (memberList, withPerms) <- getTeamMembers zusr tid maxResults pure . json $ teamMemberListJson withPerms memberList -getTeamMembers :: UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> Galley (Public.TeamMemberList, Public.TeamMember -> Bool) +getTeamMembers :: UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) getTeamMembers zusr tid maxResults = do Data.teamMember tid zusr >>= \case Nothing -> throwErrorDescriptionType @NotATeamMember @@ -388,7 +429,10 @@ getTeamMembers zusr tid maxResults = do let withPerms = (m `canSeePermsOf`) pure (mems, withPerms) -getTeamMembersCSVH :: UserId ::: TeamId ::: JSON -> Galley Response +getTeamMembersCSVH :: + Member BrigAccess r => + UserId ::: TeamId ::: JSON -> + Galley r Response getTeamMembersCSVH (zusr ::: tid ::: _) = do Data.teamMember tid zusr >>= \case Nothing -> throwM accessDenied @@ -459,7 +503,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do tExportUserId = U.userId user } - lookupInviterHandle :: [TeamMember] -> Galley (UserId -> Maybe Handle.Handle) + lookupInviterHandle :: Member BrigAccess r => [TeamMember] -> Galley r (UserId -> Maybe Handle.Handle) lookupInviterHandle members = do let inviterIds :: [UserId] inviterIds = nub $ catMaybes $ fmap fst . view invitation <$> members @@ -491,14 +535,14 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do (UserSSOId (SAML.UserRef _idp nameId)) -> Just . CI.original . SAML.unsafeShowNameID $ nameId (UserScimExternalId _) -> Nothing -bulkGetTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley Response +bulkGetTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley r Response bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do UserIdList uids <- fromJsonBody body (memberList, withPerms) <- bulkGetTeamMembers zusr tid maxResults uids pure . json $ teamMemberListJson withPerms memberList -- | like 'getTeamMembers', but with an explicit list of users we are to return. -bulkGetTeamMembers :: UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> Galley (TeamMemberList, TeamMember -> Bool) +bulkGetTeamMembers :: UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> Galley r (TeamMemberList, TeamMember -> Bool) bulkGetTeamMembers zusr tid maxResults uids = do unless (length uids <= fromIntegral (fromRange maxResults)) $ throwM bulkGetMemberLimitExceeded @@ -510,12 +554,12 @@ bulkGetTeamMembers zusr tid maxResults uids = do hasMore = ListComplete pure (newTeamMemberList mems hasMore, withPerms) -getTeamMemberH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +getTeamMemberH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do (member, withPerms) <- getTeamMember zusr tid uid pure . json $ teamMemberJson withPerms member -getTeamMember :: UserId -> TeamId -> UserId -> Galley (Public.TeamMember, Public.TeamMember -> Bool) +getTeamMember :: UserId -> TeamId -> UserId -> Galley r (Public.TeamMember, Public.TeamMember -> Bool) getTeamMember zusr tid uid = do zusrMembership <- Data.teamMember tid zusr case zusrMembership of @@ -526,33 +570,45 @@ getTeamMember zusr tid uid = do Nothing -> throwM teamMemberNotFound Just member -> pure (member, withPerms) -internalDeleteBindingTeamWithOneMemberH :: TeamId -> Galley Response +internalDeleteBindingTeamWithOneMemberH :: TeamId -> Galley r Response internalDeleteBindingTeamWithOneMemberH tid = do internalDeleteBindingTeamWithOneMember tid pure (empty & setStatus status202) -uncheckedGetTeamMemberH :: TeamId ::: UserId ::: JSON -> Galley Response +uncheckedGetTeamMemberH :: TeamId ::: UserId ::: JSON -> Galley r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid -uncheckedGetTeamMember :: TeamId -> UserId -> Galley TeamMember +uncheckedGetTeamMember :: TeamId -> UserId -> Galley r TeamMember uncheckedGetTeamMember tid uid = do Data.teamMember tid uid >>= ifNothing teamMemberNotFound -uncheckedGetTeamMembersH :: TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> Galley Response +uncheckedGetTeamMembersH :: TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> Galley r Response uncheckedGetTeamMembersH (tid ::: maxResults ::: _) = do json <$> uncheckedGetTeamMembers tid maxResults -uncheckedGetTeamMembers :: TeamId -> Range 1 HardTruncationLimit Int32 -> Galley TeamMemberList +uncheckedGetTeamMembers :: + TeamId -> + Range 1 HardTruncationLimit Int32 -> + Galley r TeamMemberList uncheckedGetTeamMembers tid maxResults = Data.teamMembersWithLimit tid maxResults -addTeamMemberH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley Response +addTeamMemberH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> + Galley r Response addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do nmem <- fromJsonBody req addTeamMember zusr zcon tid nmem pure empty -addTeamMember :: UserId -> ConnId -> TeamId -> Public.NewTeamMember -> Galley () +addTeamMember :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + Public.NewTeamMember -> + Galley r () addTeamMember zusr zcon tid nmem = do let uid = nmem ^. ntmNewTeamMember . userId Log.debug $ @@ -573,13 +629,20 @@ addTeamMember zusr zcon tid nmem = do void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem memList -- This function is "unchecked" because there is no need to check for user binding (invite only). -uncheckedAddTeamMemberH :: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response +uncheckedAddTeamMemberH :: + Members '[BrigAccess, GundeckAccess] r => + TeamId ::: JsonRequest NewTeamMember ::: JSON -> + Galley r Response uncheckedAddTeamMemberH (tid ::: req ::: _) = do nmem <- fromJsonBody req uncheckedAddTeamMember tid nmem return empty -uncheckedAddTeamMember :: TeamId -> NewTeamMember -> Galley () +uncheckedAddTeamMember :: + Members '[BrigAccess, GundeckAccess] r => + TeamId -> + NewTeamMember -> + Galley r () uncheckedAddTeamMember tid nmem = do mems <- Data.teamMembersForFanout tid (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid @@ -588,14 +651,24 @@ uncheckedAddTeamMember tid nmem = do billingUserIds <- Journal.getBillingUserIds tid $ Just $ newTeamMemberList ((nmem ^. ntmNewTeamMember) : mems ^. teamMembers) (mems ^. teamMemberListType) Journal.teamUpdate tid (sizeBeforeAdd + 1) billingUserIds -updateTeamMemberH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley Response +updateTeamMemberH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> + Galley r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do -- the team member to be updated targetMember <- view ntmNewTeamMember <$> fromJsonBody req updateTeamMember zusr zcon tid targetMember pure empty -updateTeamMember :: UserId -> ConnId -> TeamId -> TeamMember -> Galley () +updateTeamMember :: + forall r. + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + TeamMember -> + Galley r () updateTeamMember zusr zcon tid targetMember = do let targetId = targetMember ^. userId targetPermissions = targetMember ^. permissions @@ -637,14 +710,14 @@ updateTeamMember zusr zcon tid targetMember = do permissionsRole (previousMember ^. permissions) == Just RoleOwner && permissionsRole targetPermissions /= Just RoleOwner - updateJournal :: Team -> TeamMemberList -> Galley () + updateJournal :: Team -> TeamMemberList -> Galley r () updateJournal team mems = do when (team ^. teamBinding == Binding) $ do (TeamSize size) <- BrigTeam.getSize tid billingUserIds <- Journal.getBillingUserIds tid $ Just mems Journal.teamUpdate tid size billingUserIds - updatePeers :: UserId -> Permissions -> TeamMemberList -> Galley () + updatePeers :: UserId -> Permissions -> TeamMemberList -> Galley 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 @@ -658,7 +731,10 @@ updateTeamMember zusr zcon tid targetMember = do let pushPriv = newPushLocal (updatedMembers ^. teamMemberListType) zusr (TeamEvent ePriv) $ privilegedRecipients for_ pushPriv $ \p -> push1 $ p & pushConn .~ Just zcon -deleteTeamMemberH :: UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> Galley Response +deleteTeamMemberH :: + Members '[BrigAccess, ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> + Galley r Response deleteTeamMemberH (zusr ::: zcon ::: tid ::: remove ::: req ::: _) = do mBody <- fromOptionalJsonBody req deleteTeamMember zusr zcon tid remove mBody >>= \case @@ -670,7 +746,14 @@ data TeamMemberDeleteResult | TeamMemberDeleteCompleted -- | 'TeamMemberDeleteData' is only required for binding teams -deleteTeamMember :: UserId -> ConnId -> TeamId -> UserId -> Maybe Public.TeamMemberDeleteData -> Galley TeamMemberDeleteResult +deleteTeamMember :: + Members '[BrigAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + UserId -> + Maybe Public.TeamMemberDeleteData -> + Galley r TeamMemberDeleteResult deleteTeamMember zusr zcon tid remove mBody = do Log.debug $ Log.field "targets" (toByteString remove) @@ -705,7 +788,15 @@ deleteTeamMember zusr zcon tid remove mBody = do pure TeamMemberDeleteCompleted -- This function is "unchecked" because it does not validate that the user has the `RemoveTeamMember` permission. -uncheckedDeleteTeamMember :: UserId -> Maybe ConnId -> TeamId -> UserId -> TeamMemberList -> Galley () +uncheckedDeleteTeamMember :: + forall r. + Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + UserId -> + Maybe ConnId -> + TeamId -> + UserId -> + TeamMemberList -> + Galley r () uncheckedDeleteTeamMember zusr zcon tid remove mems = do now <- liftIO getCurrentTime pushMemberLeaveEvent now @@ -713,13 +804,13 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do removeFromConvsAndPushConvLeaveEvent now where -- notify all team members. - pushMemberLeaveEvent :: UTCTime -> Galley () + pushMemberLeaveEvent :: UTCTime -> Galley r () pushMemberLeaveEvent now = do let e = newEvent MemberLeave tid now & eventData ?~ EdMemberLeave remove let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (mems ^. teamMembers)) push1 $ newPushLocal1 (mems ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ zcon -- notify all conversation members not in this team. - removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Galley () + removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Galley 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 @@ -735,7 +826,7 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do -- 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 () + pushEvent :: Set UserId -> Conv.EventData -> UTCTime -> Data.Conversation -> Galley r () pushEvent exceptTo edata now dc = do localDomain <- viewFederationDomain let qconvId = Qualified (Data.convId dc) localDomain @@ -745,35 +836,41 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do let y = Conv.Event Conv.MemberLeave qconvId qusr now edata for_ (newPushLocal (mems ^. teamMemberListType) zusr (ConvEvent y) (recipient <$> x)) $ \p -> push1 $ p & pushConn .~ zcon - void . forkIO $ void $ External.deliver (bots `zip` repeat y) + External.deliverAsync (bots `zip` repeat y) -getTeamConversations :: UserId -> TeamId -> Galley Public.TeamConversationList +getTeamConversations :: UserId -> TeamId -> Galley r Public.TeamConversationList getTeamConversations zusr tid = do tm <- Data.teamMember tid zusr >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) unless (tm `hasPermission` GetTeamConversations) $ throwErrorDescription (operationDenied GetTeamConversations) Public.newTeamConversationList <$> Data.teamConversations tid -getTeamConversation :: UserId -> TeamId -> ConvId -> Galley Public.TeamConversation +getTeamConversation :: UserId -> TeamId -> ConvId -> Galley r Public.TeamConversation getTeamConversation zusr tid cid = do tm <- Data.teamMember tid zusr >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) unless (tm `hasPermission` GetTeamConversations) $ throwErrorDescription (operationDenied GetTeamConversations) Data.teamConversation tid cid >>= maybe (throwErrorDescriptionType @ConvNotFound) pure -deleteTeamConversation :: UserId -> ConnId -> TeamId -> ConvId -> Galley () +deleteTeamConversation :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + UserId -> + ConnId -> + TeamId -> + ConvId -> + Galley r () deleteTeamConversation zusr zcon _tid cid = do lusr <- qualifyLocal zusr lconv <- qualifyLocal cid void $ API.deleteLocalConversation lusr zcon lconv -getSearchVisibilityH :: UserId ::: TeamId ::: JSON -> Galley Response +getSearchVisibilityH :: UserId ::: TeamId ::: JSON -> Galley r Response getSearchVisibilityH (uid ::: tid ::: _) = do zusrMembership <- Data.teamMember tid uid void $ permissionCheck ViewTeamSearchVisibility zusrMembership json <$> getSearchVisibilityInternal tid -setSearchVisibilityH :: UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley Response +setSearchVisibilityH :: UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do zusrMembership <- Data.teamMember tid uid void $ permissionCheck ChangeTeamSearchVisibility zusrMembership @@ -796,8 +893,8 @@ withTeamIds :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> - (Bool -> [TeamId] -> Galley a) -> - Galley a + (Bool -> [TeamId] -> Galley r a) -> + Galley r a withTeamIds usr range size k = case range of Nothing -> do r <- Data.teamIdsFrom usr Nothing (rcast size) @@ -810,18 +907,17 @@ withTeamIds usr range size k = case range of k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: [UserId] -> Galley () +ensureUnboundUsers :: [UserId] -> Galley r () ensureUnboundUsers uids = do - e <- ask -- We check only 1 team because, by definition, users in binding teams -- can only be part of one team. - ts <- liftIO $ mapConcurrently (evalGalley e . Data.oneUserTeam) uids + ts <- liftGalley0 $ mapConcurrently Data.oneUserTeam uids let teams = toList $ fromList (catMaybes ts) - binds <- liftIO $ mapConcurrently (evalGalley e . Data.teamBinding) teams + binds <- liftGalley0 $ mapConcurrently Data.teamBinding teams when (any ((==) (Just Binding)) binds) $ throwM userBindingExists -ensureNonBindingTeam :: TeamId -> Galley () +ensureNonBindingTeam :: TeamId -> Galley r () ensureNonBindingTeam tid = do team <- Data.team tid >>= ifNothing teamNotFound when ((tdTeam team) ^. teamBinding == Binding) $ @@ -829,7 +925,7 @@ ensureNonBindingTeam tid = do -- ensure that the permissions are not "greater" than the user's copy permissions -- this is used to ensure users cannot "elevate" permissions -ensureNotElevated :: Permissions -> TeamMember -> Galley () +ensureNotElevated :: Permissions -> TeamMember -> Galley r () ensureNotElevated targetPermissions member = unless ( (targetPermissions ^. self) @@ -837,7 +933,7 @@ ensureNotElevated targetPermissions member = ) $ throwM invalidPermissions -ensureNotTooLarge :: TeamId -> Galley TeamSize +ensureNotTooLarge :: Member BrigAccess r => TeamId -> Galley r TeamSize ensureNotTooLarge tid = do o <- view options (TeamSize size) <- BrigTeam.getSize tid @@ -854,19 +950,19 @@ ensureNotTooLarge tid = do -- size unlimited, because we make the assumption that these teams won't turn -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. -ensureNotTooLargeForLegalHold :: TeamId -> Int -> Galley () +ensureNotTooLargeForLegalHold :: Member BrigAccess r => TeamId -> Int -> Galley r () ensureNotTooLargeForLegalHold tid teamSize = do whenM (isLegalHoldEnabledForTeam tid) $ do unlessM (teamSizeBelowLimit teamSize) $ do throwM tooManyTeamMembersOnTeamWithLegalhold -ensureNotTooLargeToActivateLegalHold :: TeamId -> Galley () +ensureNotTooLargeToActivateLegalHold :: Member BrigAccess r => TeamId -> Galley r () ensureNotTooLargeToActivateLegalHold tid = do (TeamSize teamSize) <- BrigTeam.getSize tid unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ do throwM cannotEnableLegalHoldServiceLargeTeam -teamSizeBelowLimit :: Int -> Galley Bool +teamSizeBelowLimit :: Int -> Galley r Bool teamSizeBelowLimit teamSize = do limit <- fromIntegral . fromRange <$> fanoutLimit let withinLimit = teamSize <= limit @@ -877,7 +973,14 @@ teamSizeBelowLimit teamSize = do -- unlimited, see docs of 'ensureNotTooLargeForLegalHold' pure True -addTeamMemberInternal :: TeamId -> Maybe UserId -> Maybe ConnId -> NewTeamMember -> TeamMemberList -> Galley TeamSize +addTeamMemberInternal :: + Members '[BrigAccess, GundeckAccess] r => + TeamId -> + Maybe UserId -> + Maybe ConnId -> + NewTeamMember -> + TeamMemberList -> + Galley r TeamSize addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memList = do Log.debug $ Log.field "targets" (toByteString (new ^. userId)) @@ -908,20 +1011,21 @@ addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memLi -- less warped. This is a work-around because we cannot send events to all of a large team. -- See haddocks of module "Galley.API.TeamNotifications" for details. getTeamNotificationsH :: + Member BrigAccess r => UserId ::: Maybe ByteString {- NotificationId -} ::: Range 1 10000 Int32 ::: JSON -> - Galley Response + Galley r Response getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do since <- parseSince json @Public.QueuedNotificationList <$> APITeamQueue.getTeamNotifications zusr since size where - parseSince :: Galley (Maybe Public.NotificationId) + parseSince :: Galley r (Maybe Public.NotificationId) parseSince = maybe (pure Nothing) (fmap Just . parseUUID) sinceRaw - parseUUID :: ByteString -> Galley Public.NotificationId + parseUUID :: ByteString -> Galley r Public.NotificationId parseUUID raw = maybe (throwM invalidTeamNotificationId) @@ -931,7 +1035,13 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do isV1UUID :: UUID.UUID -> Maybe UUID.UUID isV1UUID u = if UUID.version u == 1 then Just u else Nothing -finishCreateTeam :: Team -> TeamMember -> [TeamMember] -> Maybe ConnId -> Galley () +finishCreateTeam :: + Member GundeckAccess r => + Team -> + TeamMember -> + [TeamMember] -> + Maybe ConnId -> + Galley r () finishCreateTeam team owner others zcon = do let zusr = owner ^. userId for_ (owner : others) $ @@ -941,7 +1051,7 @@ finishCreateTeam team owner others zcon = do let r = membersToRecipients Nothing others push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon -withBindingTeam :: UserId -> (TeamId -> Galley b) -> Galley b +withBindingTeam :: UserId -> (TeamId -> Galley r b) -> Galley r b withBindingTeam zusr callback = do tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound binding <- Data.teamBinding tid >>= ifNothing teamNotFound @@ -949,31 +1059,31 @@ withBindingTeam zusr callback = do Binding -> callback tid NonBinding -> throwM nonBindingTeam -getBindingTeamIdH :: UserId -> Galley Response +getBindingTeamIdH :: UserId -> Galley r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: UserId -> Galley TeamId +getBindingTeamId :: UserId -> Galley r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: UserId -> Galley Response +getBindingTeamMembersH :: UserId -> Galley r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers -getBindingTeamMembers :: UserId -> Galley TeamMemberList +getBindingTeamMembers :: UserId -> Galley r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> Data.teamMembersForFanout tid -canUserJoinTeamH :: TeamId -> Galley Response +canUserJoinTeamH :: Member BrigAccess r => TeamId -> Galley r Response canUserJoinTeamH tid = canUserJoinTeam tid >> pure empty -- This could be extended for more checks, for now we test only legalhold -canUserJoinTeam :: TeamId -> Galley () +canUserJoinTeam :: Member BrigAccess r => TeamId -> Galley r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) -getTeamSearchVisibilityAvailableInternal :: TeamId -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +getTeamSearchVisibilityAvailableInternal :: TeamId -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal tid = do -- TODO: This is just redundant given there is a decent default defConfig <- do @@ -986,38 +1096,38 @@ getTeamSearchVisibilityAvailableInternal tid = do <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid -- | Modify and get visibility type for a team (internal, no user permission checks) -getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley Response +getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley r Response getSearchVisibilityInternalH (tid ::: _) = json <$> getSearchVisibilityInternal tid -getSearchVisibilityInternal :: TeamId -> Galley TeamSearchVisibilityView +getSearchVisibilityInternal :: TeamId -> Galley r TeamSearchVisibilityView getSearchVisibilityInternal = fmap TeamSearchVisibilityView . SearchVisibilityData.getSearchVisibility -setSearchVisibilityInternalH :: TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley Response +setSearchVisibilityInternalH :: TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley r Response setSearchVisibilityInternalH (tid ::: req ::: _) = do setSearchVisibilityInternal tid =<< fromJsonBody req pure noContent -setSearchVisibilityInternal :: TeamId -> TeamSearchVisibilityView -> Galley () +setSearchVisibilityInternal :: TeamId -> TeamSearchVisibilityView -> Galley r () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do status <- getTeamSearchVisibilityAvailableInternal tid unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ throwM teamSearchVisibilityNotEnabled SearchVisibilityData.setSearchVisibility tid searchVisibility -userIsTeamOwnerH :: TeamId ::: UserId ::: JSON -> Galley Response +userIsTeamOwnerH :: TeamId ::: UserId ::: JSON -> Galley r Response userIsTeamOwnerH (tid ::: uid ::: _) = do userIsTeamOwner tid uid >>= \case True -> pure empty False -> throwM accessDenied -userIsTeamOwner :: TeamId -> UserId -> Galley Bool +userIsTeamOwner :: TeamId -> UserId -> Galley r Bool userIsTeamOwner tid uid = do let asking = uid isTeamOwner . fst <$> getTeamMember asking tid uid -- Queues a team for async deletion -queueTeamDeletion :: TeamId -> UserId -> Maybe ConnId -> Galley () +queueTeamDeletion :: TeamId -> UserId -> Maybe ConnId -> Galley r () queueTeamDeletion tid zusr zcon = do q <- view deleteQueue ok <- Q.tryPush q (TeamItem tid zusr zcon) diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index f0a25d91ebd..b34917162d3 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -60,6 +60,7 @@ import Galley.App import qualified Galley.Data as Data import qualified Galley.Data.SearchVisibility as SearchVisibilityData import qualified Galley.Data.TeamFeatures as TeamFeatures +import Galley.Effects import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush, push1) import Galley.Options import Galley.Types.Teams hiding (newTeam) @@ -83,12 +84,12 @@ data DoAuth = DoAuth UserId | DontDoAuth -- | For team-settings, to administrate team feature configuration. Here we have an admin uid -- and a team id, but no uid of the member for which the feature config holds. getFeatureStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. Public.KnownTeamFeatureName a => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureStatus getter doauth tid = do case doauth of DoAuth uid -> do @@ -100,13 +101,13 @@ getFeatureStatus getter doauth tid = do -- | For team-settings, like 'getFeatureStatus'. setFeatureStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. Public.KnownTeamFeatureName a => - (TeamId -> Public.TeamFeatureStatus a -> Galley (Public.TeamFeatureStatus a)) -> + (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> Public.TeamFeatureStatus a -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) setFeatureStatus setter doauth tid status = do case doauth of DoAuth uid -> do @@ -118,11 +119,11 @@ setFeatureStatus setter doauth tid status = do -- | For individual users to get feature config for their account (personal or team). getFeatureConfig :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. Public.KnownTeamFeatureName a => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> UserId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureConfig getter zusr = do mbTeam <- Data.oneUserTeam zusr case mbTeam of @@ -133,17 +134,17 @@ getFeatureConfig getter zusr = do assertTeamExists tid getter (Right tid) -getAllFeatureConfigs :: UserId -> Galley AllFeatureConfigs +getAllFeatureConfigs :: UserId -> Galley r AllFeatureConfigs getAllFeatureConfigs zusr = do mbTeam <- Data.oneUserTeam zusr zusrMembership <- maybe (pure Nothing) (flip Data.teamMember zusr) mbTeam let getStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a) ) => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> - Galley (Text, Aeson.Value) + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + Galley r (Text, Aeson.Value) getStatus getter = do when (isJust mbTeam) $ do void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership @@ -164,11 +165,11 @@ getAllFeatureConfigs zusr = do getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal ] -getAllFeaturesH :: UserId ::: TeamId ::: JSON -> Galley Response +getAllFeaturesH :: UserId ::: TeamId ::: JSON -> Galley r Response getAllFeaturesH (uid ::: tid ::: _) = json <$> getAllFeatures uid tid -getAllFeatures :: UserId -> TeamId -> Galley Aeson.Value +getAllFeatures :: UserId -> TeamId -> Galley r Aeson.Value getAllFeatures uid tid = do Aeson.object <$> sequence @@ -184,34 +185,38 @@ getAllFeatures uid tid = do ] where getStatus :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a) ) => - (GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus a)) -> - Galley (Text, Aeson.Value) + (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> + Galley r (Text, Aeson.Value) getStatus getter = do status <- getFeatureStatus @a getter (DoAuth uid) tid let feature = Public.knownTeamFeatureName @a pure $ (cs (toByteString' feature) Aeson..= status) getFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName). + forall (a :: Public.TeamFeatureName) r. (Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, TeamFeatures.HasStatusCol a) => - Galley Public.TeamFeatureStatusValue -> + Galley r Public.TeamFeatureStatusValue -> TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureStatusNoConfig getDefault tid = do defaultStatus <- Public.TeamFeatureStatusNoConfig <$> getDefault fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid setFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName). - (Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, TeamFeatures.HasStatusCol a) => - (Public.TeamFeatureStatusValue -> TeamId -> Galley ()) -> + forall (a :: Public.TeamFeatureName) r. + ( Public.KnownTeamFeatureName a, + Public.FeatureHasNoConfig a, + TeamFeatures.HasStatusCol a, + Member GundeckAccess r + ) => + (Public.TeamFeatureStatusValue -> TeamId -> Galley r ()) -> TeamId -> Public.TeamFeatureStatus a -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) setFeatureStatusNoConfig applyState tid status = do applyState (Public.tfwoStatus status) tid newStatus <- TeamFeatures.setFeatureStatusNoConfig @a tid status @@ -223,24 +228,28 @@ setFeatureStatusNoConfig applyState tid status = do -- the feature flag, so that we get more type safety. type GetFeatureInternalParam = Either (Maybe UserId) TeamId -getSSOStatusInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) +getSSOStatusInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) getSSOStatusInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @'Public.TeamFeatureSSO getDef) where - getDef :: Galley Public.TeamFeatureStatusValue + getDef :: Galley r Public.TeamFeatureStatusValue getDef = view (options . optSettings . setFeatureFlags . flagSSO) <&> \case FeatureSSOEnabledByDefault -> Public.TeamFeatureEnabled FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled -setSSOStatusInternal :: TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) +setSSOStatusInternal :: + Member GundeckAccess r => + TeamId -> + (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case Public.TeamFeatureDisabled -> const (throwM disableSsoNotImplemented) Public.TeamFeatureEnabled -> const (pure ()) -getTeamSearchVisibilityAvailableInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +getTeamSearchVisibilityAvailableInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -251,12 +260,16 @@ getTeamSearchVisibilityAvailableInternal = FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled -setTeamSearchVisibilityAvailableInternal :: TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +setTeamSearchVisibilityAvailableInternal :: + Member GundeckAccess r => + TeamId -> + (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility $ \case Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility Public.TeamFeatureEnabled -> const (pure ()) -getValidateSAMLEmailsInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) +getValidateSAMLEmailsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) getValidateSAMLEmailsInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -267,10 +280,14 @@ getValidateSAMLEmailsInternal = -- Use getFeatureStatusWithDefault getDef = pure Public.TeamFeatureDisabled -setValidateSAMLEmailsInternal :: TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) +setValidateSAMLEmailsInternal :: + Member GundeckAccess r => + TeamId -> + (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () -getDigitalSignaturesInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) +getDigitalSignaturesInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) getDigitalSignaturesInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -281,10 +298,14 @@ getDigitalSignaturesInternal = -- Use getFeatureStatusWithDefault getDef = pure Public.TeamFeatureDisabled -setDigitalSignaturesInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) +setDigitalSignaturesInternal :: + Member GundeckAccess r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () -getLegalholdStatusInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) +getLegalholdStatusInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = pure $ Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled getLegalholdStatusInternal (Right tid) = do @@ -292,7 +313,11 @@ getLegalholdStatusInternal (Right tid) = do True -> Public.TeamFeatureStatusNoConfig Public.TeamFeatureEnabled False -> Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled -setLegalholdStatusInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) +setLegalholdStatusInternal :: + Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> + Galley 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. @@ -314,42 +339,46 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do ensureNotTooLargeToActivateLegalHold tid TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status -getFileSharingInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) +getFileSharingInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) getFileSharingInternal = getFeatureStatusWithDefaultConfig @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just getFeatureStatusWithDefaultConfig :: - forall (a :: TeamFeatureName). + forall (a :: TeamFeatureName) r. (KnownTeamFeatureName a, TeamFeatures.HasStatusCol a, FeatureHasNoConfig a) => Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus a)) -> Maybe TeamId -> - Galley (Public.TeamFeatureStatus a) + Galley r (Public.TeamFeatureStatus a) getFeatureStatusWithDefaultConfig lens' = maybe (Public.TeamFeatureStatusNoConfig <$> getDef) (getFeatureStatusNoConfig @a getDef) where - getDef :: Galley Public.TeamFeatureStatusValue + getDef :: Galley r Public.TeamFeatureStatusValue getDef = view (options . optSettings . setFeatureFlags . lens') <&> Public.tfwoStatus . view unDefaults -setFileSharingInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) +setFileSharingInternal :: + Member GundeckAccess r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) setFileSharingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () -getAppLockInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) +getAppLockInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) getAppLockInternal mbtid = do Defaults defaultStatus <- view (options . optSettings . setFeatureFlags . flagAppLockDefaults) status <- join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) pure $ fromMaybe defaultStatus status -setAppLockInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) +setAppLockInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ throwM inactivityTimeoutTooLow TeamFeatures.setApplockFeatureStatus tid status -getClassifiedDomainsInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) +getClassifiedDomainsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) getClassifiedDomainsInternal _mbtid = do globalConfig <- view (options . optSettings . setFeatureFlags . flagClassifiedDomains) let config = globalConfig @@ -358,7 +387,9 @@ getClassifiedDomainsInternal _mbtid = do Public.TeamFeatureStatusWithConfig Public.TeamFeatureDisabled (Public.TeamFeatureClassifiedDomainsConfig []) Public.TeamFeatureEnabled -> config -getConferenceCallingInternal :: GetFeatureInternalParam -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) +getConferenceCallingInternal :: + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do getFeatureConfigViaAccount @'Public.TeamFeatureConferenceCalling uid getConferenceCallingInternal (Left Nothing) = do @@ -366,10 +397,14 @@ getConferenceCallingInternal (Left Nothing) = do getConferenceCallingInternal (Right tid) = do getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) -setConferenceCallingInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> Galley (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) +setConferenceCallingInternal :: + Member GundeckAccess r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) setConferenceCallingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () -pushFeatureConfigEvent :: TeamId -> Event.Event -> Galley () +pushFeatureConfigEvent :: Member GundeckAccess r => TeamId -> Event.Event -> Galley r () pushFeatureConfigEvent tid event = do memList <- Data.teamMembersForFanout tid when ((memList ^. teamMemberListType) == ListTruncated) $ do @@ -385,7 +420,10 @@ pushFeatureConfigEvent tid event = do -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) -getFeatureConfigViaAccount :: flag ~ 'Public.TeamFeatureConferenceCalling => UserId -> Galley (Public.TeamFeatureStatus flag) +getFeatureConfigViaAccount :: + (flag ~ 'Public.TeamFeatureConferenceCalling) => + UserId -> + Galley r (Public.TeamFeatureStatus flag) getFeatureConfigViaAccount uid = do mgr <- asks (^. manager) brigep <- asks (^. brig) @@ -393,7 +431,7 @@ getFeatureConfigViaAccount uid = do where handleResp :: Either Client.ClientError Public.TeamFeatureStatusNoConfig -> - Galley Public.TeamFeatureStatusNoConfig + Galley r Public.TeamFeatureStatusNoConfig handleResp (Right cfg) = pure cfg handleResp (Left errmsg) = throwM . internalErrorWithDescription . cs . show $ errmsg diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index 7b6128a4414..08edac5eb25 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -51,6 +51,7 @@ 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.Intra.User as Intra import Galley.Types.Teams hiding (newTeam) import Gundeck.Types.Notification @@ -59,10 +60,11 @@ import Network.HTTP.Types import Network.Wai.Utilities getTeamNotifications :: + Member BrigAccess r => UserId -> Maybe NotificationId -> Range 1 10000 Int32 -> - Galley QueuedNotificationList + Galley r QueuedNotificationList getTeamNotifications zusr since size = do tid :: TeamId <- do mtid <- (userTeam . accountUser =<<) <$> Intra.getUser zusr @@ -75,7 +77,7 @@ getTeamNotifications zusr since size = do (DataTeamQueue.resultHasMore page) Nothing -pushTeamEvent :: TeamId -> Event -> Galley () +pushTeamEvent :: TeamId -> Event -> Galley r () pushTeamEvent tid evt = do nid <- mkNotificationId DataTeamQueue.add 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 5c3579c9100..dee504abe4f 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -95,6 +95,7 @@ import Galley.App import qualified Galley.Data as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) +import Galley.Effects import qualified Galley.External as External import qualified Galley.Intra.Client as Intra import Galley.Intra.Push @@ -109,12 +110,11 @@ import Galley.Types.Teams hiding (Event, EventData (..), EventType (..), self) import Galley.Types.UserList import Galley.Validation import Gundeck.Types.Push.V2 (RecipientClients (..)) -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (and, failure, setStatus, _1, _2) import Network.Wai.Utilities -import UnliftIO (pooledForConcurrentlyN) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action import qualified Wire.API.Conversation.Code as Public @@ -138,21 +138,21 @@ import Wire.API.ServantProto (RawProto (..)) import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client -acceptConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response +acceptConvH :: Member GundeckAccess r => UserId ::: Maybe ConnId ::: ConvId -> Galley r Response acceptConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> acceptConv usr conn cnv -acceptConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation +acceptConv :: Member GundeckAccess r => UserId -> Maybe ConnId -> ConvId -> Galley r Conversation acceptConv usr conn cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) conv' <- acceptOne2One usr conv conn conversationView usr conv' -blockConvH :: UserId ::: ConvId -> Galley Response +blockConvH :: UserId ::: ConvId -> Galley r Response blockConvH (zusr ::: cnv) = empty <$ blockConv zusr cnv -blockConv :: UserId -> ConvId -> Galley () +blockConv :: UserId -> ConvId -> Galley r () blockConv zusr cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ @@ -161,11 +161,19 @@ blockConv zusr cnv = do let mems = Data.convLocalMembers conv when (zusr `isMember` mems) $ Data.removeMember zusr cnv -unblockConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response +unblockConvH :: + Member GundeckAccess r => + UserId ::: Maybe ConnId ::: ConvId -> + Galley r Response unblockConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> unblockConv usr conn cnv -unblockConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation +unblockConv :: + Member GundeckAccess r => + UserId -> + Maybe ConnId -> + ConvId -> + Galley r Conversation unblockConv usr conn cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ @@ -182,11 +190,12 @@ handleUpdateResult = \case Unchanged -> empty & setStatus status204 updateConversationAccess :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationAccess usr con qcnv update = do lusr <- qualifyLocal usr let doUpdate = @@ -197,22 +206,24 @@ updateConversationAccess usr con qcnv update = do doUpdate qcnv lusr con update updateConversationAccessUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationAccessUnqualified usr zcon cnv update = do lusr <- qualifyLocal usr lcnv <- qualifyLocal cnv updateLocalConversationAccess lcnv lusr zcon update updateLocalConversationAccess :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> ConnId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateLocalConversationAccess lcnv lusr con target = getUpdateResult . updateLocalConversation lcnv (qUntagged lusr) (Just con) @@ -224,14 +235,16 @@ updateRemoteConversationAccess :: Local UserId -> ConnId -> Public.ConversationAccessData -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateRemoteConversationAccess _ _ _ _ = throwM federationNotImplemented performAccessUpdateAction :: + forall r. + Members '[BrigAccess, BotAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => Qualified UserId -> Data.Conversation -> ConversationAccessData -> - MaybeT Galley () + MaybeT (Galley r) () performAccessUpdateAction qusr conv target = do lcnv <- qualifyLocal (Data.convId conv) guard $ Data.convAccessData conv /= target @@ -252,7 +265,7 @@ performAccessUpdateAction qusr conv target = do -- Update Cassandra lift $ Data.updateConversationAccess (tUnqualified lcnv) target - lift . void . forkIO $ do + lift . fireAndForget $ do -- Remove bots traverse_ (deleteBot (tUnqualified lcnv)) (map botMemId (toList (bmBots toRemove))) @@ -265,7 +278,7 @@ performAccessUpdateAction qusr conv target = do void . runMaybeT $ performAction qusr conv action notifyConversationMetadataUpdate qusr Nothing lcnv current' action where - filterActivated :: BotsAndMembers -> Galley BotsAndMembers + filterActivated :: BotsAndMembers -> Galley r BotsAndMembers filterActivated bm | ( Data.convAccessRole conv > ActivatedAccessRole && cupAccessRole target <= ActivatedAccessRole @@ -275,7 +288,7 @@ performAccessUpdateAction qusr conv target = do pure $ bm {bmLocals = Set.fromList activated} | otherwise = pure bm - filterTeammates :: BotsAndMembers -> Galley BotsAndMembers + filterTeammates :: BotsAndMembers -> Galley r BotsAndMembers filterTeammates bm = do -- In a team-only conversation we also want to remove bots and guests case (cupAccessRole target, Data.convTeam conv) of @@ -291,11 +304,12 @@ performAccessUpdateAction qusr conv target = do _ -> pure bm updateConversationReceiptMode :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationReceiptMode usr zcon qcnv update = do lusr <- qualifyLocal usr let doUpdate = @@ -306,22 +320,24 @@ updateConversationReceiptMode usr zcon qcnv update = do doUpdate qcnv lusr zcon update updateConversationReceiptModeUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationReceiptModeUnqualified usr zcon cnv update = do lusr <- qualifyLocal usr lcnv <- qualifyLocal cnv updateLocalConversationReceiptMode lcnv lusr zcon update updateLocalConversationReceiptMode :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateLocalConversationReceiptMode lcnv lusr con update = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) $ @@ -332,26 +348,28 @@ updateRemoteConversationReceiptMode :: Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateRemoteConversationReceiptMode _ _ _ _ = throwM federationNotImplemented updateConversationMessageTimerUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationMessageTimerUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationMessageTimerUnqualified usr zcon cnv update = do lusr <- qualifyLocal usr lcnv <- qualifyLocal cnv updateLocalConversationMessageTimer lusr zcon lcnv update updateConversationMessageTimer :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationMessageTimerUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateConversationMessageTimer usr zcon qcnv update = do lusr <- qualifyLocal usr foldQualified @@ -362,32 +380,44 @@ updateConversationMessageTimer usr zcon qcnv update = do update updateLocalConversationMessageTimer :: + Members UpdateConversationActions r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationMessageTimerUpdate -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) updateLocalConversationMessageTimer lusr con lcnv update = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionMessageTimerUpdate update deleteLocalConversation :: + Members UpdateConversationActions r => Local UserId -> ConnId -> Local ConvId -> - Galley (UpdateResult Event) + Galley r (UpdateResult Event) deleteLocalConversation lusr con lcnv = getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationActionDelete +type UpdateConversationActions = + '[ BotAccess, + BrigAccess, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess + ] + -- | Update a local conversation, and notify all local and remote members. updateLocalConversation :: + Members UpdateConversationActions r => Local ConvId -> Qualified UserId -> Maybe ConnId -> ConversationAction -> - MaybeT Galley Event + MaybeT (Galley r) Event updateLocalConversation lcnv qusr con action = do -- retrieve conversation (conv, self) <- @@ -418,10 +448,11 @@ getUpdateResult = fmap (maybe Unchanged Updated) . runMaybeT -- | Perform a conversation action, and return extra notification targets and -- an updated action. performAction :: + Members UpdateConversationActions r => Qualified UserId -> Data.Conversation -> ConversationAction -> - MaybeT Galley (BotsAndMembers, ConversationAction) + MaybeT (Galley r) (BotsAndMembers, ConversationAction) performAction qusr conv action = case action of ConversationActionAddMembers members role -> performAddMemberAction qusr conv members role @@ -456,7 +487,10 @@ performAction qusr conv action = case action of Just tid -> Data.removeTeamConv tid cid pure (mempty, action) -addCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response +addCodeH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: ConvId -> + Galley r Response addCodeH (usr ::: zcon ::: cnv) = addCode usr zcon cnv <&> \case CodeAdded event -> json event & setStatus status201 @@ -466,7 +500,13 @@ data AddCodeResult = CodeAdded Public.Event | CodeAlreadyExisted Public.ConversationCode -addCode :: UserId -> ConnId -> ConvId -> Galley AddCodeResult +addCode :: + forall r. + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Galley r AddCodeResult addCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain @@ -490,16 +530,24 @@ addCode usr zcon cnv = do conversationCode <- createCode code pure $ CodeAlreadyExisted conversationCode where - createCode :: Code -> Galley ConversationCode + createCode :: Code -> Galley r ConversationCode createCode code = do urlPrefix <- view $ options . optSettings . setConversationCodeURI return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix -rmCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response +rmCodeH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: ConvId -> + Galley r Response rmCodeH (usr ::: zcon ::: cnv) = setStatus status200 . json <$> rmCode usr zcon cnv -rmCode :: UserId -> ConnId -> ConvId -> Galley Public.Event +rmCode :: + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Galley r Public.Event rmCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain @@ -515,11 +563,11 @@ rmCode usr zcon cnv = do pushConversationEvent (Just zcon) event (map lmId users) bots pure event -getCodeH :: UserId ::: ConvId -> Galley Response +getCodeH :: UserId ::: ConvId -> Galley r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv -getCode :: UserId -> ConvId -> Galley Public.ConversationCode +getCode :: UserId -> ConvId -> Galley r Public.ConversationCode getCode usr cnv = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) ensureAccess conv CodeAccess @@ -530,40 +578,62 @@ getCode usr cnv = do >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) returnCode c -returnCode :: Code -> Galley Public.ConversationCode +returnCode :: Code -> Galley r Public.ConversationCode returnCode c = do urlPrefix <- view $ options . optSettings . setConversationCodeURI pure $ Public.mkConversationCode (codeKey c) (codeValue c) urlPrefix -checkReusableCodeH :: JsonRequest Public.ConversationCode -> Galley Response +checkReusableCodeH :: JsonRequest Public.ConversationCode -> Galley r Response checkReusableCodeH req = do convCode <- fromJsonBody req checkReusableCode convCode pure empty -checkReusableCode :: Public.ConversationCode -> Galley () +checkReusableCode :: Public.ConversationCode -> Galley r () checkReusableCode convCode = void $ verifyReusableCode convCode -joinConversationByReusableCodeH :: UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> Galley Response +joinConversationByReusableCodeH :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> + Galley r Response joinConversationByReusableCodeH (zusr ::: zcon ::: req) = do convCode <- fromJsonBody req handleUpdateResult <$> joinConversationByReusableCode zusr zcon convCode -joinConversationByReusableCode :: UserId -> ConnId -> Public.ConversationCode -> Galley (UpdateResult Event) +joinConversationByReusableCode :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.ConversationCode -> + Galley r (UpdateResult Event) joinConversationByReusableCode zusr zcon convCode = do c <- verifyReusableCode convCode joinConversation zusr zcon (codeConversation c) CodeAccess -joinConversationByIdH :: UserId ::: ConnId ::: ConvId ::: JSON -> Galley Response +joinConversationByIdH :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: ConvId ::: JSON -> + Galley r Response joinConversationByIdH (zusr ::: zcon ::: cnv ::: _) = handleUpdateResult <$> joinConversationById zusr zcon cnv -joinConversationById :: UserId -> ConnId -> ConvId -> Galley (UpdateResult Event) +joinConversationById :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Galley r (UpdateResult Event) joinConversationById zusr zcon cnv = joinConversation zusr zcon cnv LinkAccess -joinConversation :: UserId -> ConnId -> ConvId -> Access -> Galley (UpdateResult Event) +joinConversation :: + Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + ConvId -> + Access -> + Galley r (UpdateResult Event) joinConversation zusr zcon cnv access = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv @@ -592,7 +662,7 @@ addMembersToLocalConversation :: Local ConvId -> UserList UserId -> RoleName -> - MaybeT Galley (BotsAndMembers, ConversationAction) + MaybeT (Galley r) (BotsAndMembers, ConversationAction) addMembersToLocalConversation lcnv users role = do (lmems, rmems) <- lift $ Data.addMembers lcnv (fmap (,role) users) neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users @@ -600,11 +670,13 @@ addMembersToLocalConversation lcnv users role = do pure (bmFromMembers lmems rmems, action) performAddMemberAction :: + forall r. + Members UpdateConversationActions r => Qualified UserId -> Data.Conversation -> NonEmpty (Qualified UserId) -> RoleName -> - MaybeT Galley (BotsAndMembers, ConversationAction) + MaybeT (Galley r) (BotsAndMembers, ConversationAction) performAddMemberAction qusr conv invited role = do lcnv <- lift $ qualifyLocal (Data.convId conv) let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited @@ -619,7 +691,7 @@ performAddMemberAction qusr conv invited role = do where userIsMember u = (^. userId . to (== u)) - checkLocals :: Local ConvId -> Maybe TeamId -> [UserId] -> Galley () + checkLocals :: Local ConvId -> Maybe TeamId -> [UserId] -> Galley r () checkLocals lcnv (Just tid) newUsers = do tms <- Data.teamMembersLimited tid newUsers let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers @@ -632,7 +704,7 @@ performAddMemberAction qusr conv invited role = do ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) ensureConnectedOrSameTeam qusr newUsers - checkRemotes :: [Remote UserId] -> Galley () + checkRemotes :: [Remote UserId] -> Galley r () checkRemotes remotes = do -- if federator is not configured, we fail early, so we avoid adding -- remote members to the database @@ -649,7 +721,7 @@ performAddMemberAction qusr conv invited role = do qusr remotes - checkLHPolicyConflictsLocal :: Local ConvId -> [UserId] -> Galley () + checkLHPolicyConflictsLocal :: Local ConvId -> [UserId] -> Galley r () checkLHPolicyConflictsLocal lcnv newUsers = do let convUsers = Data.convLocalMembers conv @@ -682,16 +754,27 @@ performAddMemberAction qusr conv invited role = do ConversationActionRemoveMembers (pure qvictim) else throwErrorDescriptionType @MissingLegalholdConsent - checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley () + checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley r () checkLHPolicyConflictsRemote _remotes = pure () addMembersUnqualified :: - UserId -> ConnId -> ConvId -> Public.Invite -> Galley (UpdateResult Event) + Members UpdateConversationActions r => + 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) -addMembers :: UserId -> ConnId -> ConvId -> Public.InviteQualified -> Galley (UpdateResult Event) +addMembers :: + Members UpdateConversationActions r => + UserId -> + ConnId -> + ConvId -> + Public.InviteQualified -> + Galley r (UpdateResult Event) addMembers zusr zcon cnv (Public.InviteQualified users role) = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv @@ -699,7 +782,13 @@ addMembers zusr zcon cnv (Public.InviteQualified users role) = do updateLocalConversation lcnv (qUntagged lusr) (Just zcon) $ ConversationActionAddMembers users role -updateSelfMember :: UserId -> ConnId -> Qualified ConvId -> Public.MemberUpdate -> Galley () +updateSelfMember :: + Members '[GundeckAccess, ExternalAccess] r => + UserId -> + ConnId -> + Qualified ConvId -> + Public.MemberUpdate -> + Galley r () updateSelfMember zusr zcon qcnv update = do lusr <- qualifyLocal zusr exists <- foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr @@ -727,18 +816,25 @@ updateSelfMember zusr zcon qcnv update = do misConvRoleName = Nothing } -updateUnqualifiedSelfMember :: UserId -> ConnId -> ConvId -> Public.MemberUpdate -> Galley () +updateUnqualifiedSelfMember :: + Members UpdateConversationActions r => + UserId -> + ConnId -> + ConvId -> + Public.MemberUpdate -> + Galley r () updateUnqualifiedSelfMember zusr zcon cnv update = do lcnv <- qualifyLocal cnv updateSelfMember zusr zcon (qUntagged lcnv) update updateOtherMemberUnqualified :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMemberUnqualified zusr zcon cnv victim update = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv @@ -746,24 +842,26 @@ updateOtherMemberUnqualified zusr zcon cnv victim update = do updateOtherMemberLocalConv lcnv lusr zcon (qUntagged lvictim) update updateOtherMember :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMember zusr zcon qcnv qvictim update = do lusr <- qualifyLocal zusr let doUpdate = foldQualified lusr updateOtherMemberLocalConv updateOtherMemberRemoteConv doUpdate qcnv lusr zcon qvictim update updateOtherMemberLocalConv :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do when (qUntagged lusr == qvictim) $ throwM invalidTargetUserOp @@ -776,31 +874,39 @@ updateOtherMemberRemoteConv :: ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> - Galley () + Galley r () updateOtherMemberRemoteConv _ _ _ _ _ = throwM federationNotImplemented -removeMemberUnqualified :: UserId -> ConnId -> ConvId -> UserId -> Galley RemoveFromConversationResponse +removeMemberUnqualified :: + Members UpdateConversationActions r => + 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) removeMemberQualified :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Qualified UserId -> - Galley RemoveFromConversationResponse + Galley r RemoveFromConversationResponse removeMemberQualified zusr con qcnv victim = do lusr <- qualifyLocal zusr foldQualified lusr removeMemberFromLocalConv removeMemberFromRemoteConv qcnv lusr (Just con) victim removeMemberFromRemoteConv :: + Member FederatorAccess r => Remote ConvId -> Local UserId -> Maybe ConnId -> Qualified UserId -> - Galley RemoveFromConversationResponse + Galley r RemoveFromConversationResponse removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim | qUntagged lusr == victim = do @@ -820,7 +926,7 @@ removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim performRemoveMemberAction :: Data.Conversation -> [Qualified UserId] -> - MaybeT Galley () + MaybeT (Galley r) () performRemoveMemberAction conv victims = do loc <- qualifyLocal () let presentVictims = filter (isConvMember loc conv) victims @@ -832,11 +938,12 @@ performRemoveMemberAction conv victims = do -- | Remove a member from a local conversation. removeMemberFromLocalConv :: + Members UpdateConversationActions r => Local ConvId -> Local UserId -> Maybe ConnId -> Qualified UserId -> - Galley RemoveFromConversationResponse + Galley r RemoveFromConversationResponse removeMemberFromLocalConv lcnv lusr con victim = -- FUTUREWORK: actually return errors as part of the response instead of throwing fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) @@ -854,24 +961,39 @@ data OtrResult | OtrUnknownClient !Public.UnknownClient | OtrConversationNotFound !Public.ConvNotFound -handleOtrResult :: OtrResult -> Galley Response +handleOtrResult :: OtrResult -> Galley r Response handleOtrResult = \case OtrSent m -> pure $ json m & setStatus status201 OtrMissingRecipients m -> pure $ json m & setStatus status412 OtrUnknownClient _ -> throwErrorDescriptionType @UnknownClient OtrConversationNotFound _ -> throwErrorDescriptionType @ConvNotFound -postBotMessageH :: BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> Galley Response +postBotMessageH :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> + Galley r Response postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message handleOtrResult =<< postBotMessage zbot zcnv val' message -postBotMessage :: BotId -> ConvId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> Galley OtrResult +postBotMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + BotId -> + ConvId -> + Public.OtrFilterMissing -> + Public.NewOtrMessage -> + Galley r OtrResult postBotMessage zbot zcnv val message = postNewOtrMessage Bot (botUserId zbot) Nothing zcnv val message -postProteusMessage :: UserId -> ConnId -> Qualified ConvId -> RawProto Public.QualifiedNewOtrMessage -> Galley (Public.PostOtrResponse Public.MessageSendingStatus) +postProteusMessage :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + UserId -> + ConnId -> + Qualified ConvId -> + RawProto Public.QualifiedNewOtrMessage -> + Galley r (Public.PostOtrResponse Public.MessageSendingStatus) postProteusMessage zusr zcon conv msg = do localDomain <- viewFederationDomain let sender = Qualified zusr localDomain @@ -879,7 +1001,15 @@ postProteusMessage zusr zcon conv msg = do then postRemoteOtrMessage sender conv (rpRaw msg) else postQualifiedOtrMessage User sender (Just zcon) (qUnqualified conv) (rpValue msg) -postOtrMessageUnqualified :: UserId -> ConnId -> ConvId -> Maybe Public.IgnoreMissing -> Maybe Public.ReportMissing -> Public.NewOtrMessage -> Galley (Public.PostOtrResponse Public.ClientMismatch) +postOtrMessageUnqualified :: + Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + 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 @@ -906,19 +1036,31 @@ postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do unqualify localDomain <$> postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage -postProtoOtrBroadcastH :: UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> Galley Response +postProtoOtrBroadcastH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> + Galley r Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do message <- Public.protoToNewOtrMessage <$> fromProtoBody req let val' = allowOtrFilterMissingInBody val message handleOtrResult =<< postOtrBroadcast zusr zcon val' message -postOtrBroadcastH :: UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> Galley Response +postOtrBroadcastH :: + Members '[BrigAccess, GundeckAccess] r => + UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> + Galley r Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do message <- fromJsonBody req let val' = allowOtrFilterMissingInBody val message handleOtrResult =<< postOtrBroadcast zusr zcon val' message -postOtrBroadcast :: UserId -> ConnId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> Galley OtrResult +postOtrBroadcast :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.OtrFilterMissing -> + Public.NewOtrMessage -> + Galley r OtrResult postOtrBroadcast zusr zcon = postNewOtrBroadcast zusr (Just zcon) -- internal OTR helpers @@ -932,7 +1074,13 @@ allowOtrFilterMissingInBody val (NewOtrMessage _ _ _ _ _ _ mrepmiss) = case mrep Just uids -> OtrReportMissing $ Set.fromList uids -- | bots are not supported on broadcast -postNewOtrBroadcast :: UserId -> Maybe ConnId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postNewOtrBroadcast :: + Members '[BrigAccess, GundeckAccess] r => + UserId -> + Maybe ConnId -> + OtrFilterMissing -> + NewOtrMessage -> + Galley r OtrResult postNewOtrBroadcast usr con val msg = do localDomain <- viewFederationDomain let qusr = Qualified usr localDomain @@ -943,7 +1091,15 @@ postNewOtrBroadcast usr con val msg = do let (_, toUsers) = foldr (newMessage qusr con Nothing msg now) ([], []) rs pushSome (catMaybes toUsers) -postNewOtrMessage :: UserType -> UserId -> Maybe ConnId -> ConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postNewOtrMessage :: + Members '[BotAccess, BrigAccess, ExternalAccess, GundeckAccess] r => + UserType -> + UserId -> + Maybe ConnId -> + ConvId -> + OtrFilterMissing -> + NewOtrMessage -> + Galley r OtrResult postNewOtrMessage utype usr con cnv val msg = do localDomain <- viewFederationDomain let qusr = Qualified usr localDomain @@ -954,9 +1110,7 @@ postNewOtrMessage utype usr con cnv val msg = do withValidOtrRecipients utype usr sender cnv recvrs val now $ \rs -> do let (toBots, toUsers) = foldr (newMessage qusr con (Just qcnv) msg now) ([], []) rs pushSome (catMaybes toUsers) - void . forkIO $ do - gone <- External.deliver toBots - mapM_ (deleteBot cnv . botMemId) gone + External.deliverAndDeleteAsync cnv toBots newMessage :: Qualified UserId -> @@ -994,11 +1148,12 @@ newMessage qusr con qcnv msg now (m, c, t) ~(toBots, toUsers) = in (toBots, p : toUsers) updateConversationName :: + Members UpdateConversationActions r => UserId -> ConnId -> Qualified ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateConversationName zusr zcon qcnv convRename = do lusr <- qualifyLocal zusr foldQualified @@ -1009,22 +1164,24 @@ updateConversationName zusr zcon qcnv convRename = do convRename updateUnqualifiedConversationName :: + Members UpdateConversationActions r => UserId -> ConnId -> ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateUnqualifiedConversationName zusr zcon cnv rename = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv updateLocalConversationName lusr zcon lcnv rename updateLocalConversationName :: + Members UpdateConversationActions r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateLocalConversationName lusr zcon lcnv convRename = do alive <- Data.isConvAlive (tUnqualified lcnv) if alive @@ -1032,49 +1189,54 @@ updateLocalConversationName lusr zcon lcnv convRename = do else Nothing <$ Data.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: + Members UpdateConversationActions r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationRename -> - Galley (Maybe Public.Event) + Galley r (Maybe Public.Event) updateLiveLocalConversationName lusr con lcnv rename = runMaybeT $ updateLocalConversation lcnv (qUntagged lusr) (Just con) $ ConversationActionRename rename notifyConversationMetadataUpdate :: + Members '[FederatorAccess, ExternalAccess, GundeckAccess] r => Qualified UserId -> Maybe ConnId -> Local ConvId -> BotsAndMembers -> ConversationAction -> - Galley Event + Galley r Event notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = do localDomain <- viewFederationDomain now <- liftIO getCurrentTime let e = conversationActionToEvent now quid qcnv action -- notify remote participants - let rusersByDomain = bucketRemote (toList (bmRemotes targets)) - void . pooledForConcurrentlyN 8 rusersByDomain $ \(qUntagged -> Qualified uids domain) -> do - let req = FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) uids action - rpc = - FederatedGalley.onConversationUpdated - FederatedGalley.clientRoutes - localDomain - req - runFederatedGalley domain rpc + runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> + FederatedGalley.onConversationUpdated FederatedGalley.clientRoutes localDomain $ + FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action -- notify local participants and bots pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e -isTypingH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> Galley Response +isTypingH :: + Member GundeckAccess r => + UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> + Galley r Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do typingData <- fromJsonBody req isTyping zusr zcon cnv typingData pure empty -isTyping :: UserId -> ConnId -> ConvId -> Public.TypingData -> Galley () +isTyping :: + Member GundeckAccess r => + UserId -> + ConnId -> + ConvId -> + Public.TypingData -> + Galley r () isTyping zusr zcon cnv typingData = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain @@ -1091,22 +1253,30 @@ isTyping zusr zcon cnv typingData = do & pushRoute .~ RouteDirect & pushTransient .~ True -addServiceH :: JsonRequest Service -> Galley Response +addServiceH :: JsonRequest Service -> Galley r Response addServiceH req = do Data.insertService =<< fromJsonBody req return empty -rmServiceH :: JsonRequest ServiceRef -> Galley Response +rmServiceH :: JsonRequest ServiceRef -> Galley r Response rmServiceH req = do Data.deleteService =<< fromJsonBody req return empty -addBotH :: UserId ::: ConnId ::: JsonRequest AddBot -> Galley Response +addBotH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: ConnId ::: JsonRequest AddBot -> + Galley r Response addBotH (zusr ::: zcon ::: req) = do bot <- fromJsonBody req json <$> addBot zusr zcon bot -addBot :: UserId -> ConnId -> AddBot -> Galley Event +addBot :: + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + ConnId -> + AddBot -> + Galley r Event addBot zusr zcon b = do lusr <- qualifyLocal zusr c <- Data.conversation (b ^. addBotConv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) @@ -1118,7 +1288,7 @@ addBot zusr zcon b = do (e, bm) <- Data.addBotMember (qUntagged lusr) (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) t for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> push1 $ p & pushConn ?~ zcon - void . forkIO $ void $ External.deliver ((bm : bots) `zip` repeat e) + External.deliverAsync ((bm : bots) `zip` repeat e) pure e where regularConvChecks lusr c = do @@ -1136,12 +1306,20 @@ addBot zusr zcon b = do when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged -rmBotH :: UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley Response +rmBotH :: + Members '[ExternalAccess, GundeckAccess] r => + UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> + Galley r Response rmBotH (zusr ::: zcon ::: req) = do bot <- fromJsonBody req handleUpdateResult <$> rmBot zusr zcon bot -rmBot :: UserId -> Maybe ConnId -> RemoveBot -> Galley (UpdateResult Event) +rmBot :: + Members '[ExternalAccess, GundeckAccess] r => + UserId -> + Maybe ConnId -> + RemoveBot -> + Galley r (UpdateResult Event) rmBot zusr zcon b = do c <- Data.conversation (b ^. rmBotConv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) localDomain <- viewFederationDomain @@ -1160,20 +1338,20 @@ rmBot zusr zcon b = do push1 $ p & pushConn .~ zcon Data.removeMember (botUserId (b ^. rmBotId)) (Data.convId c) Data.eraseClients (botUserId (b ^. rmBotId)) - void . forkIO $ void $ External.deliver (bots `zip` repeat e) + External.deliverAsync (bots `zip` repeat e) pure $ Updated e ------------------------------------------------------------------------------- -- Helpers -ensureMemberLimit :: Foldable f => [LocalMember] -> f a -> Galley () +ensureMemberLimit :: Foldable f => [LocalMember] -> f a -> Galley r () ensureMemberLimit old new = do o <- view options let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) when (length old + length new > maxSize) $ throwM tooManyMembers -ensureConvMember :: [LocalMember] -> UserId -> Galley () +ensureConvMember :: [LocalMember] -> UserId -> Galley r () ensureConvMember users usr = unless (usr `isMember` users) $ throwErrorDescriptionType @ConvNotFound @@ -1194,13 +1372,14 @@ data CheckedOtrRecipients -- | bots are not supported on broadcast withValidOtrBroadcastRecipients :: + Member BrigAccess r => UserId -> ClientId -> OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(LocalMember, ClientId, Text)] -> Galley ()) -> - Galley OtrResult + ([(LocalMember, ClientId, Text)] -> Galley r ()) -> + Galley r OtrResult withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ \tid -> do limit <- fromIntegral . fromRange <$> fanoutLimit -- If we are going to fan this out to more than limit, we want to fail early @@ -1238,6 +1417,7 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ pure (mems ^. teamMembers) withValidOtrRecipients :: + Member BrigAccess r => UserType -> UserId -> ClientId -> @@ -1245,8 +1425,8 @@ withValidOtrRecipients :: OtrRecipients -> OtrFilterMissing -> UTCTime -> - ([(LocalMember, ClientId, Text)] -> Galley ()) -> - Galley OtrResult + ([(LocalMember, ClientId, Text)] -> Galley r ()) -> + Galley r OtrResult withValidOtrRecipients utype usr clt cnv rcps val now go = do alive <- Data.isConvAlive cnv if not alive @@ -1264,6 +1444,7 @@ withValidOtrRecipients utype usr clt cnv rcps val now go = do handleOtrResponse utype usr clt rcps localMembers clts val now go handleOtrResponse :: + Member BrigAccess r => -- | Type of proposed sender (user / bot) UserType -> -- | Proposed sender (user) @@ -1281,8 +1462,8 @@ handleOtrResponse :: -- | The current timestamp. UTCTime -> -- | Callback if OtrRecipients are valid - ([(LocalMember, ClientId, Text)] -> Galley ()) -> - Galley OtrResult + ([(LocalMember, ClientId, Text)] -> Galley r ()) -> + Galley 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 @@ -1375,7 +1556,7 @@ checkOtrRecipients usr sid prs vms vcs val now OtrIgnoreMissing us -> Clients.filter (`Set.notMember` us) miss -- Copied from 'Galley.API.Team' to break import cycles -withBindingTeam :: UserId -> (TeamId -> Galley b) -> Galley b +withBindingTeam :: UserId -> (TeamId -> Galley r b) -> Galley r b withBindingTeam zusr callback = do tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound binding <- Data.teamBinding tid >>= ifNothing teamNotFound diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index e0c3d332bb0..bbcf15950d7 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -44,6 +44,7 @@ import qualified Galley.Data as Data import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) import Galley.Data.Services (BotMember, newBotMember) import qualified Galley.Data.Types as DataTypes +import Galley.Effects import qualified Galley.External as External import Galley.Intra.Push import Galley.Intra.User @@ -53,12 +54,12 @@ import Galley.Types.Conversations.Members (localMemberToOther, remoteMemberToOth import Galley.Types.Conversations.Roles import Galley.Types.Teams hiding (Event, MemberJoin, self) import Galley.Types.UserList -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error) import Network.Wai.Utilities -import UnliftIO.Async +import UnliftIO.Async (concurrently, pooledForConcurrentlyN) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action (ConversationAction (..), conversationActionTag) import Wire.API.ErrorDescription @@ -71,7 +72,7 @@ import qualified Wire.API.User as User type JSON = Media "application" "json" -ensureAccessRole :: AccessRole -> [(UserId, Maybe TeamMember)] -> Galley () +ensureAccessRole :: Member BrigAccess r => AccessRole -> [(UserId, Maybe TeamMember)] -> Galley r () ensureAccessRole role users = case role of PrivateAccessRole -> throwErrorDescriptionType @ConvAccessDenied TeamAccessRole -> @@ -88,7 +89,7 @@ ensureAccessRole role users = case role of -- -- Team members are always considered connected, so we only check 'ensureConnected' -- for non-team-members of the _given_ user -ensureConnectedOrSameTeam :: Qualified UserId -> [UserId] -> Galley () +ensureConnectedOrSameTeam :: Member BrigAccess r => Qualified UserId -> [UserId] -> Galley r () ensureConnectedOrSameTeam _ [] = pure () ensureConnectedOrSameTeam (Qualified u domain) uids = do -- FUTUREWORK(federation, #1262): handle remote users (can't be part of the same team, just check connections) @@ -106,28 +107,28 @@ ensureConnectedOrSameTeam (Qualified u domain) uids = do -- The connection has to be bidirectional (e.g. if A connects to B and later -- B blocks A, the status of A-to-B is still 'Accepted' but it doesn't mean -- that they are connected). -ensureConnected :: Local UserId -> UserList UserId -> Galley () +ensureConnected :: Member BrigAccess r => Local UserId -> UserList UserId -> Galley r () ensureConnected self others = do ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToRemotes self (ulRemotes others) -ensureConnectedToLocals :: UserId -> [UserId] -> Galley () +ensureConnectedToLocals :: Member BrigAccess r => UserId -> [UserId] -> Galley r () ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = do +ensureConnectedToLocals u uids = liftGalley0 $ do (connsFrom, connsTo) <- - getConnectionsUnqualified [u] (Just uids) (Just Accepted) - `concurrently` getConnectionsUnqualified uids (Just [u]) (Just Accepted) + getConnectionsUnqualified0 [u] (Just uids) (Just Accepted) + `concurrently` getConnectionsUnqualified0 uids (Just [u]) (Just Accepted) unless (length connsFrom == length uids && length connsTo == length uids) $ throwErrorDescriptionType @NotConnected -ensureConnectedToRemotes :: Local UserId -> [Remote UserId] -> Galley () +ensureConnectedToRemotes :: Member BrigAccess r => Local UserId -> [Remote UserId] -> Galley r () ensureConnectedToRemotes _ [] = pure () ensureConnectedToRemotes u remotes = do acceptedConns <- getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) when (length acceptedConns /= length remotes) $ throwErrorDescriptionType @NotConnected -ensureReAuthorised :: UserId -> Maybe PlainTextPassword -> Galley () +ensureReAuthorised :: Member BrigAccess r => UserId -> Maybe PlainTextPassword -> Galley r () ensureReAuthorised u secret = do reAuthed <- reAuthUser u (ReAuthUser secret) unless reAuthed $ @@ -136,7 +137,7 @@ ensureReAuthorised u secret = do -- | Given a member in a conversation, check if the given action -- is permitted. If the user does not have the given permission, throw -- 'operationDenied'. -ensureActionAllowed :: IsConvMember mem => Action -> mem -> Galley () +ensureActionAllowed :: IsConvMember mem => Action -> mem -> Galley r () ensureActionAllowed action self = case isActionAllowed action (convMemberRole self) of Just True -> pure () Just False -> throwErrorDescription (actionDenied action) @@ -150,7 +151,7 @@ ensureConversationActionAllowed :: ConversationAction -> Data.Conversation -> mem -> - Galley () + Galley r () ensureConversationActionAllowed action conv self = do loc <- qualifyLocal () let tag = conversationActionTag (convMemberId loc self) action @@ -199,7 +200,7 @@ ensureConversationActionAllowed action conv self = do throwErrorDescriptionType @InvalidTargetAccess _ -> pure () -ensureGroupConvThrowing :: Data.Conversation -> Galley () +ensureGroupConvThrowing :: Data.Conversation -> Galley r () ensureGroupConvThrowing conv = case Data.convType conv of SelfConv -> throwM invalidSelfOp One2OneConv -> throwM invalidOne2OneOp @@ -210,7 +211,7 @@ ensureGroupConvThrowing conv = case Data.convType conv of -- own. This is used to ensure users cannot "elevate" allowed actions -- This function needs to be review when custom roles are introduced since only -- custom roles can cause `roleNameToActions` to return a Nothing -ensureConvRoleNotElevated :: IsConvMember mem => mem -> RoleName -> Galley () +ensureConvRoleNotElevated :: IsConvMember mem => mem -> RoleName -> Galley r () ensureConvRoleNotElevated origMember targetRole = do case (roleNameToActions targetRole, roleNameToActions (convMemberRole origMember)) of (Just targetActions, Just memberActions) -> @@ -222,7 +223,7 @@ ensureConvRoleNotElevated origMember targetRole = do -- | If a team member is not given throw 'notATeamMember'; if the given team -- member does not have the given permission, throw 'operationDenied'. -- Otherwise, return the team member. -permissionCheck :: (IsPerm perm, Show perm) => perm -> Maybe TeamMember -> Galley TeamMember +permissionCheck :: (IsPerm perm, Show perm) => perm -> Maybe TeamMember -> Galley r TeamMember permissionCheck p = \case Just m -> do if m `hasPermission` p @@ -230,14 +231,14 @@ permissionCheck p = \case else throwErrorDescription (operationDenied p) Nothing -> throwErrorDescriptionType @NotATeamMember -assertTeamExists :: TeamId -> Galley () +assertTeamExists :: TeamId -> Galley r () assertTeamExists tid = do teamExists <- isJust <$> Data.team tid if teamExists then pure () else throwM teamNotFound -assertOnTeam :: UserId -> TeamId -> Galley () +assertOnTeam :: UserId -> TeamId -> Galley r () assertOnTeam uid tid = do Data.teamMember tid uid >>= \case Nothing -> throwErrorDescriptionType @NotATeamMember @@ -245,7 +246,7 @@ assertOnTeam uid tid = do -- | If the conversation is in a team, throw iff zusr is a team member and does not have named -- permission. If the conversation is not in a team, do nothing (no error). -permissionCheckTeamConv :: UserId -> ConvId -> Perm -> Galley () +permissionCheckTeamConv :: UserId -> ConvId -> Perm -> Galley r () permissionCheckTeamConv zusr cnv perm = Data.conversation cnv >>= \case Just cnv' -> case Data.convTeam cnv' of @@ -254,7 +255,12 @@ permissionCheckTeamConv zusr cnv perm = Nothing -> throwErrorDescriptionType @ConvNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. -acceptOne2One :: UserId -> Data.Conversation -> Maybe ConnId -> Galley Data.Conversation +acceptOne2One :: + Member GundeckAccess r => + UserId -> + Data.Conversation -> + Maybe ConnId -> + Galley r Data.Conversation acceptOne2One usr conv conn = do lusr <- qualifyLocal usr lcid <- qualifyLocal cid @@ -460,12 +466,12 @@ getSelfMemberFromLocals :: ExceptT ConvNotFound m LocalMember getSelfMemberFromLocals = getLocalMember (mkErrorDescription :: ConvNotFound) --- | A legacy version of 'getSelfMemberFromLocals' that runs in the Galley monad. +-- | A legacy version of 'getSelfMemberFromLocals' that runs in the Galley r monad. getSelfMemberFromLocalsLegacy :: Foldable t => UserId -> t LocalMember -> - Galley LocalMember + Galley r LocalMember getSelfMemberFromLocalsLegacy usr lmems = eitherM throwErrorDescription pure . runExceptT $ getSelfMemberFromLocals usr lmems @@ -475,7 +481,7 @@ ensureOtherMember :: Local a -> Qualified UserId -> Data.Conversation -> - Galley (Either LocalMember RemoteMember) + Galley r (Either LocalMember RemoteMember) ensureOtherMember loc quid conv = maybe (throwErrorDescriptionType @ConvMemberNotFound) pure $ (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) @@ -488,7 +494,7 @@ getSelfMemberFromRemotes :: ExceptT ConvNotFound m RemoteMember getSelfMemberFromRemotes = getRemoteMember (mkErrorDescription :: ConvNotFound) -getSelfMemberFromRemotesLegacy :: Foldable t => Remote UserId -> t RemoteMember -> Galley RemoteMember +getSelfMemberFromRemotesLegacy :: Foldable t => Remote UserId -> t RemoteMember -> Galley r RemoteMember getSelfMemberFromRemotesLegacy usr rmems = eitherM throwErrorDescription pure . runExceptT $ getSelfMemberFromRemotes usr rmems @@ -538,7 +544,10 @@ getMember :: ExceptT e m mem getMember p ex u = hoistEither . note ex . find ((u ==) . p) -getConversationAndCheckMembership :: UserId -> ConvId -> Galley Data.Conversation +getConversationAndCheckMembership :: + UserId -> + ConvId -> + Galley r Data.Conversation getConversationAndCheckMembership uid cnv = do (conv, _) <- getConversationAndMemberWithError @@ -552,7 +561,7 @@ getConversationAndMemberWithError :: Error -> uid -> ConvId -> - Galley (Data.Conversation, mem) + Galley r (Data.Conversation, mem) getConversationAndMemberWithError ex usr convId = do c <- Data.conversation convId >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) when (DataTypes.isConvDeleted c) $ do @@ -582,14 +591,20 @@ canDeleteMember deleter deletee getRole mem = fromMaybe RoleMember $ permissionsRole $ mem ^. permissions -- | Send an event to local users and bots -pushConversationEvent :: Foldable f => Maybe ConnId -> Event -> f UserId -> f BotMember -> Galley () +pushConversationEvent :: + (Members '[GundeckAccess, ExternalAccess] r, Foldable f) => + Maybe ConnId -> + Event -> + f UserId -> + f BotMember -> + Galley r () pushConversationEvent conn e users bots = do localDomain <- viewFederationDomain for_ (newConversationEventPush localDomain e (toList users)) $ \p -> push1 $ p & set pushConn conn - void . forkIO $ void $ External.deliver (toList bots `zip` repeat e) + External.deliverAsync (toList bots `zip` repeat e) -verifyReusableCode :: ConversationCode -> Galley DataTypes.Code +verifyReusableCode :: ConversationCode -> Galley r DataTypes.Code verifyReusableCode convCode = do c <- Data.lookupCode (conversationKey convCode) DataTypes.ReusableCode @@ -598,7 +613,7 @@ verifyReusableCode convCode = do throwM (errorDescriptionTypeToWai @CodeNotFound) return c -ensureConversationAccess :: UserId -> ConvId -> Access -> Galley Data.Conversation +ensureConversationAccess :: Member BrigAccess r => UserId -> ConvId -> Access -> Galley r Data.Conversation ensureConversationAccess zusr cnv access = do conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) ensureAccess conv access @@ -606,7 +621,7 @@ ensureConversationAccess zusr cnv access = do ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] pure conv -ensureAccess :: Data.Conversation -> Access -> Galley () +ensureAccess :: Data.Conversation -> Access -> Galley r () ensureAccess conv access = unless (access `elem` Data.convAccess conv) $ throwErrorDescriptionType @ConvAccessDenied @@ -620,12 +635,15 @@ viewFederationDomain = view (options . optSettings . setFederationDomain) qualifyLocal :: MonadReader Env m => a -> m (Local a) qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a -checkRemoteUsersExist :: (Functor f, Foldable f) => f (Remote UserId) -> Galley () +checkRemoteUsersExist :: + (Member FederatorAccess r, Functor f, Foldable f) => + f (Remote UserId) -> + Galley r () checkRemoteUsersExist = -- FUTUREWORK: pooledForConcurrentlyN_ instead of sequential checks per domain traverse_ checkRemotesFor . bucketRemote -checkRemotesFor :: Remote [UserId] -> Galley () +checkRemotesFor :: Member FederatorAccess r => Remote [UserId] -> Galley r () checkRemotesFor (qUntagged -> Qualified uids domain) = do let rpc = FederatedBrig.getUsersByIds FederatedBrig.clientRoutes uids users <- runFederatedBrig domain rpc @@ -636,33 +654,55 @@ checkRemotesFor (qUntagged -> Qualified uids domain) = do unless (Set.fromList uids == Set.fromList uids') $ throwM unknownRemoteUser -type FederatedGalleyRPC c a = FederatorClient c (ExceptT FederationClientFailure Galley) a +type FederatedGalleyRPC c a = FederatorClient c (ExceptT FederationClientFailure Galley0) a -runFederatedGalley :: Domain -> FederatedGalleyRPC 'Galley a -> Galley a -runFederatedGalley = runFederated @'Galley - -runFederatedBrig :: Domain -> FederatedGalleyRPC 'Brig a -> Galley a -runFederatedBrig = runFederated @'Brig - -runFederated :: forall (c :: Component) a. Domain -> FederatorClient c (ExceptT FederationClientFailure Galley) a -> Galley a -runFederated remoteDomain rpc = do +runFederated0 :: + forall (c :: Component) a. + Domain -> + FederatedGalleyRPC c a -> + Galley0 a +runFederated0 remoteDomain rpc = do runExceptT (executeFederated remoteDomain rpc) >>= either (throwM . federationErrorToWai) pure +runFederatedGalley :: + Member FederatorAccess r => + Domain -> + FederatedGalleyRPC 'Galley a -> + Galley r a +runFederatedGalley = runFederated + +runFederatedBrig :: + Member FederatorAccess r => + Domain -> + FederatedGalleyRPC 'Brig a -> + Galley r a +runFederatedBrig = runFederated + +runFederated :: + forall (c :: Component) r a. + Member FederatorAccess r => + Domain -> + FederatedGalleyRPC c a -> + Galley r a +runFederated remoteDomain = liftGalley0 . runFederated0 remoteDomain + runFederatedConcurrently :: + Member FederatorAccess r => (Foldable f, Functor f) => f (Remote a) -> (Remote [a] -> FederatedGalleyRPC c b) -> - Galley [Remote b] -runFederatedConcurrently xs rpc = + Galley r [Remote b] +runFederatedConcurrently xs rpc = liftGalley0 $ pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> - qualifyAs r <$> runFederated (tDomain r) (rpc r) + qualifyAs r <$> runFederated0 (tDomain r) (rpc r) runFederatedConcurrently_ :: + Member FederatorAccess r => (Foldable f, Functor f) => f (Remote a) -> (Remote [a] -> FederatedGalleyRPC c ()) -> - Galley () + Galley r () runFederatedConcurrently_ xs = void . runFederatedConcurrently xs -- | Convert an internal conversation representation 'Data.Conversation' to @@ -767,12 +807,13 @@ fromNewRemoteConversation loc rc@NewRemoteConversation {..} = -- | Notify remote users of being added to a new conversation registerRemoteConversationMemberships :: + Member FederatorAccess r => -- | The time stamp when the conversation was created UTCTime -> -- | The domain of the user that created the conversation Domain -> Data.Conversation -> - Galley () + Galley r () registerRemoteConversationMemberships now localDomain c = do let allRemoteMembers = nubOrd (map rmId (Data.convRemoteMembers c)) rc = toNewRemoteConversation now localDomain c @@ -799,13 +840,13 @@ consentGiven = \case UserLegalHoldEnabled -> ConsentGiven UserLegalHoldNoConsent -> ConsentNotGiven -checkConsent :: Map UserId TeamId -> UserId -> Galley ConsentGiven +checkConsent :: Map UserId TeamId -> UserId -> Galley r ConsentGiven checkConsent teamsOfUsers other = do consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other -- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user -- doesn't belong to a team. -getLHStatus :: Maybe TeamId -> UserId -> Galley UserLegalHoldStatus +getLHStatus :: Maybe TeamId -> UserId -> Galley r UserLegalHoldStatus getLHStatus teamOfUser other = do case teamOfUser of Nothing -> pure defUserLegalHoldStatus @@ -813,7 +854,7 @@ getLHStatus teamOfUser other = do mMember <- Data.teamMember team other pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember -anyLegalholdActivated :: [UserId] -> Galley Bool +anyLegalholdActivated :: [UserId] -> Galley r Bool anyLegalholdActivated uids = do view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure False @@ -825,7 +866,7 @@ anyLegalholdActivated uids = do teamsOfUsers <- Data.usersTeams uidsPage anyM (\uid -> userLHEnabled <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage -allLegalholdConsentGiven :: [UserId] -> Galley Bool +allLegalholdConsentGiven :: [UserId] -> Galley r Bool allLegalholdConsentGiven uids = do view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure False @@ -842,7 +883,7 @@ allLegalholdConsentGiven uids = do allM isTeamLegalholdWhitelisted teamsPage -- | Add to every uid the legalhold status -getLHStatusForUsers :: [UserId] -> Galley [(UserId, UserLegalHoldStatus)] +getLHStatusForUsers :: [UserId] -> Galley r [(UserId, UserLegalHoldStatus)] getLHStatusForUsers uids = mconcat <$> ( for (chunksOf 32 uids) $ \uidsChunk -> do diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 3d938a8241d..10ba4724994 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -38,6 +38,8 @@ module Galley.App -- * Galley monad Galley, + GalleyEffects, + Galley0, runGalley, evalGalley, ask, @@ -52,6 +54,13 @@ module Galley.App initExtEnv, fanoutLimit, currentFanoutLimit, + + -- * MonadUnliftIO / Sem compatibility + fireAndForget, + spawnMany, + liftGalley0, + liftSem, + interpretGalleyToGalley0, ) where @@ -61,8 +70,9 @@ 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 hiding (tryJust) +import Control.Monad.Catch (MonadCatch (..), MonadMask (..), MonadThrow (..)) import Data.Aeson (FromJSON) import qualified Data.Aeson as Aeson import Data.ByteString.Conversion (toByteString') @@ -80,26 +90,32 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Galley.API.Error import qualified Galley.Aws as Aws +import Galley.Effects +import qualified Galley.Effects.FireAndForget as E import Galley.Options import qualified Galley.Queue as Q import qualified Galley.Types.Teams as Teams -import Imports +import Imports hiding (forkIO) import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.OpenSSL 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 +import Network.Wai.Utilities hiding (Error) import qualified Network.Wai.Utilities as WaiError import qualified Network.Wai.Utilities.Server as Server import OpenSSL.EVP.Digest (getDigestByName) import OpenSSL.Session as Ssl import qualified OpenSSL.X509.SystemStore as Ssl +import Polysemy +import Polysemy.Internal (Append) +import qualified Polysemy.Reader as P import qualified Servant import Ssl.Util import System.Logger.Class hiding (Error, info) import qualified System.Logger.Extended as Logger +import qualified UnliftIO.Exception as UnliftIO import Util.Options import Wire.API.Federation.Client (HasFederatorConfig (..)) @@ -131,26 +147,48 @@ makeLenses ''Env makeLenses ''ExtEnv -newtype Galley a = Galley - { unGalley :: ReaderT Env Client a - } - deriving - ( Functor, - Applicative, - Monad, - MonadIO, - MonadThrow, - MonadCatch, - MonadMask, - MonadReader Env, - MonadClient - ) +-- 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.Reader ClientState, P.Reader 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 HasFederatorConfig Galley where +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 MonadThrow (Galley r) where + throwM e = Galley (embed @IO (throwM e)) + +instance MonadReader Env (Galley r) where + ask = Galley $ P.ask @Env + local f m = Galley $ P.local f (unGalley m) + +instance MonadClient (Galley r) where + liftClient m = Galley $ do + cs <- P.ask @ClientState + embed @IO $ runClient cs m + localState f m = Galley $ P.local f (unGalley m) + +instance HasFederatorConfig (Galley r) where federatorEndpoint = view federator federationDomain = view (options . optSettings . setFederationDomain) -fanoutLimit :: Galley (Range 1 Teams.HardTruncationLimit Int32) +fanoutLimit :: Galley r (Range 1 Teams.HardTruncationLimit Int32) fanoutLimit = view options >>= return . currentFanoutLimit currentFanoutLimit :: Opts -> Range 1 Teams.HardTruncationLimit Int32 @@ -182,23 +220,17 @@ validateOptions l o = do when (settings ^. setMaxTeamSize < optFanoutLimit) $ error "setMaxTeamSize cannot be < setTruncationLimit" -instance MonadUnliftIO Galley where - askUnliftIO = - Galley . ReaderT $ \r -> - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . flip runReaderT r . unGalley)) - -instance MonadLogger Galley where +instance MonadLogger (Galley r) where log l m = do e <- ask Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) -instance MonadHttp Galley where +instance MonadHttp (Galley r) where handleRequestWithCont req handler = do httpManager <- view manager liftIO $ withResponse req httpManager handler -instance HasRequestId Galley where +instance HasRequestId (Galley r) where getRequestId = view reqId createEnv :: Metrics -> Opts -> IO Env @@ -271,13 +303,20 @@ initExtEnv = do let pinset = map toByteString' fprs in verifyRsaFingerprint sha pinset -runGalley :: Env -> Request -> Galley a -> IO a +runGalley :: Env -> Request -> Galley GalleyEffects a -> IO a runGalley e r m = let e' = reqId .~ lookupReqId r $ e in evalGalley e' m -evalGalley :: Env -> Galley a -> IO a -evalGalley e m = runClient (e ^. cstate) (runReaderT (unGalley m) e) +evalGalley0 :: Env -> Sem GalleyEffects0 a -> IO a +evalGalley0 e = + runFinal @IO + . embedToFinal @IO + . P.runReader e + . P.runReader (e ^. cstate) + +evalGalley :: Env -> Galley GalleyEffects a -> IO a +evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders @@ -286,33 +325,33 @@ reqIdMsg :: RequestId -> Msg -> Msg reqIdMsg = ("request" .=) . unRequestId {-# INLINE reqIdMsg #-} -fromJsonBody :: FromJSON a => JsonRequest a -> Galley a +fromJsonBody :: FromJSON a => JsonRequest a -> Galley r a fromJsonBody r = exceptT (throwM . invalidPayload) return (parseBody r) {-# INLINE fromJsonBody #-} -fromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> Galley (Maybe a) +fromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> Galley r (Maybe a) fromOptionalJsonBody r = exceptT (throwM . invalidPayload) return (parseOptionalBody r) {-# INLINE fromOptionalJsonBody #-} -fromProtoBody :: Proto.Decode a => Request -> Galley a +fromProtoBody :: Proto.Decode a => Request -> Galley r a fromProtoBody r = do b <- readBody r either (throwM . invalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) {-# INLINE fromProtoBody #-} -ifNothing :: Error -> Maybe a -> Galley a +ifNothing :: WaiError.Error -> Maybe a -> Galley r a ifNothing e = maybe (throwM e) return {-# INLINE ifNothing #-} -toServantHandler :: Env -> Galley a -> Servant.Handler a +toServantHandler :: Env -> Galley GalleyEffects a -> Servant.Handler a toServantHandler env galley = do - eith <- liftIO $ try (evalGalley env galley) + eith <- liftIO $ Control.Exception.try (evalGalley env galley) case eith of Left werr -> handleWaiErrors (view applog env) (unRequestId (view reqId env)) werr Right result -> pure result where - handleWaiErrors :: Logger -> ByteString -> Error -> Servant.Handler a + handleWaiErrors :: Logger -> ByteString -> WaiError.Error -> Servant.Handler a handleWaiErrors logger reqId' werr = do Server.logError' logger (Just reqId') werr Servant.throwError $ @@ -320,3 +359,50 @@ toServantHandler env galley = do mkCode = statusCode . WaiError.code mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . WaiError.code + +---------------------------------------------------------------------------------- +---- 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 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 + +interpretGalleyToGalley0 :: Galley GalleyEffects a -> Galley0 a +interpretGalleyToGalley0 = + Galley + . interpretFireAndForget + . interpretIntra + . interpretBot + . interpretFederator + . interpretExternal + . interpretSpar + . interpretGundeck + . interpretBrig + . unGalley diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 04353e202e9..4d2e02de642 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -111,6 +111,7 @@ module Galley.Data -- * Clients eraseClients, lookupClients, + lookupClients', updateClient, -- * Utilities @@ -129,7 +130,7 @@ import Cassandra.Util import Control.Arrow (second) import Control.Exception (ErrorCall (ErrorCall)) import Control.Lens hiding ((<|)) -import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Catch (throwM) import Control.Monad.Extra (ifM) import Data.ByteString.Conversion hiding (parser) import Data.Domain (Domain) @@ -170,10 +171,8 @@ import Galley.Types.Teams.Intra import Galley.Types.UserList import Galley.Validation import Imports hiding (Set, max) -import System.Logger.Class (MonadLogger) import qualified System.Logger.Class as Log -import UnliftIO (async, mapConcurrently, wait) -import UnliftIO.Async (pooledMapConcurrentlyN) +import qualified UnliftIO import Wire.API.Team.Member -- We use this newtype to highlight the fact that the 'Page' wrapped in here @@ -210,7 +209,7 @@ schemaVersion :: Int32 schemaVersion = 53 -- | Insert a conversation code -insertCode :: MonadClient m => Code -> m () +insertCode :: Code -> Galley r () insertCode c = do let k = codeKey c let v = codeValue c @@ -220,16 +219,16 @@ insertCode c = do retry x5 (write Cql.insertCode (params Quorum (k, v, cnv, s, t))) -- | Lookup a conversation by code. -lookupCode :: MonadClient m => Key -> Scope -> m (Maybe Code) +lookupCode :: Key -> Scope -> Galley r (Maybe Code) lookupCode k s = fmap (toCode k s) <$> retry x1 (query1 Cql.lookupCode (params Quorum (k, s))) -- | Delete a code associated with the given conversation key -deleteCode :: MonadClient m => Key -> Scope -> m () +deleteCode :: Key -> Scope -> Galley r () deleteCode k s = retry x5 $ write Cql.deleteCode (params Quorum (k, s)) -- Teams -------------------------------------------------------------------- -team :: MonadClient m => TeamId -> m (Maybe TeamData) +team :: TeamId -> Galley r (Maybe TeamData) team tid = fmap toTeam <$> retry x1 (query1 Cql.selectTeam (params Quorum (Identity tid))) where @@ -238,16 +237,16 @@ team tid = status = if d then PendingDelete else fromMaybe Active s in TeamData t status (writeTimeToUTC <$> st) -teamName :: MonadClient m => TeamId -> m (Maybe Text) +teamName :: TeamId -> Galley r (Maybe Text) teamName tid = fmap runIdentity <$> retry x1 (query1 Cql.selectTeamName (params Quorum (Identity tid))) -teamIdsOf :: MonadClient m => UserId -> Range 1 32 (List TeamId) -> m [TeamId] +teamIdsOf :: UserId -> Range 1 32 (List TeamId) -> Galley r [TeamId] teamIdsOf usr (fromList . fromRange -> tids) = map runIdentity <$> retry x1 (query Cql.selectUserTeamsIn (params Quorum (usr, tids))) -teamIdsFrom :: MonadClient m => UserId -> Maybe TeamId -> Range 1 100 Int32 -> m (ResultSet TeamId) +teamIdsFrom :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Galley r (ResultSet TeamId) teamIdsFrom usr range (fromRange -> max) = mkResultSet . fmap runIdentity . strip <$> case range of Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) (max + 1)) @@ -255,32 +254,32 @@ teamIdsFrom usr range (fromRange -> max) = where strip p = p {result = take (fromIntegral max) (result p)} -teamIdsForPagination :: MonadClient m => UserId -> Maybe TeamId -> Range 1 100 Int32 -> m (Page TeamId) +teamIdsForPagination :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Galley r (Page TeamId) teamIdsForPagination usr range (fromRange -> max) = fmap runIdentity <$> case range of Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) max) Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) max) -teamConversation :: MonadClient m => TeamId -> ConvId -> m (Maybe TeamConversation) +teamConversation :: TeamId -> ConvId -> Galley r (Maybe TeamConversation) teamConversation t c = fmap (newTeamConversation c . runIdentity) <$> retry x1 (query1 Cql.selectTeamConv (params Quorum (t, c))) -teamConversations :: MonadClient m => TeamId -> m [TeamConversation] +teamConversations :: TeamId -> Galley r [TeamConversation] teamConversations t = map (uncurry newTeamConversation) <$> retry x1 (query Cql.selectTeamConvs (params Quorum (Identity t))) -teamConversationsForPagination :: MonadClient m => TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> m (Page TeamConversation) +teamConversationsForPagination :: TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> Galley r (Page TeamConversation) teamConversationsForPagination tid start (fromRange -> max) = fmap (uncurry newTeamConversation) <$> case start of Just c -> paginate Cql.selectTeamConvsFrom (paramsP Quorum (tid, c) max) Nothing -> paginate Cql.selectTeamConvs (paramsP Quorum (Identity tid) max) -teamMembersForFanout :: TeamId -> Galley TeamMemberList +teamMembersForFanout :: TeamId -> Galley r TeamMemberList teamMembersForFanout t = fanoutLimit >>= teamMembersWithLimit t -teamMembersWithLimit :: forall m. (MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> Range 1 HardTruncationLimit Int32 -> m TeamMemberList +teamMembersWithLimit :: TeamId -> Range 1 HardTruncationLimit Int32 -> Galley r TeamMemberList teamMembersWithLimit t (fromRange -> limit) = do -- NOTE: We use +1 as size and then trim it due to the semantics of C* when getting a page with the exact same size pageTuple <- retry x1 (paginate Cql.selectTeamMembers (paramsP Quorum (Identity t) (limit + 1))) @@ -293,7 +292,7 @@ teamMembersWithLimit t (fromRange -> limit) = do -- This function has a bit of a difficult type to work with because we don't have a pure function of type -- (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> TeamMember so we -- cannot fmap over the ResultSet. We don't want to mess around with the Result size nextPage either otherwise -teamMembersForPagination :: MonadClient m => TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> m (Page (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus)) +teamMembersForPagination :: TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Galley r (Page (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus)) teamMembersForPagination tid start (fromRange -> max) = case start of Just u -> paginate Cql.selectTeamMembersFrom (paramsP Quorum (tid, u) max) @@ -301,7 +300,7 @@ teamMembersForPagination tid start (fromRange -> max) = -- NOTE: Use this function with care... should only be required when deleting a team! -- Maybe should be left explicitly for the caller? -teamMembersCollectedWithPagination :: TeamId -> Galley [TeamMember] +teamMembersCollectedWithPagination :: TeamId -> Galley r [TeamMember] teamMembersCollectedWithPagination tid = do mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) collectTeamMembersPaginated [] mems @@ -315,38 +314,43 @@ teamMembersCollectedWithPagination tid = do -- Lookup only specific team members: this is particularly useful for large teams when -- needed to look up only a small subset of members (typically 2, user to perform the action -- and the target user) -teamMembersLimited :: forall m. (MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> [UserId] -> m [TeamMember] +teamMembersLimited :: TeamId -> [UserId] -> Galley r [TeamMember] teamMembersLimited t u = mapM (newTeamMember' t) =<< retry x1 (query Cql.selectTeamMembers' (params Quorum (t, u))) -teamMember :: forall m. (MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> UserId -> m (Maybe TeamMember) +teamMember :: TeamId -> UserId -> Galley r (Maybe TeamMember) teamMember t u = newTeamMember'' u =<< retry x1 (query1 Cql.selectTeamMember (params Quorum (t, u))) where newTeamMember'' :: UserId -> Maybe (Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> - m (Maybe TeamMember) + Galley r (Maybe TeamMember) newTeamMember'' _ Nothing = pure Nothing newTeamMember'' uid (Just (perms, minvu, minvt, mulhStatus)) = Just <$> newTeamMember' t (uid, perms, minvu, minvt, mulhStatus) -userTeams :: MonadClient m => UserId -> m [TeamId] +userTeams :: UserId -> Galley r [TeamId] userTeams u = map runIdentity <$> retry x1 (query Cql.selectUserTeams (params Quorum (Identity u))) -usersTeams :: (MonadUnliftIO m, MonadClient m) => [UserId] -> m (Map UserId TeamId) -usersTeams uids = do - pairs :: [(UserId, TeamId)] <- catMaybes <$> pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeam uid) uids +usersTeams :: [UserId] -> Galley r (Map UserId TeamId) +usersTeams uids = liftClient $ do + pairs :: [(UserId, TeamId)] <- + catMaybes + <$> UnliftIO.pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeamC uid) uids pure $ foldl' (\m (k, v) -> Map.insert k v m) Map.empty pairs -oneUserTeam :: MonadClient m => UserId -> m (Maybe TeamId) -oneUserTeam u = +oneUserTeam :: UserId -> Galley r (Maybe TeamId) +oneUserTeam = liftClient . oneUserTeamC + +oneUserTeamC :: UserId -> Client (Maybe TeamId) +oneUserTeamC u = fmap runIdentity <$> retry x1 (query1 Cql.selectOneUserTeam (params Quorum (Identity u))) -teamCreationTime :: MonadClient m => TeamId -> m (Maybe TeamCreationTime) +teamCreationTime :: TeamId -> Galley r (Maybe TeamCreationTime) teamCreationTime t = checkCreation . fmap runIdentity <$> retry x1 (query1 Cql.selectTeamBindingWritetime (params Quorum (Identity t))) @@ -354,20 +358,19 @@ teamCreationTime t = checkCreation (Just (Just ts)) = Just $ TeamCreationTime ts checkCreation _ = Nothing -teamBinding :: MonadClient m => TeamId -> m (Maybe TeamBinding) +teamBinding :: TeamId -> Galley r (Maybe TeamBinding) teamBinding t = fmap (fromMaybe NonBinding . runIdentity) <$> retry x1 (query1 Cql.selectTeamBinding (params Quorum (Identity t))) createTeam :: - MonadClient m => Maybe TeamId -> UserId -> Range 1 256 Text -> Range 1 256 Text -> Maybe (Range 1 256 Text) -> TeamBinding -> - m Team + Galley r Team createTeam t uid (fromRange -> n) (fromRange -> i) k b = do tid <- maybe (Id <$> liftIO nextRandom) return t retry x5 $ write Cql.insertTeam (params Quorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) @@ -376,7 +379,7 @@ createTeam t uid (fromRange -> n) (fromRange -> i) k b = do initialStatus Binding = PendingActive -- Team becomes Active after User account activation initialStatus NonBinding = Active -deleteTeam :: forall m. (MonadClient m, Log.MonadLogger m, MonadThrow m) => TeamId -> m () +deleteTeam :: TeamId -> Galley r () deleteTeam tid = do -- TODO: delete service_whitelist records that mention this team retry x5 $ write Cql.markTeamDeleted (params Quorum (PendingDelete, tid)) @@ -386,7 +389,7 @@ deleteTeam tid = do removeConvs cnvs retry x5 $ write Cql.deleteTeam (params Quorum (Deleted, tid)) where - removeConvs :: Page TeamConversation -> m () + removeConvs :: Page TeamConversation -> Galley r () removeConvs cnvs = do for_ (result cnvs) $ removeTeamConv tid . view conversationId unless (null $ result cnvs) $ @@ -400,13 +403,13 @@ deleteTeam tid = do Maybe UTCTimeMillis, Maybe UserLegalHoldStatus ) -> - m () + Galley r () removeTeamMembers mems = do mapM_ (removeTeamMember tid . view _1) (result mems) unless (null $ result mems) $ removeTeamMembers =<< liftClient (nextPage mems) -addTeamMember :: MonadClient m => TeamId -> TeamMember -> m () +addTeamMember :: TeamId -> TeamMember -> Galley r () addTeamMember t m = retry x5 . batch $ do setType BatchLogged @@ -424,14 +427,13 @@ addTeamMember t m = addPrepQuery Cql.insertBillingTeamMember (t, m ^. userId) updateTeamMember :: - MonadClient m => -- | Old permissions, used for maintaining 'billing_team_member' table Permissions -> TeamId -> UserId -> -- | New permissions Permissions -> - m () + Galley r () updateTeamMember oldPerms tid uid newPerms = do retry x5 . batch $ do setType BatchLogged @@ -448,7 +450,7 @@ updateTeamMember oldPerms tid uid newPerms = do acquiredPerms = newPerms `permDiff` oldPerms lostPerms = oldPerms `permDiff` newPerms -removeTeamMember :: MonadClient m => TeamId -> UserId -> m () +removeTeamMember :: TeamId -> UserId -> Galley r () removeTeamMember t m = retry x5 . batch $ do setType BatchLogged @@ -457,12 +459,12 @@ removeTeamMember t m = addPrepQuery Cql.deleteUserTeam (m, t) addPrepQuery Cql.deleteBillingTeamMember (t, m) -listBillingTeamMembers :: MonadClient m => TeamId -> m [UserId] +listBillingTeamMembers :: TeamId -> Galley r [UserId] listBillingTeamMembers tid = fmap runIdentity <$> retry x1 (query Cql.listBillingTeamMembers (params Quorum (Identity tid))) -removeTeamConv :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => TeamId -> ConvId -> m () +removeTeamConv :: TeamId -> ConvId -> Galley r () removeTeamConv tid cid = do retry x5 . batch $ do setType BatchLogged @@ -471,10 +473,10 @@ removeTeamConv tid cid = do addPrepQuery Cql.deleteTeamConv (tid, cid) deleteConversation cid -updateTeamStatus :: MonadClient m => TeamId -> TeamStatus -> m () +updateTeamStatus :: TeamId -> TeamStatus -> Galley r () updateTeamStatus t s = retry x5 $ write Cql.updateTeamStatus (params Quorum (s, t)) -updateTeam :: MonadClient m => TeamId -> TeamUpdateData -> m () +updateTeam :: TeamId -> TeamUpdateData -> Galley r () updateTeam tid u = retry x5 . batch $ do setType BatchLogged setConsistency Quorum @@ -487,7 +489,7 @@ updateTeam tid u = retry x5 . batch $ do -- Conversations ------------------------------------------------------------ -isConvAlive :: MonadClient m => ConvId -> m Bool +isConvAlive :: ConvId -> Galley r Bool isConvAlive cid = do result <- retry x1 (query1 Cql.isConvDeleted (params Quorum (Identity cid))) case runIdentity <$> result of @@ -496,38 +498,39 @@ isConvAlive cid = do Just (Just True) -> pure False Just (Just False) -> pure True -conversation :: - (MonadUnliftIO m, MonadClient m, Log.MonadLogger m, MonadThrow m) => - ConvId -> - m (Maybe Conversation) -conversation conv = do - cdata <- async $ retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) - remoteMems <- async $ lookupRemoteMembers conv - mbConv <- toConv conv <$> members conv <*> wait remoteMems <*> wait cdata +conversation :: ConvId -> Galley r (Maybe Conversation) +conversation conv = liftClient $ do + cdata <- UnliftIO.async $ retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) + remoteMems <- UnliftIO.async $ lookupRemoteMembersC conv + mbConv <- + toConv conv + <$> membersC conv + <*> UnliftIO.wait remoteMems + <*> UnliftIO.wait cdata return mbConv >>= conversationGC {- "Garbage collect" the conversation, i.e. the conversation may be marked as deleted, in which case we delete it and return Nothing -} conversationGC :: - (MonadClient m, Log.MonadLogger m, MonadThrow m) => Maybe Conversation -> - m (Maybe Conversation) + Client (Maybe Conversation) conversationGC conv = case join (convDeleted <$> conv) of (Just True) -> do - sequence_ $ deleteConversation . convId <$> conv + sequence_ $ deleteConversationC . convId <$> conv return Nothing _ -> return conv -localConversations :: - (MonadLogger m, MonadUnliftIO m, MonadClient m) => - [ConvId] -> - m [Conversation] +localConversations :: [ConvId] -> Galley r [Conversation] localConversations [] = return [] localConversations ids = do - convs <- async fetchConvs - mems <- async $ memberLists ids - remoteMems <- async $ remoteMemberLists ids - cs <- zipWith4 toConv ids <$> wait mems <*> wait remoteMems <*> wait convs + cs <- liftClient $ do + convs <- UnliftIO.async fetchConvs + mems <- UnliftIO.async $ memberLists ids + remoteMems <- UnliftIO.async $ remoteMemberLists ids + zipWith4 toConv ids + <$> UnliftIO.wait mems + <*> UnliftIO.wait remoteMems + <*> UnliftIO.wait convs foldrM flatten [] (zip ids cs) where fetchConvs = do @@ -551,7 +554,7 @@ toConv cid mms remoteMems conv = where 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 -conversationMeta :: MonadClient m => Domain -> ConvId -> m (Maybe ConversationMetadata) +conversationMeta :: Domain -> ConvId -> Galley r (Maybe ConversationMetadata) conversationMeta _localDomain conv = fmap toConvMeta <$> retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) @@ -569,11 +572,10 @@ conversationMeta _localDomain conv = -- | Deprecated, use 'localConversationIdsPageFrom' conversationIdsFrom :: - (MonadClient m) => UserId -> Maybe ConvId -> Range 1 1000 Int32 -> - m (ResultSet ConvId) + Galley r (ResultSet ConvId) conversationIdsFrom usr start (fromRange -> max) = mkResultSet . strip . fmap runIdentity <$> case start of Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) (max + 1)) @@ -582,19 +584,18 @@ conversationIdsFrom usr start (fromRange -> max) = strip p = p {result = take (fromIntegral max) (result p)} localConversationIdsPageFrom :: - (MonadClient m) => UserId -> Maybe PagingState -> Range 1 1000 Int32 -> - m (PageWithState ConvId) + Galley r (PageWithState ConvId) localConversationIdsPageFrom usr pagingState (fromRange -> max) = fmap runIdentity <$> paginateWithState Cql.selectUserConvs (paramsPagingState Quorum (Identity usr) max pagingState) -remoteConversationIdsPageFrom :: (MonadClient m) => UserId -> Maybe PagingState -> Int32 -> m (PageWithState (Qualified ConvId)) +remoteConversationIdsPageFrom :: UserId -> Maybe PagingState -> Int32 -> Galley r (PageWithState (Qualified ConvId)) remoteConversationIdsPageFrom usr pagingState max = uncurry (flip Qualified) <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState Quorum (Identity usr) max pagingState) -localConversationIdRowsForPagination :: MonadClient m => UserId -> Maybe ConvId -> Range 1 1000 Int32 -> m (Page ConvId) +localConversationIdRowsForPagination :: UserId -> Maybe ConvId -> Range 1 1000 Int32 -> Galley r (Page ConvId) localConversationIdRowsForPagination usr start (fromRange -> max) = runIdentity <$$> case start of @@ -603,24 +604,24 @@ localConversationIdRowsForPagination usr start (fromRange -> max) = -- | Takes a list of conversation ids and returns those found for the given -- user. -localConversationIdsOf :: forall m. (MonadClient m, MonadUnliftIO m) => UserId -> [ConvId] -> m [ConvId] +localConversationIdsOf :: UserId -> [ConvId] -> Galley r [ConvId] localConversationIdsOf usr cids = do runIdentity <$$> retry x1 (query Cql.selectUserConvsIn (params Quorum (usr, cids))) -- | Takes a list of remote conversation ids and fetches member status flags -- for the given user remoteConversationStatus :: - (MonadClient m, MonadUnliftIO m) => UserId -> [Remote ConvId] -> - m (Map (Remote ConvId) MemberStatus) + Galley r (Map (Remote ConvId) MemberStatus) remoteConversationStatus uid = - fmap mconcat - . pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomain uid) + liftClient + . fmap mconcat + . UnliftIO.pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomainC uid) . bucketRemote -remoteConversationStatusOnDomain :: MonadClient m => UserId -> Remote [ConvId] -> m (Map (Remote ConvId) MemberStatus) -remoteConversationStatusOnDomain uid rconvs = +remoteConversationStatusOnDomainC :: UserId -> Remote [ConvId] -> Client (Map (Remote ConvId) MemberStatus) +remoteConversationStatusOnDomainC uid rconvs = Map.fromList . map toPair <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, tDomain rconvs, tUnqualified rconvs)) where @@ -629,12 +630,11 @@ remoteConversationStatusOnDomain uid rconvs = toMemberStatus (omus, omur, oar, oarr, hid, hidr) ) -conversationsRemote :: (MonadClient m) => UserId -> m [Remote ConvId] +conversationsRemote :: UserId -> Galley r [Remote ConvId] conversationsRemote usr = do uncurry toRemoteUnsafe <$$> retry x1 (query Cql.selectUserRemoteConvs (params Quorum (Identity usr))) createConversation :: - MonadClient m => Local UserId -> Maybe (Range 1 256 Text) -> [Access] -> @@ -645,7 +645,7 @@ createConversation :: Maybe Milliseconds -> Maybe ReceiptMode -> RoleName -> - m Conversation + Galley r Conversation createConversation lusr name acc role others tinfo mtimer recpt othersConversationRole = do conv <- Id <$> liftIO nextRandom let lconv = qualifyAs lusr conv @@ -662,7 +662,7 @@ createConversation lusr name acc role others tinfo mtimer recpt othersConversati (lmems, rmems) <- addMembers lconv (ulAddLocal (tUnqualified lusr, roleNameWireAdmin) newUsers) pure $ newConv conv RegularConv usr lmems rmems acc role name (cnvTeamId <$> tinfo) mtimer recpt -createSelfConversation :: MonadClient m => Local UserId -> Maybe (Range 1 256 Text) -> m Conversation +createSelfConversation :: Local UserId -> Maybe (Range 1 256 Text) -> Galley r Conversation createSelfConversation lusr name = do let usr = tUnqualified lusr conv = selfConv usr @@ -673,12 +673,11 @@ createSelfConversation lusr name = do pure $ newConv conv SelfConv usr lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing createConnectConversation :: - MonadClient m => Local x -> U.UUID U.V4 -> U.UUID U.V4 -> Maybe (Range 1 256 Text) -> - m Conversation + Galley r Conversation createConnectConversation loc a b name = do let conv = localOne2OneConvId a b lconv = qualifyAs loc conv @@ -691,11 +690,10 @@ createConnectConversation loc a b name = do pure $ newConv conv ConnectConv a' lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing createConnectConversationWithRemote :: - MonadClient m => Local ConvId -> Local UserId -> UserList UserId -> - m () + Galley r () createConnectConversationWithRemote lconvId creator m = do retry x5 $ write Cql.insertConv (params Quorum (tUnqualified lconvId, ConnectConv, tUnqualified creator, privateOnly, privateRole, Nothing, Nothing, Nothing, Nothing)) @@ -704,13 +702,12 @@ createConnectConversationWithRemote lconvId creator m = do void $ addMembers lconvId m createLegacyOne2OneConversation :: - MonadClient m => Local x -> U.UUID U.V4 -> U.UUID U.V4 -> Maybe (Range 1 256 Text) -> Maybe TeamId -> - m Conversation + Galley r Conversation createLegacyOne2OneConversation loc a b name ti = do let conv = localOne2OneConvId a b lconv = qualifyAs loc conv @@ -724,13 +721,12 @@ createLegacyOne2OneConversation loc a b name ti = do ti createOne2OneConversation :: - MonadClient m => Local ConvId -> Local UserId -> Qualified UserId -> Maybe (Range 1 256 Text) -> Maybe TeamId -> - m Conversation + Galley r Conversation createOne2OneConversation lconv self other name mtid = do retry x5 $ case mtid of Nothing -> write Cql.insertConv (params Quorum (tUnqualified lconv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) @@ -742,38 +738,41 @@ createOne2OneConversation lconv self other name mtid = do (lmems, rmems) <- addMembers lconv (toUserList self [qUntagged self, other]) pure $ newConv (tUnqualified lconv) One2OneConv (tUnqualified self) lmems rmems [PrivateAccess] privateRole name mtid Nothing Nothing -updateConversation :: MonadClient m => ConvId -> Range 1 256 Text -> m () +updateConversation :: ConvId -> Range 1 256 Text -> Galley r () updateConversation cid name = retry x5 $ write Cql.updateConvName (params Quorum (fromRange name, cid)) -updateConversationAccess :: MonadClient m => ConvId -> ConversationAccessData -> m () +updateConversationAccess :: ConvId -> ConversationAccessData -> Galley r () updateConversationAccess cid (ConversationAccessData acc role) = retry x5 $ write Cql.updateConvAccess (params Quorum (Set (toList acc), role, cid)) -updateConversationReceiptMode :: MonadClient m => ConvId -> ReceiptMode -> m () +updateConversationReceiptMode :: ConvId -> ReceiptMode -> Galley r () updateConversationReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMode (params Quorum (receiptMode, cid)) -lookupReceiptMode :: MonadClient m => ConvId -> m (Maybe ReceiptMode) +lookupReceiptMode :: ConvId -> Galley r (Maybe ReceiptMode) lookupReceiptMode cid = join . fmap runIdentity <$> retry x1 (query1 Cql.selectReceiptMode (params Quorum (Identity cid))) -updateConversationMessageTimer :: MonadClient m => ConvId -> Maybe Milliseconds -> m () +updateConversationMessageTimer :: ConvId -> Maybe Milliseconds -> Galley r () updateConversationMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params Quorum (mtimer, cid)) -deleteConversation :: (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> m () -deleteConversation cid = do +deleteConversation :: ConvId -> Galley r () +deleteConversation = liftClient . deleteConversationC + +deleteConversationC :: ConvId -> Client () +deleteConversationC cid = do retry x5 $ write Cql.markConvDeleted (params Quorum (Identity cid)) - localMembers <- members cid + localMembers <- membersC cid for_ (nonEmpty localMembers) $ \ms -> - removeLocalMembersFromLocalConv cid (lmId <$> ms) + removeLocalMembersFromLocalConvC cid (lmId <$> ms) - remoteMembers <- lookupRemoteMembers cid + remoteMembers <- lookupRemoteMembersC cid for_ (nonEmpty remoteMembers) $ \ms -> - removeRemoteMembersFromLocalConv cid (rmId <$> ms) + removeRemoteMembersFromLocalConvC cid (rmId <$> ms) retry x5 $ write Cql.deleteConv (params Quorum (Identity cid)) -acceptConnect :: MonadClient m => ConvId -> m () +acceptConnect :: ConvId -> Galley r () acceptConnect cid = retry x5 $ write Cql.updateConvType (params Quorum (One2OneConv, cid)) -- | We deduce the conversation ID by adding the 4 components of the V4 UUID @@ -863,18 +862,14 @@ privateOnly = Set [PrivateAccess] -- Conversation Members ----------------------------------------------------- member :: - (MonadClient m, Log.MonadLogger m, MonadThrow m) => ConvId -> UserId -> - m (Maybe LocalMember) + Galley r (Maybe LocalMember) member cnv usr = (toMember =<<) <$> retry x1 (query1 Cql.selectMember (params Quorum (cnv, usr))) -remoteMemberLists :: - (MonadClient m) => - [ConvId] -> - m [[RemoteMember]] +remoteMemberLists :: [ConvId] -> Client [[RemoteMember]] remoteMemberLists convs = do mems <- retry x1 $ query Cql.selectRemoteMembers (params Quorum (Identity convs)) let convMembers = foldr (insert . mkMem) Map.empty mems @@ -888,10 +883,7 @@ remoteMemberLists convs = do toRemoteMember :: UserId -> Domain -> RoleName -> RemoteMember toRemoteMember u d = RemoteMember (toRemoteUnsafe d u) -memberLists :: - (MonadClient m, MonadThrow m) => - [ConvId] -> - m [[LocalMember]] +memberLists :: [ConvId] -> Client [[LocalMember]] memberLists convs = do mems <- retry x1 $ query Cql.selectMembers (params Quorum (Identity convs)) let convMembers = foldr (\m acc -> insert (mkMem m) acc) mempty mems @@ -904,14 +896,20 @@ memberLists convs = do mkMem (cnv, usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn) = (cnv, toMember (usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn)) -members :: (MonadClient m, MonadThrow m) => ConvId -> m [LocalMember] -members conv = join <$> memberLists [conv] +members :: ConvId -> Galley r [LocalMember] +members = liftClient . membersC + +membersC :: ConvId -> Client [LocalMember] +membersC = fmap concat . liftClient . memberLists . pure -lookupRemoteMembers :: (MonadClient m) => ConvId -> m [RemoteMember] -lookupRemoteMembers conv = join <$> remoteMemberLists [conv] +lookupRemoteMembers :: ConvId -> Galley r [RemoteMember] +lookupRemoteMembers = liftClient . lookupRemoteMembersC + +lookupRemoteMembersC :: ConvId -> Client [RemoteMember] +lookupRemoteMembersC conv = join <$> remoteMemberLists [conv] -- | Add a member to a local conversation, as an admin. -addMember :: MonadClient m => Local ConvId -> Local UserId -> m [LocalMember] +addMember :: Local ConvId -> Local UserId -> Galley r [LocalMember] addMember c u = fst <$> addMembers c (UserList [tUnqualified u] []) class ToUserRole a where @@ -932,12 +930,7 @@ toQualifiedUserRole = requalify . fmap toUserRole -- Conversation is local, so we can add any member to it (including remote ones). -- When the role is not specified, it defaults to admin. -- Please make sure the conversation doesn't exceed the maximum size! -addMembers :: - forall m a. - (MonadClient m, ToUserRole a) => - Local ConvId -> - UserList a -> - m ([LocalMember], [RemoteMember]) +addMembers :: ToUserRole a => Local ConvId -> UserList a -> Galley r ([LocalMember], [RemoteMember]) addMembers (tUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = do -- batch statement with 500 users are known to be above the batch size limit -- and throw "Batch too large" errors. Therefor we chunk requests and insert @@ -973,7 +966,7 @@ addMembers (tUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = -- | Set local users as belonging to a remote conversation. This is invoked by a -- remote galley when users from the current backend are added to conversations -- on the remote end. -addLocalMembersToRemoteConv :: MonadClient m => Remote ConvId -> [UserId] -> m () +addLocalMembersToRemoteConv :: Remote ConvId -> [UserId] -> Galley r () addLocalMembersToRemoteConv _ [] = pure () addLocalMembersToRemoteConv rconv users = do -- FUTUREWORK: consider using pooledMapConcurrentlyN @@ -987,20 +980,18 @@ addLocalMembersToRemoteConv rconv users = do (u, tDomain rconv, tUnqualified rconv) updateSelfMember :: - MonadClient m => Local x -> Qualified ConvId -> Local UserId -> MemberUpdate -> - m () + Galley r () updateSelfMember loc = foldQualified loc updateSelfMemberLocalConv updateSelfMemberRemoteConv updateSelfMemberLocalConv :: - MonadClient m => Local ConvId -> Local UserId -> MemberUpdate -> - m () + Galley r () updateSelfMemberLocalConv lcid luid mup = do retry x5 . batch $ do setType BatchUnLogged @@ -1019,11 +1010,10 @@ updateSelfMemberLocalConv lcid luid mup = do (h, mupHiddenRef mup, tUnqualified lcid, tUnqualified luid) updateSelfMemberRemoteConv :: - MonadClient m => Remote ConvId -> Local UserId -> MemberUpdate -> - m () + Galley r () updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do retry x5 . batch $ do setType BatchUnLogged @@ -1042,20 +1032,18 @@ updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do (h, mupHiddenRef mup, domain, cid, tUnqualified luid) updateOtherMember :: - MonadClient m => Local x -> Qualified ConvId -> Qualified UserId -> OtherMemberUpdate -> - m () + Galley r () updateOtherMember loc = foldQualified loc updateOtherMemberLocalConv updateOtherMemberRemoteConv updateOtherMemberLocalConv :: - MonadClient m => Local ConvId -> Qualified UserId -> OtherMemberUpdate -> - m () + Galley r () updateOtherMemberLocalConv lcid quid omu = do let addQuery r @@ -1074,34 +1062,36 @@ updateOtherMemberLocalConv lcid quid omu = -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-887 updateOtherMemberRemoteConv :: - MonadClient m => Remote ConvId -> Qualified UserId -> OtherMemberUpdate -> - m () + Galley r () updateOtherMemberRemoteConv _ _ _ = pure () -- | Select only the members of a remote conversation from a list of users. -- Return the filtered list and a boolean indicating whether the all the input -- users are members. -filterRemoteConvMembers :: (MonadUnliftIO m, MonadClient m) => [UserId] -> Qualified ConvId -> m ([UserId], Bool) +filterRemoteConvMembers :: + [UserId] -> + Qualified ConvId -> + Galley r ([UserId], Bool) filterRemoteConvMembers users (Qualified conv dom) = - fmap Data.Monoid.getAll - . foldMap (\muser -> (muser, Data.Monoid.All (not (null muser)))) - <$> pooledMapConcurrentlyN 8 filterMember users + liftClient $ + fmap Data.Monoid.getAll + . foldMap (\muser -> (muser, Data.Monoid.All (not (null muser)))) + <$> UnliftIO.pooledMapConcurrentlyN 8 filterMember users where - filterMember :: MonadClient m => UserId -> m [UserId] + filterMember :: UserId -> Client [UserId] filterMember user = fmap (map runIdentity) . retry x1 $ query Cql.selectRemoteConvMembers (params Quorum (user, dom, conv)) -removeLocalMembersFromLocalConv :: - MonadClient m => - ConvId -> - NonEmpty UserId -> - m () -removeLocalMembersFromLocalConv cnv victims = do +removeLocalMembersFromLocalConv :: ConvId -> NonEmpty UserId -> Galley r () +removeLocalMembersFromLocalConv cnv = liftClient . removeLocalMembersFromLocalConvC cnv + +removeLocalMembersFromLocalConvC :: ConvId -> NonEmpty UserId -> Client () +removeLocalMembersFromLocalConvC cnv victims = do retry x5 . batch $ do setType BatchLogged setConsistency Quorum @@ -1109,12 +1099,11 @@ removeLocalMembersFromLocalConv cnv victims = do addPrepQuery Cql.removeMember (cnv, victim) addPrepQuery Cql.deleteUserConv (victim, cnv) -removeRemoteMembersFromLocalConv :: - MonadClient m => - ConvId -> - NonEmpty (Remote UserId) -> - m () -removeRemoteMembersFromLocalConv cnv victims = do +removeRemoteMembersFromLocalConv :: ConvId -> NonEmpty (Remote UserId) -> Galley r () +removeRemoteMembersFromLocalConv cnv = liftClient . removeRemoteMembersFromLocalConvC cnv + +removeRemoteMembersFromLocalConvC :: ConvId -> NonEmpty (Remote UserId) -> Client () +removeRemoteMembersFromLocalConvC cnv victims = do retry x5 . batch $ do setType BatchLogged setConsistency Quorum @@ -1122,12 +1111,11 @@ removeRemoteMembersFromLocalConv cnv victims = do addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) removeLocalMembersFromRemoteConv :: - MonadClient m => -- | The conversation to remove members from Remote ConvId -> -- | Members to remove local to this backend [UserId] -> - m () + Galley r () removeLocalMembersFromRemoteConv _ [] = pure () removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victims = retry x5 . batch $ do @@ -1135,7 +1123,7 @@ removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victim setConsistency Quorum for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) -removeMember :: MonadClient m => UserId -> ConvId -> m () +removeMember :: UserId -> ConvId -> Galley r () removeMember usr cnv = retry x5 . batch $ do setType BatchLogged setConsistency Quorum @@ -1213,25 +1201,26 @@ toMember _ = Nothing -- Clients ------------------------------------------------------------------ -updateClient :: MonadClient m => Bool -> UserId -> ClientId -> m () +updateClient :: Bool -> UserId -> ClientId -> Galley r () updateClient add usr cls = do let q = if add then Cql.addMemberClient else Cql.rmMemberClient retry x5 $ write (q cls) (params Quorum (Identity usr)) -- Do, at most, 16 parallel lookups of up to 128 users each -lookupClients :: - (MonadClient m, MonadUnliftIO m) => - [UserId] -> - m Clients -lookupClients users = +lookupClients :: [UserId] -> Galley r Clients +lookupClients = liftClient . lookupClients' + +-- This is only used by tests +lookupClients' :: [UserId] -> Client Clients +lookupClients' users = Clients.fromList . concat . concat - <$> forM (chunksOf 2048 users) (mapConcurrently getClients . chunksOf 128) + <$> forM (chunksOf 2048 users) (UnliftIO.mapConcurrently getClients . chunksOf 128) where getClients us = map (second fromSet) <$> retry x1 (query Cql.selectClients (params Quorum (Identity us))) -eraseClients :: MonadClient m => UserId -> m () +eraseClients :: UserId -> Galley r () eraseClients user = retry x5 (write Cql.rmClients (params Quorum (Identity user))) -- Internal utilities @@ -1242,11 +1231,11 @@ eraseClients user = retry x5 (write Cql.rmClients (params Quorum (Identity user) -- -- Throw an exception if one of invitation timestamp and inviter is 'Nothing' and the -- other is 'Just', which can only be caused by inconsistent database content. -newTeamMember' :: (MonadIO m, MonadThrow m, MonadClient m, MonadReader Env m) => TeamId -> (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> m TeamMember +newTeamMember' :: TeamId -> (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> Galley r TeamMember newTeamMember' tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus -> lhStatus) = do mk minvu minvt >>= maybeGrant where - maybeGrant :: (MonadClient m, MonadReader Env m) => TeamMember -> m TeamMember + maybeGrant :: TeamMember -> Galley r TeamMember maybeGrant m = ifM (isTeamLegalholdWhitelisted tid) @@ -1271,8 +1260,8 @@ newTeamMember' tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus - -- which are looked up based on: withTeamMembersWithChunks :: TeamId -> - ([TeamMember] -> Galley ()) -> - Galley () + ([TeamMember] -> Galley r ()) -> + Galley r () withTeamMembersWithChunks tid action = do mems <- teamMembersForPagination tid Nothing (unsafeRange hardTruncationLimit) handleMembers mems diff --git a/services/galley/src/Galley/Data/Services.hs b/services/galley/src/Galley/Data/Services.hs index 3d4f01108ed..f47bf123648 100644 --- a/services/galley/src/Galley/Data/Services.hs +++ b/services/galley/src/Galley/Data/Services.hs @@ -67,7 +67,7 @@ botMemId = BotId . lmId . fromBotMember botMemService :: BotMember -> ServiceRef botMemService = fromJust . lmService . fromBotMember -addBotMember :: Qualified UserId -> ServiceRef -> BotId -> ConvId -> UTCTime -> Galley (Event, BotMember) +addBotMember :: Qualified UserId -> ServiceRef -> BotId -> ConvId -> UTCTime -> Galley r (Event, BotMember) addBotMember qorig s bot cnv now = do retry x5 . batch $ do setType BatchLogged diff --git a/services/galley/src/Galley/Data/TeamNotifications.hs b/services/galley/src/Galley/Data/TeamNotifications.hs index 1922c1580ab..d5c7689538f 100644 --- a/services/galley/src/Galley/Data/TeamNotifications.hs +++ b/services/galley/src/Galley/Data/TeamNotifications.hs @@ -37,6 +37,7 @@ import Data.List1 (List1) import Data.Range (Range, fromRange) import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (><)) import qualified Data.Sequence as Seq +import Galley.App import Gundeck.Types.Notification import Imports @@ -51,11 +52,10 @@ data ResultPage = ResultPage -- FUTUREWORK: the magic 32 should be made configurable, so it can be tuned add :: - (MonadClient m, MonadUnliftIO m) => TeamId -> NotificationId -> List1 JSON.Object -> - m () + Galley r () add tid nid (Blob . JSON.encode -> payload) = write cqlInsert (params Quorum (tid, nid, payload, notificationTTLSeconds)) & retry x5 where @@ -69,7 +69,7 @@ add tid nid (Blob . JSON.encode -> payload) = notificationTTLSeconds :: Int32 notificationTTLSeconds = 24192200 -fetch :: forall m. MonadClient m => TeamId -> Maybe NotificationId -> Range 1 10000 Int32 -> m ResultPage +fetch :: TeamId -> Maybe NotificationId -> Range 1 10000 Int32 -> Galley r ResultPage fetch tid since (fromRange -> size) = do -- We always need to look for one more than requested in order to correctly -- report whether there are more results. @@ -90,7 +90,11 @@ fetch tid since (fromRange -> size) = do EmptyL -> ResultPage Seq.empty False (x :< xs) -> ResultPage (x <| xs) more where - collect :: Seq QueuedNotification -> Int -> Page (TimeUuid, Blob) -> m (Seq QueuedNotification, Bool) + collect :: + Seq QueuedNotification -> + Int -> + Page (TimeUuid, Blob) -> + Galley r (Seq QueuedNotification, Bool) collect acc num page = let ns = splitAt num $ foldr toNotif [] (result page) nseq = Seq.fromList (fst ns) diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs new file mode 100644 index 00000000000..78aceb69541 --- /dev/null +++ b/services/galley/src/Galley/Effects.hs @@ -0,0 +1,109 @@ +-- 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 + ( -- * Effects needed in Galley + GalleyEffects1, + + -- * Internal services + Intra, + interpretIntra, + + -- * Brig + BrigAccess, + interpretBrig, + + -- * Federator + FederatorAccess, + interpretFederator, + + -- * Spar + SparAccess, + interpretSpar, + + -- * Gundeck + GundeckAccess, + interpretGundeck, + + -- * External services + ExternalAccess, + interpretExternal, + + -- * Bot API + BotAccess, + interpretBot, + + -- * Fire-and-forget async + FireAndForget, + interpretFireAndForget, + + -- * Polysemy re-exports + Member, + Members, + ) +where + +import Galley.Effects.FireAndForget +import Imports +import Polysemy + +data Intra m a + +interpretIntra :: Sem (Intra ': r) a -> Sem r a +interpretIntra = interpret $ \case + +data BrigAccess m a + +interpretBrig :: Sem (BrigAccess ': r) a -> Sem r a +interpretBrig = interpret $ \case + +data GundeckAccess m a + +interpretGundeck :: Sem (GundeckAccess ': r) a -> Sem r a +interpretGundeck = interpret $ \case + +data ExternalAccess m a + +interpretExternal :: Sem (ExternalAccess ': r) a -> Sem r a +interpretExternal = interpret $ \case + +data FederatorAccess m a + +interpretFederator :: Sem (FederatorAccess ': r) a -> Sem r a +interpretFederator = interpret $ \case + +data SparAccess m a + +interpretSpar :: Sem (SparAccess ': r) a -> Sem r a +interpretSpar = interpret $ \case + +data BotAccess m a + +interpretBot :: Sem (BotAccess ': r) a -> Sem r a +interpretBot = interpret $ \case + +-- All the possible high-level effects. +type GalleyEffects1 = + '[ BrigAccess, + GundeckAccess, + SparAccess, + ExternalAccess, + FederatorAccess, + BotAccess, + Intra, + FireAndForget + ] diff --git a/services/galley/src/Galley/Effects/FireAndForget.hs b/services/galley/src/Galley/Effects/FireAndForget.hs new file mode 100644 index 00000000000..4b614862a35 --- /dev/null +++ b/services/galley/src/Galley/Effects/FireAndForget.hs @@ -0,0 +1,48 @@ +-- 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.FireAndForget + ( FireAndForget, + fireAndForget, + spawnMany, + interpretFireAndForget, + ) +where + +import Imports +import Polysemy +import Polysemy.Final +import UnliftIO.Async (pooledMapConcurrentlyN_) + +data FireAndForget m a where + FireAndForgetOne :: m () -> FireAndForget m () + SpawnMany :: [m ()] -> FireAndForget m () + +makeSem ''FireAndForget + +fireAndForget :: Member FireAndForget r => Sem r () -> Sem r () +fireAndForget = fireAndForgetOne + +interpretFireAndForget :: Member (Final IO) r => Sem (FireAndForget ': r) a -> Sem r a +interpretFireAndForget = interpretFinal @IO $ \case + FireAndForgetOne action -> do + action' <- runS action + liftS $ void . forkIO . void $ action' + SpawnMany actions -> do + actions' <- traverse runS actions + -- I picked this number by fair dice roll, feel free to change it :P + liftS $ pooledMapConcurrentlyN_ 8 void actions' diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index 4b8b7994a82..eb2024ee2d7 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -17,6 +17,8 @@ module Galley.External ( deliver, + deliverAndDeleteAsync, + deliverAsync, ) where @@ -25,10 +27,13 @@ import Bilge.Retry (httpHandlers) import Control.Lens import Control.Retry import Data.ByteString.Conversion.To +import Data.Id import Data.Misc import Galley.App import Galley.Data.Services (BotMember, botMemId, botMemService) import qualified Galley.Data.Services as Data +import Galley.Effects +import Galley.Intra.User import Galley.Types (Event) import Galley.Types.Bot import Imports @@ -41,22 +46,41 @@ import System.Logger.Message (field, msg, val, (~~)) import URI.ByteString import UnliftIO (Async, async, waitCatch) +-- | Like deliver, but ignore orphaned bots and return immediately. +-- +-- FUTUREWORK: Check if this can be removed. +deliverAsync :: Member ExternalAccess r => [(BotMember, Event)] -> Galley r () +deliverAsync = liftGalley0 . void . forkIO . void . deliver0 + +-- | Like deliver, but remove orphaned bots and return immediately. +deliverAndDeleteAsync :: + Members '[ExternalAccess, BotAccess] r => + ConvId -> + [(BotMember, Event)] -> + Galley r () +deliverAndDeleteAsync cnv pushes = liftGalley0 . void . forkIO $ do + gone <- liftGalley0 $ deliver0 pushes + mapM_ (deleteBot0 cnv . botMemId) gone + -- | Deliver events to external (bot) services. -- -- Returns those bots which are found to be orphaned by the external -- service, e.g. when the service tells us that it no longer knows about the -- bot. -deliver :: [(BotMember, Event)] -> Galley [BotMember] -deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) +deliver :: Member ExternalAccess r => [(BotMember, Event)] -> Galley r [BotMember] +deliver = liftGalley0 . deliver0 + +deliver0 :: [(BotMember, Event)] -> Galley0 [BotMember] +deliver0 pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) where - exec :: (BotMember, Event) -> Galley Bool + exec :: (BotMember, Event) -> Galley0 Bool exec (b, e) = Data.lookupService (botMemService b) >>= \case Nothing -> return False Just s -> do deliver1 s b e return True - eval :: [BotMember] -> (BotMember, Async Bool) -> Galley [BotMember] + eval :: [BotMember] -> (BotMember, Async Bool) -> Galley r [BotMember] eval gone (b, a) = do let s = botMemService b r <- waitCatch a @@ -95,7 +119,7 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) -- Internal ------------------------------------------------------------------- -deliver1 :: Service -> BotMember -> Event -> Galley () +deliver1 :: Service -> BotMember -> Event -> Galley0 () deliver1 s bm e | s ^. serviceEnabled = do let t = toByteString' (s ^. serviceToken) @@ -125,7 +149,7 @@ urlPort (HttpsUrl u) = do p <- a ^. authorityPortL return (fromIntegral (p ^. portNumberL)) -sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> Galley () +sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> Galley r () 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 67d2f6bd9ac..133b4cf4134 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -67,7 +67,7 @@ import URI.ByteString (uriPath) -- api -- | Get /status from legal hold service; throw 'Wai.Error' if things go wrong. -checkLegalHoldServiceStatus :: Fingerprint Rsa -> HttpsUrl -> Galley () +checkLegalHoldServiceStatus :: Fingerprint Rsa -> HttpsUrl -> Galley r () checkLegalHoldServiceStatus fpr url = do resp <- makeVerifiedRequestFreshManager fpr url reqBuilder if @@ -83,7 +83,7 @@ checkLegalHoldServiceStatus fpr url = do . Bilge.expect2xx -- | @POST /initiate@. -requestNewDevice :: TeamId -> UserId -> Galley NewLegalHoldClient +requestNewDevice :: TeamId -> UserId -> Galley r NewLegalHoldClient requestNewDevice tid uid = do resp <- makeLegalHoldServiceRequest tid reqParams case eitherDecode (responseBody resp) of @@ -107,7 +107,7 @@ confirmLegalHold :: UserId -> -- | TODO: Replace with 'LegalHold' token type OpaqueAuthToken -> - Galley () + Galley r () confirmLegalHold clientId tid uid legalHoldAuthToken = do void $ makeLegalHoldServiceRequest tid reqParams where @@ -123,7 +123,7 @@ confirmLegalHold clientId tid uid legalHoldAuthToken = do removeLegalHold :: TeamId -> UserId -> - Galley () + Galley r () removeLegalHold tid uid = do void $ makeLegalHoldServiceRequest tid reqParams where @@ -140,7 +140,7 @@ removeLegalHold tid uid = do -- | Lookup legal hold service settings for a team and make a request to the service. Pins -- the TSL fingerprint via 'makeVerifiedRequest' and passes the token so the service can -- authenticate the request. -makeLegalHoldServiceRequest :: TeamId -> (Http.Request -> Http.Request) -> Galley (Http.Response LC8.ByteString) +makeLegalHoldServiceRequest :: TeamId -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) makeLegalHoldServiceRequest tid reqBuilder = do maybeLHSettings <- LegalHoldData.getSettings tid lhSettings <- case maybeLHSettings of @@ -157,7 +157,7 @@ makeLegalHoldServiceRequest tid reqBuilder = do reqBuilder . Bilge.header "Authorization" ("Bearer " <> toByteString' token) -makeVerifiedRequest :: Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> Galley (Http.Response LC8.ByteString) +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 @@ -166,23 +166,24 @@ makeVerifiedRequest fpr url reqBuilder = do -- 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 (Http.Response LC8.ByteString) +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 (Http.Response LC8.ByteString) +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] - extHandleAll errHandler $ do - recovering x3 httpHandlers $ - const $ - liftIO $ - withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ - \req -> - Http.httpLbs req mgr + 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) diff --git a/services/galley/src/Galley/Intra/Client.hs b/services/galley/src/Galley/Intra/Client.hs index b45043dac89..f0a941d0a39 100644 --- a/services/galley/src/Galley/Intra/Client.hs +++ b/services/galley/src/Galley/Intra/Client.hs @@ -39,6 +39,7 @@ import qualified Data.Set as Set import Data.Text.Encoding import Galley.API.Error import Galley.App +import Galley.Effects import Galley.External.LegalHoldService import Galley.Intra.Util import Imports @@ -49,11 +50,11 @@ import qualified System.Logger.Class as Logger import Wire.API.User.Client (UserClients, UserClientsFull, filterClients, filterClientsFull) -- | Calls 'Brig.API.internalListClientsH'. -lookupClients :: [UserId] -> Galley UserClients +lookupClients :: Member BrigAccess r => [UserId] -> Galley r UserClients lookupClients uids = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort . path "/i/clients" . json (UserSet $ Set.fromList uids) @@ -62,11 +63,14 @@ lookupClients uids = do return $ filterClients (not . Set.null) clients -- | Calls 'Brig.API.internalListClientsFullH'. -lookupClientsFull :: [UserId] -> Galley UserClientsFull +lookupClientsFull :: + Member BrigAccess r => + [UserId] -> + Galley r UserClientsFull lookupClientsFull uids = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort . path "/i/clients/full" . json (UserSet $ Set.fromList uids) @@ -75,10 +79,15 @@ lookupClientsFull uids = do return $ filterClientsFull (not . Set.null) clients -- | Calls 'Brig.API.legalHoldClientRequestedH'. -notifyClientsAboutLegalHoldRequest :: UserId -> UserId -> LastPrekey -> Galley () +notifyClientsAboutLegalHoldRequest :: + Member BrigAccess r => + UserId -> + UserId -> + LastPrekey -> + Galley r () notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do (brigHost, brigPort) <- brigReq - void . call "brig" $ + void . callBrig $ method POST . host brigHost . port brigPort @@ -87,11 +96,15 @@ notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do . expect2xx -- | Calls 'Brig.User.API.Auth.legalHoldLoginH'. -getLegalHoldAuthToken :: UserId -> Maybe PlainTextPassword -> Galley OpaqueAuthToken +getLegalHoldAuthToken :: + Member BrigAccess r => + UserId -> + Maybe PlainTextPassword -> + Galley r OpaqueAuthToken getLegalHoldAuthToken uid pw = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort @@ -106,7 +119,13 @@ getLegalHoldAuthToken uid pw = do Just c -> pure . OpaqueAuthToken . decodeUtf8 $ c -- | Calls 'Brig.API.addClientInternalH'. -addLegalHoldClientToUser :: UserId -> ConnId -> [Prekey] -> LastPrekey -> Galley ClientId +addLegalHoldClientToUser :: + Member BrigAccess r => + UserId -> + ConnId -> + [Prekey] -> + LastPrekey -> + Galley r ClientId addLegalHoldClientToUser uid connId prekeys lastPrekey' = do clientId <$> brigAddClient uid connId lhClient where @@ -123,10 +142,13 @@ addLegalHoldClientToUser uid connId prekeys lastPrekey' = do Nothing -- | Calls 'Brig.API.removeLegalHoldClientH'. -removeLegalHoldClientFromUser :: UserId -> Galley () +removeLegalHoldClientFromUser :: + Member BrigAccess r => + UserId -> + Galley r () removeLegalHoldClientFromUser targetUid = do (brigHost, brigPort) <- brigReq - void . call "brig" $ + void . callBrig $ method DELETE . host brigHost . port brigPort @@ -135,11 +157,11 @@ removeLegalHoldClientFromUser targetUid = do . expect2xx -- | Calls 'Brig.API.addClientInternalH'. -brigAddClient :: UserId -> ConnId -> NewClient -> Galley Client +brigAddClient :: Member BrigAccess r => UserId -> ConnId -> NewClient -> Galley r Client brigAddClient uid connId client = do (brigHost, brigPort) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host brigHost . port brigPort diff --git a/services/galley/src/Galley/Intra/Journal.hs b/services/galley/src/Galley/Intra/Journal.hs index 234db9ebbac..4cb9e07a3d7 100644 --- a/services/galley/src/Galley/Intra/Journal.hs +++ b/services/galley/src/Galley/Intra/Journal.hs @@ -49,22 +49,22 @@ import qualified System.Logger.Class as Log -- Team journal operations to SQS are a no-op when the service -- is started without journaling arguments -teamActivate :: TeamId -> Natural -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> Galley () +teamActivate :: TeamId -> Natural -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> Galley 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 () +teamUpdate :: TeamId -> Natural -> [UserId] -> Galley r () teamUpdate tid teamSize billingUserIds = journalEvent TeamEvent'TEAM_UPDATE tid (Just $ evData teamSize billingUserIds Nothing) Nothing -teamDelete :: TeamId -> Galley () +teamDelete :: TeamId -> Galley r () teamDelete tid = journalEvent TeamEvent'TEAM_DELETE tid Nothing Nothing -teamSuspend :: TeamId -> Galley () +teamSuspend :: TeamId -> Galley r () teamSuspend tid = journalEvent TeamEvent'TEAM_SUSPEND tid Nothing Nothing -journalEvent :: TeamEvent'EventType -> TeamId -> Maybe TeamEvent'EventData -> Maybe TeamCreationTime -> Galley () +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 @@ -90,7 +90,7 @@ evData memberCount billingUserIds cur = -- FUTUREWORK: Remove this function and always get billing users ids using -- 'Data.listBillingTeamMembers'. This is required only until data is backfilled in the -- 'billing_team_user' table. -getBillingUserIds :: TeamId -> Maybe TeamMemberList -> Galley [UserId] +getBillingUserIds :: TeamId -> Maybe TeamMemberList -> Galley r [UserId] getBillingUserIds tid maybeMemberList = do enableIndexedBillingTeamMembers <- view (options . Opts.optSettings . Opts.setEnableIndexedBillingTeamMembers . to (fromMaybe False)) case maybeMemberList of @@ -100,14 +100,14 @@ getBillingUserIds tid maybeMemberList = do else handleList enableIndexedBillingTeamMembers =<< Data.teamMembersForFanout tid Just list -> handleList enableIndexedBillingTeamMembers list where - fetchFromDB :: Galley [UserId] + fetchFromDB :: Galley r [UserId] fetchFromDB = Data.listBillingTeamMembers tid - filterFromMembers :: TeamMemberList -> Galley [UserId] + filterFromMembers :: TeamMemberList -> Galley r [UserId] filterFromMembers list = pure $ map (view userId) $ filter (`hasPermission` SetBilling) (list ^. teamMembers) - handleList :: Bool -> TeamMemberList -> Galley [UserId] + handleList :: Bool -> TeamMemberList -> Galley r [UserId] handleList enableIndexedBillingTeamMembers list = case list ^. teamMemberListType of ListTruncated -> diff --git a/services/galley/src/Galley/Intra/Push.hs b/services/galley/src/Galley/Intra/Push.hs index 04c2e48b3e1..15f67076140 100644 --- a/services/galley/src/Galley/Intra/Push.hs +++ b/services/galley/src/Galley/Intra/Push.hs @@ -71,16 +71,18 @@ import qualified Data.Set as Set import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import Galley.App +import Galley.Effects import Galley.Options import Galley.Types import qualified Galley.Types.Teams as Teams import Gundeck.Types.Push.V2 (RecipientClients (..)) import qualified Gundeck.Types.Push.V2 as Gundeck -import Imports +import Imports hiding (forkIO) import Network.HTTP.Types.Method import Safe (headDef, tailDef) import System.Logger.Class hiding (new) -import UnliftIO (mapConcurrently) +import UnliftIO.Async (mapConcurrently) +import UnliftIO.Concurrent (forkIO) import Util.Options import qualified Wire.API.Event.FeatureConfig as FeatureConfig @@ -158,14 +160,14 @@ newConversationEventPush localDomain e users = -- | Asynchronously send a single push, chunking it into multiple -- requests if there are more than 128 recipients. -push1 :: Push -> Galley () +push1 :: Member GundeckAccess r => Push -> Galley r () push1 p = push (list1 p []) -pushSome :: [Push] -> Galley () +pushSome :: Member GundeckAccess r => [Push] -> Galley r () pushSome [] = return () pushSome (x : xs) = push (list1 x xs) -push :: List1 Push -> Galley () +push :: Member GundeckAccess r => List1 Push -> Galley r () push ps = do let (localPushes, remotePushes) = foldMap (bimap toList toList . splitPush) (toList ps) traverse_ (pushLocal . List1) (nonEmpty localPushes) @@ -185,13 +187,14 @@ 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 :: List1 (PushTo UserId) -> Galley () +pushLocal :: Member GundeckAccess r => List1 (PushTo UserId) -> Galley r () pushLocal ps = do limit <- fanoutLimit + opts <- view options -- Do not fan out for very large teams - let (async, sync) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) - forM_ (pushes async) $ gundeckReq >=> callAsync "gundeck" - void $ mapConcurrently (gundeckReq >=> call "gundeck") (pushes sync) + let (asyncs, sync) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) + forM_ (pushes asyncs) $ callAsync "gundeck" . gundeckReq opts + void . liftGalley0 $ mapConcurrently (call0 "gundeck" . gundeckReq opts) (pushes sync) return () where pushes = fst . foldr chunk ([], 0) @@ -226,7 +229,7 @@ pushLocal ps = do ) -- instead of IdMapping, we could also just take qualified IDs -pushRemote :: List1 (PushTo UserId) -> Galley () +pushRemote :: List1 (PushTo UserId) -> Galley r () pushRemote _ps = do -- FUTUREWORK(federation, #1261): send these to the other backends pure () @@ -234,27 +237,25 @@ pushRemote _ps = do ----------------------------------------------------------------------------- -- Helpers -gundeckReq :: [Gundeck.Push] -> Galley (Request -> Request) -gundeckReq ps = do - o <- view options - return $ - host (encodeUtf8 $ o ^. optGundeck . epHost) - . port (portNumber $ fromIntegral (o ^. optGundeck . epPort)) - . method POST - . path "/i/push/v2" - . json ps - . expect2xx +gundeckReq :: Opts -> [Gundeck.Push] -> Request -> Request +gundeckReq o ps = + host (encodeUtf8 $ o ^. optGundeck . epHost) + . port (portNumber $ fromIntegral (o ^. optGundeck . epPort)) + . method POST + . path "/i/push/v2" + . json ps + . expect2xx -callAsync :: LT.Text -> (Request -> Request) -> Galley () -callAsync n r = void . forkIO $ void (call n r) `catches` handlers +callAsync :: Member GundeckAccess r => LT.Text -> (Request -> Request) -> Galley r () +callAsync n r = liftGalley0 . void . forkIO $ void (call0 n r) `catches` handlers where handlers = [ Handler $ \(x :: RPCException) -> err (rpcExceptionMsg x), Handler $ \(x :: SomeException) -> err $ "remote" .= n ~~ msg (show x) ] -call :: LT.Text -> (Request -> Request) -> Galley (Response (Maybe LByteString)) -call n r = recovering x3 rpcHandlers (const (rpc n r)) +call0 :: LT.Text -> (Request -> Request) -> Galley0 (Response (Maybe LByteString)) +call0 n r = recovering x3 rpcHandlers (const (rpc n r)) x3 :: RetryPolicy x3 = limitRetries 3 <> exponentialBackoff 100000 diff --git a/services/galley/src/Galley/Intra/Spar.hs b/services/galley/src/Galley/Intra/Spar.hs index 08ec54af70e..c10f3109d38 100644 --- a/services/galley/src/Galley/Intra/Spar.hs +++ b/services/galley/src/Galley/Intra/Spar.hs @@ -24,16 +24,17 @@ import Bilge import Data.ByteString.Conversion import Data.Id import Galley.App +import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Types.Method -- | Notify Spar that a team is being deleted. -deleteTeam :: TeamId -> Galley () +deleteTeam :: Member SparAccess r => TeamId -> Galley r () deleteTeam tid = do (h, p) <- sparReq _ <- - call "spar" $ + callSpar $ method DELETE . host h . port p . paths ["i", "teams", toByteString' tid] . expect2xx diff --git a/services/galley/src/Galley/Intra/Team.hs b/services/galley/src/Galley/Intra/Team.hs index dbf56e2d6b2..50cdcdd345f 100644 --- a/services/galley/src/Galley/Intra/Team.hs +++ b/services/galley/src/Galley/Intra/Team.hs @@ -23,17 +23,18 @@ import Brig.Types.Team import Data.ByteString.Conversion import Data.Id import Galley.App +import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error -getSize :: TeamId -> Galley TeamSize +getSize :: Member BrigAccess r => TeamId -> Galley r TeamSize getSize tid = do (h, p) <- brigReq r <- - call "brig" $ + callBrig $ method GET . host h . port p . paths ["/i/teams", toByteString' tid, "size"] . expect2xx diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index 29a077222a6..faea13c43ea 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -17,6 +17,7 @@ module Galley.Intra.User ( getConnections, + getConnectionsUnqualified0, getConnectionsUnqualified, putConnectionInternal, deleteBot, @@ -28,6 +29,9 @@ module Galley.Intra.User getContactList, chunkify, getRichInfoMultiUser, + + -- * Internal + deleteBot0, ) where @@ -43,6 +47,7 @@ import Data.ByteString.Conversion import Data.Id import Data.Qualified import Galley.App +import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Client (HttpExceptionContent (..)) @@ -59,11 +64,24 @@ import Wire.API.User.RichInfo (RichInfo) -- -- When a connection does not exist, it is skipped. -- Calls 'Brig.API.Internal.getConnectionsStatusUnqualified'. -getConnectionsUnqualified :: [UserId] -> Maybe [UserId] -> Maybe Relation -> Galley [ConnectionStatus] -getConnectionsUnqualified uFrom uTo rlt = do +getConnectionsUnqualified :: + Member BrigAccess r => + [UserId] -> + Maybe [UserId] -> + Maybe Relation -> + Galley r [ConnectionStatus] +getConnectionsUnqualified uFrom uTo rlt = + liftGalley0 $ getConnectionsUnqualified0 uFrom uTo rlt + +getConnectionsUnqualified0 :: + [UserId] -> + Maybe [UserId] -> + Maybe Relation -> + Galley0 [ConnectionStatus] +getConnectionsUnqualified0 uFrom uTo rlt = do (h, p) <- brigReq r <- - call "brig" $ + call0 "brig" $ method POST . host h . port p . path "/i/users/connections-status" . maybe id rfilter rlt @@ -79,34 +97,33 @@ getConnectionsUnqualified uFrom uTo rlt = do -- -- When a connection does not exist, it is skipped. -- Calls 'Brig.API.Internal.getConnectionsStatus'. -getConnections :: [UserId] -> Maybe [Qualified UserId] -> Maybe Relation -> Galley [ConnectionStatusV2] +getConnections :: Member BrigAccess r => [UserId] -> Maybe [Qualified UserId] -> Maybe Relation -> Galley r [ConnectionStatusV2] getConnections [] _ _ = pure [] getConnections uFrom uTo rlt = do (h, p) <- brigReq r <- - call "brig" $ + callBrig $ method POST . host h . port p . path "/i/users/connections-status/v2" . json (ConnectionsStatusRequestV2 uFrom uTo rlt) . expect2xx parseResponse (mkError status502 "server-error") r -putConnectionInternal :: UpdateConnectionsInternal -> Galley Status +putConnectionInternal :: Member BrigAccess r => UpdateConnectionsInternal -> Galley r Status putConnectionInternal updateConn = do (h, p) <- brigReq response <- - call "brig" $ + callBrig $ method PUT . host h . port p . paths ["/i/connections/connection-update"] . json updateConn pure $ responseStatus response --- | Calls 'Brig.Provider.API.botGetSelfH'. -deleteBot :: ConvId -> BotId -> Galley () -deleteBot cid bot = do +deleteBot0 :: ConvId -> BotId -> Galley0 () +deleteBot0 cid bot = do (h, p) <- brigReq void $ - call "brig" $ + call0 "brig" $ method DELETE . host h . port p . path "/bot/self" . header "Z-Type" "bot" @@ -114,15 +131,19 @@ deleteBot cid bot = do . header "Z-Conversation" (toByteString' cid) . expect2xx +-- | Calls 'Brig.Provider.API.botGetSelfH'. +deleteBot :: Member BotAccess r => ConvId -> BotId -> Galley r () +deleteBot cid bot = liftGalley0 $ deleteBot0 cid bot + -- | Calls 'Brig.User.API.Auth.reAuthUserH'. -reAuthUser :: UserId -> ReAuthUser -> Galley Bool +reAuthUser :: Member BrigAccess r => UserId -> ReAuthUser -> Galley r Bool reAuthUser uid auth = do (h, p) <- brigReq let req = method GET . host h . port p . paths ["/i/users", toByteString' uid, "reauthenticate"] . json auth - st <- statusCode . responseStatus <$> call "brig" (check [status200, status403] . req) + st <- statusCode . responseStatus <$> callBrig (check [status200, status403] . req) return $ st == 200 check :: [Status] -> Request -> Request @@ -135,12 +156,12 @@ check allowed r = } -- | Calls 'Brig.API.listActivatedAccountsH'. -lookupActivatedUsers :: [UserId] -> Galley [User] +lookupActivatedUsers :: Member BrigAccess r => [UserId] -> Galley r [User] lookupActivatedUsers = chunkify $ \uids -> do (h, p) <- brigReq let users = BSC.intercalate "," $ toByteString' <$> uids r <- - call "brig" $ + callBrig $ method GET . host h . port p . path "/i/users" . queryItem "ids" users @@ -162,15 +183,15 @@ chunkify doChunk keys = mconcat <$> (doChunk `mapM` chunks keys) chunks uids = case splitAt maxSize uids of (h, t) -> h : chunks t -- | Calls 'Brig.API.listActivatedAccountsH'. -getUser :: UserId -> Galley (Maybe UserAccount) +getUser :: Member BrigAccess r => UserId -> Galley r (Maybe UserAccount) getUser uid = listToMaybe <$> getUsers [uid] -- | Calls 'Brig.API.listActivatedAccountsH'. -getUsers :: [UserId] -> Galley [UserAccount] +getUsers :: Member BrigAccess r => [UserId] -> Galley r [UserAccount] getUsers = chunkify $ \uids -> do (h, p) <- brigReq resp <- - call "brig" $ + callBrig $ method GET . host h . port p . path "/i/users" . queryItem "ids" (BSC.intercalate "," (toByteString' <$> uids)) @@ -178,32 +199,32 @@ getUsers = chunkify $ \uids -> do pure . fromMaybe [] . responseJsonMaybe $ resp -- | Calls 'Brig.API.deleteUserNoVerifyH'. -deleteUser :: UserId -> Galley () +deleteUser :: Member BrigAccess r => UserId -> Galley r () deleteUser uid = do (h, p) <- brigReq void $ - call "brig" $ + callBrig $ method DELETE . host h . port p . paths ["/i/users", toByteString' uid] . expect2xx -- | Calls 'Brig.API.getContactListH'. -getContactList :: UserId -> Galley [UserId] +getContactList :: Member BrigAccess r => UserId -> Galley r [UserId] getContactList uid = do (h, p) <- brigReq r <- - call "brig" $ + callBrig $ method GET . host h . port p . paths ["/i/users", toByteString' uid, "contacts"] . expect2xx cUsers <$> parseResponse (mkError status502 "server-error") r -- | Calls 'Brig.API.Internal.getRichInfoMultiH' -getRichInfoMultiUser :: [UserId] -> Galley [(UserId, RichInfo)] +getRichInfoMultiUser :: Member BrigAccess r => [UserId] -> Galley r [(UserId, RichInfo)] getRichInfoMultiUser = chunkify $ \uids -> do (h, p) <- brigReq resp <- - call "brig" $ + callBrig $ method GET . host h . port p . paths ["/i/users/rich-info"] . queryItem "ids" (toByteString' (List uids)) diff --git a/services/galley/src/Galley/Intra/Util.hs b/services/galley/src/Galley/Intra/Util.hs index 9416c8d68f3..a9dc8ff8820 100644 --- a/services/galley/src/Galley/Intra/Util.hs +++ b/services/galley/src/Galley/Intra/Util.hs @@ -18,7 +18,10 @@ module Galley.Intra.Util ( brigReq, sparReq, - call, + call0, + callBrig, + callSpar, + callBot, x1, ) where @@ -33,17 +36,18 @@ import Data.Misc (portNumber) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import Galley.App +import Galley.Effects import Galley.Options import Imports import Util.Options -brigReq :: Galley (ByteString, Word16) +brigReq :: Galley r (ByteString, Word16) brigReq = do h <- encodeUtf8 <$> view (options . optBrig . epHost) p <- portNumber . fromIntegral <$> view (options . optBrig . epPort) return (h, p) -sparReq :: Galley (ByteString, Word16) +sparReq :: Galley r (ByteString, Word16) sparReq = do h <- encodeUtf8 <$> view (options . optSpar . epHost) p <- portNumber . fromIntegral <$> view (options . optSpar . epPort) @@ -51,8 +55,17 @@ sparReq = do -- gundeckReq lives in Galley.Intra.Push -call :: LT.Text -> (Request -> Request) -> Galley (Response (Maybe LB.ByteString)) -call n r = recovering x1 rpcHandlers (const (rpc n r)) +call0 :: LT.Text -> (Request -> Request) -> Galley0 (Response (Maybe LB.ByteString)) +call0 n r = liftGalley0 $ recovering x1 rpcHandlers (const (rpc n r)) + +callBrig :: Member BrigAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) +callBrig r = liftGalley0 $ call0 "brig" r + +callSpar :: Member SparAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) +callSpar r = liftGalley0 $ call0 "spar" r + +callBot :: Member BotAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) +callBot r = liftGalley0 $ call0 "brig" r x1 :: RetryPolicy x1 = limitRetries 1 diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 742b32f9714..7218a22c37c 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -131,8 +131,8 @@ bodyParserErrorFormatter _ _ errMsg = type CombinedAPI = GalleyAPI.ServantAPI :<|> Internal.ServantAPI :<|> ToServantApi FederationGalley.Api :<|> Servant.Raw -refreshMetrics :: Galley () -refreshMetrics = do +refreshMetrics :: Galley r () +refreshMetrics = liftGalley0 $ do m <- view monitor q <- view deleteQueue Internal.safeForever "refreshMetrics" $ do diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index dc4f17a31ed..a533cdbd513 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -32,11 +32,11 @@ import Galley.App import Galley.Options import Imports -rangeChecked :: Within a n m => a -> Galley (Range n m a) +rangeChecked :: Within a n m => a -> Galley r (Range n m a) rangeChecked = either throwErr return . checkedEither {-# INLINE rangeChecked #-} -rangeCheckedMaybe :: Within a n m => Maybe a -> Galley (Maybe (Range n m a)) +rangeCheckedMaybe :: Within a n m => Maybe a -> Galley r (Maybe (Range n m a)) rangeCheckedMaybe Nothing = return Nothing rangeCheckedMaybe (Just a) = Just <$> rangeChecked a {-# INLINE rangeCheckedMaybe #-} @@ -45,7 +45,7 @@ rangeCheckedMaybe (Just a) = Just <$> rangeChecked a newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} deriving (Functor, Foldable, Traversable) -checkedConvSize :: Foldable f => f a -> Galley (ConvSizeChecked f a) +checkedConvSize :: Foldable f => f a -> Galley r (ConvSizeChecked f a) checkedConvSize x = do o <- view options let minV :: Integer = 0 @@ -54,5 +54,5 @@ checkedConvSize x = do then return (ConvSizeChecked x) else throwErr (errorMsg minV limit "") -throwErr :: String -> Galley a +throwErr :: String -> Galley r a throwErr = throwM . invalidRange . fromString diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index cd61c67eb42..3c2cf9e9184 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -39,6 +39,7 @@ import Brig.Types import qualified Control.Concurrent.Async as Async import Control.Lens (at, ix, preview, view, (.~), (?~)) import Control.Monad.Except (MonadError (throwError)) +import Control.Monad.Trans.Maybe import Data.Aeson hiding (json) import qualified Data.ByteString as BS import Data.ByteString.Conversion @@ -59,9 +60,7 @@ import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.Text.Ascii as Ascii import Data.Time.Clock (getCurrentTime) -import Database.CQL.IO import Galley.API.Mapping -import qualified Galley.Data as Data import Galley.Options (Opts, optFederator) import Galley.Types hiding (LocalMember (..)) import Galley.Types.Conversations.Intra @@ -3247,7 +3246,6 @@ testOne2OneConversationRequest :: Bool -> Actor -> DesiredMembership -> TestM () testOne2OneConversationRequest shouldBeLocal actor desired = do alice <- qTagUnsafe <$> randomQualifiedUser (bob, expectedConvId) <- generateRemoteAndConvId shouldBeLocal alice - db <- view tsCass convId <- do let req = UpsertOne2OneConversationRequest alice bob actor desired Nothing @@ -3260,20 +3258,34 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do case shouldBeLocal of True -> do - mems <- runClient db $ do - lmems <- fmap (qUntagged . qualifyAs alice . lmId) <$> Data.members (qUnqualified convId) - rmems <- fmap (qUntagged . rmId) <$> Data.lookupRemoteMembers (qUnqualified convId) - pure (lmems <> rmems) - let actorId = case actor of - LocalActor -> qUntagged alice - RemoteActor -> qUntagged bob - liftIO $ isJust (find (actorId ==) mems) @?= (desired == Included) - liftIO $ filter (actorId /=) mems @?= [] + members <- case actor of + LocalActor -> runMaybeT $ do + resp <- lift $ getConvQualified (tUnqualified alice) convId + guard $ statusCode resp == 200 + conv <- lift $ responseJsonError resp + pure . map omQualifiedId . cmOthers . cnvMembers $ conv + RemoteActor -> do + fedGalleyClient <- view tsFedGalleyClient + GetConversationsResponse convs <- + FederatedGalley.getConversations + fedGalleyClient + (tDomain bob) + FederatedGalley.GetConversationsRequest + { FederatedGalley.gcrUserId = tUnqualified bob, + FederatedGalley.gcrConvIds = [qUnqualified convId] + } + pure + . fmap (map omQualifiedId . rcmOthers . rcnvMembers) + . listToMaybe + $ convs + liftIO $ case desired of + Included -> members @?= Just [] + Excluded -> members @?= Nothing False -> do - mems <- runClient db $ do - smap <- Data.remoteConversationStatus (tUnqualified alice) [qTagUnsafe convId] - case Map.lookup (qTagUnsafe convId) smap of - Just _ -> pure [qUntagged alice] - _ -> pure [] - when (actor == LocalActor) $ - liftIO $ isJust (find (qUntagged alice ==) mems) @?= (desired == Included) + found <- do + let rconv = mkConv (qUnqualified convId) (tUnqualified bob) roleNameWireAdmin [] + (resp, _) <- + withTempMockFederator (const (FederatedGalley.GetConversationsResponse [rconv])) $ + getConvQualified (tUnqualified alice) convId + pure $ statusCode resp == 200 + liftIO $ found @?= ((actor, desired) == (LocalActor, Included)) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 01d7cf94509..161b1a2636c 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -324,7 +324,7 @@ testApproveLegalHoldDevice = do renewToken authToken cassState <- view tsCass liftIO $ do - clients' <- Cql.runClient cassState $ Data.lookupClients [member] + clients' <- Cql.runClient cassState $ Data.lookupClients' [member] assertBool "Expect clientId to be saved on the user" $ Clients.contains member someClientId clients' UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index b023b3abf56..9d458076467 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -256,7 +256,7 @@ testApproveLegalHoldDevice = do renewToken authToken cassState <- view tsCass liftIO $ do - clients' <- Cql.runClient cassState $ Data.lookupClients [member] + clients' <- Cql.runClient cassState $ Data.lookupClients' [member] assertBool "Expect clientId to be saved on the user" $ Clients.contains member someClientId clients' UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 212834e6032..a0521b675a8 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 instance +-- | A class for monads with access to a Galley r instance class HasGalley m where viewGalley :: m GalleyR viewGalleyOpts :: m Opts.Opts