diff --git a/CHANGELOG.md b/CHANGELOG.md index e681a5bcddf..758a603d3f2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,49 @@ +# [2026-05-08] (Chart Release 5.31.0) + +## API changes + + +* `GET /teams/:tid/size` response body lists `teamSizeRegulars`, `teamSizeApps`. (#5213) + + +## Features + + +* `DELETE /meetings/:domain/:meetingId` for deleting meetings. (#5066) + + +## Bug fixes and other updates + + +* Fix: Inconsistent removal messages across local and federated conversation members (#5210) + +* Do not count apps as paying users. (#5213) + +* brig-index: Continue indexing even when an invalid user is found in the DB (#4839) + +* Postgres: Index the parent_conv column in the conversation table (#5205, #5209, #5205) + + +## Internal changes + + +* Consolidate brig/galley api access effects from spar into wire-subsystems. + + NB: calls to internal galley end-points were *sometimes* propagating unexpected errors (eg. 400) to the client, sometimes they were turned into a fixed 5xx error. we now consistently do the latter, which is more accurate (we don't want this to ever happen). (#5189) + +* Using a random-generated index name to stabilize `testSearchNoExtraResults` (`brig-integration`). (#5198) + +* Move conversation-related operations into a unified Polysemy `ConversationSubsystem` effect across the wire-server codebase. (#5126) + +* Move meetings feature check from galley service layer into the MeetingsSubsystem interpreter, ensuring the check is enforced consistently within the subsystem. (#5214) + +* Add tools/mlsstats to the Docker images to be built in CI runs. + mlsstats Helm chart now supports pod identity: ServiceAccount with configurable annotations is created and referenced by the CronJob pod, enabling OIDC-based AWS credential injection instead of static keys. AWS_EC2_METADATA_DISABLED is set so the AWS SDK uses web identity tokens on non-EC2 nodes. Secret creation is skipped when no static credentials are provided. (#5200) + +* Add zone-level topologySpreadConstraints to nginz deployment so pods are spread evenly across availability zones, ensuring traffic reaches all AZs when zone-aware routing is in use. + topologySpreadConstraints are now configurable via values.yaml (defaulting to zone + hostname spreading), allowing chart users to customise pod scheduling without patching the chart. (#5208) + + # [2026-04-20] (Chart Release 5.30.0) ## Release notes diff --git a/charts/mlsstats/templates/cronjob.yaml b/charts/mlsstats/templates/cronjob.yaml index 5247b15cd38..08a10f2d404 100644 --- a/charts/mlsstats/templates/cronjob.yaml +++ b/charts/mlsstats/templates/cronjob.yaml @@ -22,13 +22,13 @@ spec: backoffLimit: 0 template: spec: + serviceAccountName: {{ .Values.serviceAccount.name }} restartPolicy: Never containers: - name: mlsstats image: "{{ .Values.image.repository }}:{{ .Values.image.tag }}" imagePullPolicy: {{ default "" .Values.imagePullPolicy | quote }} - args: [ "mlsstats" - , "--brig-cassandra-host", {{ .Values.config.cassandra.brig.host | quote }} + args: [ "--brig-cassandra-host", {{ .Values.config.cassandra.brig.host | quote }} , "--brig-cassandra-port", {{ .Values.config.cassandra.brig.port | quote }} , "--brig-cassandra-keyspace", {{ .Values.config.cassandra.brig.keyspace | quote }} , "--galley-cassandra-host", {{ .Values.config.cassandra.galley.host | quote }} @@ -42,19 +42,21 @@ spec: , "--s3-bucket-dir", {{ .Values.config.s3.bucket.directory | quote }} ] resources: +{{ toYaml .Values.resources | indent 16 }} env: {{- if hasKey .Values.secrets "awsKeyId" }} - name: AWS_ACCESS_KEY_ID valueFrom: secretKeyRef: - name: mlsstats + name: {{ .Chart.Name }} key: awsKeyId - name: AWS_SECRET_ACCESS_KEY valueFrom: secretKeyRef: - name: mlsstats + name: {{ .Chart.Name }} key: awsSecretKey {{- end }} - name: AWS_REGION value: "{{ .Values.config.s3.region }}" -{{ toYaml .Values.resources | indent 16 }} + - name: AWS_EC2_METADATA_DISABLED + value: "true" diff --git a/charts/mlsstats/templates/secret.yaml b/charts/mlsstats/templates/secret.yaml index 3f93be5120c..7402648523f 100644 --- a/charts/mlsstats/templates/secret.yaml +++ b/charts/mlsstats/templates/secret.yaml @@ -1,7 +1,8 @@ +{{- if .Values.secrets.awsKeyId }} apiVersion: v1 kind: Secret metadata: - name: {{ .Release.Name }} + name: {{ .Chart.Name }} labels: app: mlsstats chart: "{{ .Chart.Name }}-{{ .Chart.Version }}" @@ -9,12 +10,6 @@ metadata: heritage: "{{ .Release.Service }}" type: Opaque data: - {{/* for_helm_linting is necessary only since the 'with' block below does not throw an error upon an empty .Values.secrets */}} - for_helm_linting: {{ required "No .secrets found in configuration. Did you forget to helm -f path/to/secrets.yaml ?" .Values.secrets | quote | b64enc | quote }} - - {{- with .Values.secrets }} - {{- if .awsKeyId }} - awsKeyId: {{ .awsKeyId | b64enc | quote }} - awsSecretKey: {{ .awsSecretKey | b64enc | quote }} - {{- end }} - {{- end }} + awsKeyId: {{ .Values.secrets.awsKeyId | b64enc | quote }} + awsSecretKey: {{ .Values.secrets.awsSecretKey | b64enc | quote }} +{{- end }} diff --git a/charts/mlsstats/templates/serviceaccount.yaml b/charts/mlsstats/templates/serviceaccount.yaml new file mode 100644 index 00000000000..ce2e7247969 --- /dev/null +++ b/charts/mlsstats/templates/serviceaccount.yaml @@ -0,0 +1,16 @@ +{{- if .Values.serviceAccount.create -}} +apiVersion: v1 +kind: ServiceAccount +metadata: + name: {{ .Values.serviceAccount.name }} + labels: + app: mlsstats + chart: "{{ .Chart.Name }}-{{ .Chart.Version }}" + release: "{{ .Release.Name }}" + heritage: "{{ .Release.Service }}" + {{- with .Values.serviceAccount.annotations }} + annotations: + {{- toYaml . | nindent 4 }} + {{- end }} +automountServiceAccountToken: {{ .Values.serviceAccount.automountServiceAccountToken }} +{{- end }} diff --git a/charts/mlsstats/values.yaml b/charts/mlsstats/values.yaml index 399bc1ec996..615586a11ed 100644 --- a/charts/mlsstats/values.yaml +++ b/charts/mlsstats/values.yaml @@ -1,6 +1,6 @@ image: repository: quay.io/wire/mlsstats - tag: 0.1 + tag: 5.30.5 resources: requests: memory: "256Mi" @@ -9,6 +9,11 @@ resources: memory: "256Mi" cpu: "100m" schedule: "23 3 * * *" +serviceAccount: + create: true + name: mlsstats + annotations: {} + automountServiceAccountToken: true config: cassandra: brig: diff --git a/charts/nginz/templates/deployment.yaml b/charts/nginz/templates/deployment.yaml index 11c9f739dbd..7a54dbf969d 100644 --- a/charts/nginz/templates/deployment.yaml +++ b/charts/nginz/templates/deployment.yaml @@ -29,13 +29,10 @@ spec: fluentbit.io/parser-nginz: nginz spec: terminationGracePeriodSeconds: {{ .Values.terminationGracePeriodSeconds }} + {{- with .Values.topologySpreadConstraints }} topologySpreadConstraints: - - maxSkew: 1 - topologyKey: "kubernetes.io/hostname" - whenUnsatisfiable: ScheduleAnyway - labelSelector: - matchLabels: - app: nginz + {{- toYaml . | nindent 8 }} + {{- end }} containers: - name: nginz image: "{{ .Values.images.nginz.repository }}:{{ .Values.images.nginz.tag }}" diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index 20412031f42..2e4e3272bd8 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -20,6 +20,19 @@ config: wsPort: 8081 useProxyProtocol: true terminationGracePeriodSeconds: 90 +topologySpreadConstraints: + - maxSkew: 1 + topologyKey: "topology.kubernetes.io/zone" + whenUnsatisfiable: ScheduleAnyway + labelSelector: + matchLabels: + app: nginz + - maxSkew: 1 + topologyKey: "kubernetes.io/hostname" + whenUnsatisfiable: ScheduleAnyway + labelSelector: + matchLabels: + app: nginz nginx_conf: dns_resolver: kube-dns cluster_domain: cluster.local diff --git a/flake.lock b/flake.lock index cc0609b71f2..87862f14021 100644 --- a/flake.lock +++ b/flake.lock @@ -183,6 +183,23 @@ "type": "github" } }, + "hasql-migration": { + "flake": false, + "locked": { + "lastModified": 1777384964, + "narHash": "sha256-NRFZUDR4cW6jRihO311glqtlIlcRKSKeBXJErHuXf+k=", + "owner": "wireapp", + "repo": "hasql-migration", + "rev": "ef03ac6410c94444bf1807fc4eda1db6b0974984", + "type": "github" + }, + "original": { + "owner": "wireapp", + "ref": "allow-no-transaction", + "repo": "hasql-migration", + "type": "github" + } + }, "hedis": { "flake": false, "locked": { @@ -321,6 +338,7 @@ "cql": "cql", "cql-io": "cql-io", "flake-utils": "flake-utils", + "hasql-migration": "hasql-migration", "hedis": "hedis", "hspec-wai": "hspec-wai", "http-client": "http-client", diff --git a/flake.nix b/flake.nix index 1b65360f4a1..b5c9a151a50 100644 --- a/flake.nix +++ b/flake.nix @@ -85,6 +85,11 @@ url = "github:brendanhay/amazonka?rev=a7d699be1076e2aad05a1930ca3937ffea954ad8"; flake = false; }; + + hasql-migration = { + url = "github:wireapp/hasql-migration?ref=allow-no-transaction"; + flake = false; + }; }; outputs = inputs@{ nixpkgs, nixpkgs_24_11, nixpkgs-unstable, flake-utils, tom-bombadil, sbomnix, ... }: diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index d5cc1d33bf9..56b0d0b5867 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -932,6 +932,12 @@ activateSend domain email locale = do req <- rawBaseRequest domain Brig Versioned $ joinHttpPath ["activate", "send"] submit "POST" $ req & addJSONObject (["email" .= email] <> maybeToList (((.=) "locale") <$> locale)) +-- https://staging-nginz-https.zinfra.io/v16/api/swagger-ui/#/default/get-team-size +getTeamSize :: (HasCallStack, MakesValue user) => user -> String -> App Response +getTeamSize user tid = do + req <- baseRequest user Brig Versioned $ joinHttpPath ["teams", tid, "size"] + submit "GET" req + acceptTeamInvitation :: (HasCallStack, MakesValue user) => user -> String -> Maybe String -> App Response acceptTeamInvitation user code mPw = do req <- baseRequest user Brig Versioned $ joinHttpPath ["teams", "invitations", "accept"] diff --git a/integration/test/API/BrigInternal.hs b/integration/test/API/BrigInternal.hs index ff9ab3d1357..4a0051e8907 100644 --- a/integration/test/API/BrigInternal.hs +++ b/integration/test/API/BrigInternal.hs @@ -186,6 +186,11 @@ refreshIndex domain = do res <- submit "POST" req res.status `shouldMatchInt` 200 +getTeamSize :: (HasCallStack, MakesValue caller) => caller -> String -> App Response +getTeamSize caller tid = do + req <- baseRequest caller Brig Unversioned $ joinHttpPath ["i", "teams", tid, "size"] + submit "GET" req + addFederationRemoteTeam :: (HasCallStack, MakesValue domain, MakesValue remoteDomain, MakesValue team) => domain -> remoteDomain -> team -> App () addFederationRemoteTeam domain remoteDomain team = do void $ addFederationRemoteTeam' domain remoteDomain team >>= getBody 200 diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 1b3ca8dd677..83982cd79ad 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -999,6 +999,11 @@ putMeeting user domain meetingId updatedMeeting = do req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) submit "PUT" $ req & addJSON updatedMeeting +deleteMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> App Response +deleteMeeting user domain meetingId = do + req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) + submit "DELETE" req + getMeeting :: (HasCallStack, MakesValue user) => user -> String -> String -> App Response getMeeting user domain meetingId = do req <- baseRequest user Galley Versioned (joinHttpPath ["meetings", domain, meetingId]) diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index a30031f6362..cdbd6fcee2c 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -682,7 +682,8 @@ consumingMessages mlsProtocol mp = Codensity $ \k -> do -- at this point we know that every new user has been added to the -- conversation - for_ (zip clients wss) $ \((cid, t), ws) -> case t of + let cssNoToBeRemoved = filter (\((ci, _), _) -> ci `Set.notMember` conv.membersToBeRemoved) (zip clients wss) + for_ cssNoToBeRemoved $ \((cid, t), ws) -> case t of MLSNotificationMessageTag -> when (conv.epoch > 0) $ void $ @@ -717,7 +718,7 @@ consumeMessageNoExternal cs cid mp = consumeMessageWithPredicate isNewMLSMessage where -- the backend (correctly) reacts to a commit removing someone from a parent conversation with a -- remove proposal, however, we don't want to consume this here - isNewMLSMessageNotifButNoProposal :: Value -> App Bool + isNewMLSMessageNotifButNoProposal :: (HasCallStack) => Value -> App Bool isNewMLSMessageNotifButNoProposal n = do isRelevantNotif <- isNewMLSMessageNotif n &&~ isNotifConvId mp.convId n if isRelevantNotif diff --git a/integration/test/Test/Apps.hs b/integration/test/Test/Apps.hs index 72eaa5e637f..cdce0eb5b77 100644 --- a/integration/test/Test/Apps.hs +++ b/integration/test/Test/Apps.hs @@ -19,7 +19,7 @@ module Test.Apps where -import API.Brig +import API.Brig as Brig import qualified API.BrigInternal as BrigI import API.Common import API.Galley @@ -28,6 +28,7 @@ import Data.Aeson.QQ.Simple import MLS.Util import Notifications import SetupHelpers +import System.Random (randomRIO) import Testlib.Prelude testCreateGetApp :: (HasCallStack) => Domain -> App () @@ -561,3 +562,34 @@ testAppReceivesMemberJoinNotification = do memberJoinApp <- awaitMatch isTeamMemberJoinNotif wsApp memberJoinApp %. "payload.0.team" `shouldMatch` tid memberJoinApp %. "payload.0.data.user" `shouldMatch` objId newMember + +testTeamSizeWithApps :: (HasCallStack) => TaggedBool "test internal api" -> App () +testTeamSizeWithApps (TaggedBool testInternalApi) = do + domain <- make OwnDomain + numRegulars <- liftIO $ randomRIO (1 :: Int, 3) + numApps <- liftIO $ randomRIO (1 :: Int, 3) + + (owner, tid, extraMembers) <- createTeam domain (numRegulars + 1) + + apps <- replicateM numApps $ bindResponse (createApp owner tid def) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "user" + + let checkSize :: (HasCallStack) => Int -> Int -> App () + checkSize wantRegulars wantApps = + (if testInternalApi then BrigI.getTeamSize else Brig.getTeamSize) owner tid `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "teamSize" `shouldMatchInt` (1 + wantRegulars + wantApps) + resp.json %. "teamSizeRegulars" `shouldMatchInt` (1 + wantRegulars) + resp.json %. "teamSizeApps" `shouldMatchInt` wantApps + + BrigI.refreshIndex domain + eventually $ do + checkSize numRegulars numApps + + deleteTeamMember tid owner (head apps) >>= assertSuccess + deleteTeamMember tid owner (head extraMembers) >>= assertSuccess + + BrigI.refreshIndex domain + eventually $ do + checkSize (numRegulars - 1) (numApps - 1) diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index de871aae26e..567168f1200 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -1209,3 +1209,13 @@ testGroupIdParseError = do resp.json %. "label" `shouldMatch` "mls-protocol-error" msg <- resp.json %. "message" & asString assertBool "unexpected error message" $ "Could not parse group ID:" `isPrefixOf` msg + +testFederatedRemove :: (HasCallStack) => App () +testFederatedRemove = do + [alice, amy, bob] <- createAndConnectUsers [OwnDomain, OwnDomain, OtherDomain] + [alice1, amy1, bob1] <- traverse (createMLSClient def) [alice, amy, bob] + traverse_ (uploadNewKeyPackage def) [amy1, bob1] + convId <- createNewGroup def alice1 + + void $ createAddCommit alice1 convId [amy, bob] >>= sendAndConsumeCommitBundle + void $ createRemoveCommit alice1 convId [amy1, bob1] >>= sendAndConsumeCommitBundle diff --git a/integration/test/Test/Meetings.hs b/integration/test/Test/Meetings.hs index f63ca75e937..f3d47dbb698 100644 --- a/integration/test/Test/Meetings.hs +++ b/integration/test/Test/Meetings.hs @@ -311,3 +311,51 @@ testMeetingRemoveInvitationNotFound = do let removeInvitation = object ["emails" .= ["alice@example.com"]] deleteMeetingInvitation owner "example.com" fakeMeetingId removeInvitation >>= assertStatus 404 + +testMeetingDelete :: (HasCallStack) => App () +testMeetingDelete = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + recurrenceUntil = addUTCTime (30 * 24 * 3600) now + recurrence = + object + [ "frequency" .= "daily", + "interval" .= (1 :: Int), + "until" .= recurrenceUntil + ] + newMeeting = + object + [ "title" .= "Team Standup", + "start_time" .= startTime, + "end_time" .= endTime, + "invited_emails" .= ([] :: [String]), + "recurrence" .= recurrence + ] + r1 <- postMeetings owner newMeeting + assertSuccess r1 + meeting <- getJSON 201 r1 + (meetingId, domain) <- getMeetingIdAndDomain meeting + deleteMeeting owner domain meetingId >>= assertStatus 200 + getMeeting owner domain meetingId >>= assertStatus 404 + +testMeetingDeleteNotFound :: (HasCallStack) => App () +testMeetingDeleteNotFound = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + fakeMeetingId <- randomId + deleteMeeting owner "example.com" fakeMeetingId >>= assertStatus 404 + +testMeetingDeleteUnauthorized :: (HasCallStack) => App () +testMeetingDeleteUnauthorized = do + (owner, _tid, _members) <- createTeam OwnDomain 1 + (otherUser, _, _membersOther) <- createTeam OwnDomain 1 + now <- liftIO getCurrentTime + let startTime = addUTCTime 3600 now + endTime = addUTCTime 7200 now + newMeeting = defaultMeetingJson "Team Standup" startTime endTime [] + r1 <- postMeetings owner newMeeting + assertSuccess r1 + meeting <- getJSON 201 r1 + (meetingId, domain) <- getMeetingIdAndDomain meeting + deleteMeeting otherUser domain meetingId >>= assertStatus 404 diff --git a/integration/test/Testlib/JSON.hs b/integration/test/Testlib/JSON.hs index d7688a7a0f6..04ae74ef192 100644 --- a/integration/test/Testlib/JSON.hs +++ b/integration/test/Testlib/JSON.hs @@ -243,7 +243,7 @@ lookupField :: lookupField val selector = do v <- make val vp <- prettyJSON v - addFailureContext ("Loooking up (nested) field " <> selector <> " of object:\n" <> vp) $ do + addFailureContext ("Looking up (nested) field " <> selector <> " of object:\n" <> vp) $ do let keys = splitOn "." selector case keys of (k : ks) -> go k ks v diff --git a/libs/types-common-journal/proto/TeamEvents.proto b/libs/types-common-journal/proto/TeamEvents.proto index 8dc80757cd8..8bd25c21cc8 100644 --- a/libs/types-common-journal/proto/TeamEvents.proto +++ b/libs/types-common-journal/proto/TeamEvents.proto @@ -13,6 +13,19 @@ message TeamEvent { required int32 member_count = 1; repeated bytes billing_user = 2; optional string currency = 3; // ISO_4217 + + // the following fields are at the end of the declaration + // for backwards compatibility. + // + // this declaration is used to generate producer code, so it + // is ok and desirable to make this fields mandatory (they + // are guaranteed to be present). + // + // for backwards compatibility, clients should make these + // fields optional, and fall back to using `member_count` if + // they are missing. + required int32 member_count_regular = 4; + required int32 member_count_app = 5; } enum EventType { diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs index 0f4afc600a0..b2ae91b06e4 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs @@ -83,7 +83,7 @@ type GalleyApi = '[From 'V2] "get-conversations" GetConversationsRequest - GetConversationsResponseV2 + GetRemoteConversationViewsResponse :<|> FedEndpoint "leave-conversation" LeaveConversationRequest @@ -236,7 +236,7 @@ instance ToSchema RemoteConversation -- information as a 'Conversation', with the exception that conversation status -- fields (muted\/archived\/hidden) are omitted, since they are not known by the -- remote backend. -data RemoteConversationV2 = RemoteConversationV2 +data RemoteConversationView = RemoteConversationView { -- | Id of the conversation, implicitly qualified with the domain of the -- backend that created this value. id :: ConvId, @@ -245,13 +245,13 @@ data RemoteConversationV2 = RemoteConversationV2 protocol :: Protocol } deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform RemoteConversationV2) - deriving (FromJSON, ToJSON) via (CustomEncoded RemoteConversationV2) + deriving (Arbitrary) via (GenericUniform RemoteConversationView) + deriving (FromJSON, ToJSON) via (CustomEncoded RemoteConversationView) -instance ToSchema RemoteConversationV2 +instance ToSchema RemoteConversationView -remoteConversationFromV2 :: RemoteConversationV2 -> RemoteConversation -remoteConversationFromV2 rc = +remoteConversationFromView :: RemoteConversationView -> RemoteConversation +remoteConversationFromView rc = RemoteConversation { id = rc.id, metadata = rc.metadata, @@ -259,9 +259,9 @@ remoteConversationFromV2 rc = protocol = ClientAPI.Versioned rc.protocol } -remoteConversationToV2 :: RemoteConversation -> RemoteConversationV2 -remoteConversationToV2 rc = - RemoteConversationV2 +remoteConversationToView :: RemoteConversation -> RemoteConversationView +remoteConversationToView rc = + RemoteConversationView { id = rc.id, metadata = rc.metadata, members = rc.members, @@ -277,20 +277,20 @@ newtype GetConversationsResponse = GetConversationsResponse instance ToSchema GetConversationsResponse -newtype GetConversationsResponseV2 = GetConversationsResponseV2 - { convs :: [RemoteConversationV2] +newtype GetRemoteConversationViewsResponse = GetRemoteConversationViewsResponse + { convs :: [RemoteConversationView] } deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform GetConversationsResponseV2) - deriving (ToJSON, FromJSON) via (CustomEncoded GetConversationsResponseV2) + deriving (Arbitrary) via (GenericUniform GetRemoteConversationViewsResponse) + deriving (ToJSON, FromJSON) via (CustomEncoded GetRemoteConversationViewsResponse) -instance ToSchema GetConversationsResponseV2 +instance ToSchema GetRemoteConversationViewsResponse -getConversationsResponseToV2 :: GetConversationsResponse -> GetConversationsResponseV2 -getConversationsResponseToV2 res = GetConversationsResponseV2 (map remoteConversationToV2 res.convs) +getConversationsResponseToView :: GetConversationsResponse -> GetRemoteConversationViewsResponse +getConversationsResponseToView res = GetRemoteConversationViewsResponse (map remoteConversationToView res.convs) -getConversationsResponseFromV2 :: GetConversationsResponseV2 -> GetConversationsResponse -getConversationsResponseFromV2 res = GetConversationsResponse (map remoteConversationFromV2 res.convs) +getConversationsResponseFromView :: GetRemoteConversationViewsResponse -> GetConversationsResponse +getConversationsResponseFromView res = GetConversationsResponse (map remoteConversationFromView res.convs) data GetOne2OneConversationResponse = GetOne2OneConversationOk RemoteConversation @@ -321,7 +321,7 @@ data GetOne2OneConversationResponseV2 instance ToSchema GetOne2OneConversationResponseV2 data RemoteMLSOne2OneConversation = RemoteMLSOne2OneConversation - { conversation :: RemoteConversationV2, + { conversation :: RemoteConversationView, publicKeys :: MLSKeysByPurpose MLSPublicKeys } deriving stock (Eq, Show, Generic) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs index 25cd3f9025e..5e95cdd713b 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GetOne2OneConversationResponse.hs @@ -116,9 +116,9 @@ remoteConversation = } } -remoteConversationV2 :: RemoteConversationV2 +remoteConversationV2 :: RemoteConversationView remoteConversationV2 = - RemoteConversationV2 + RemoteConversationView { id = (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200040001"))), metadata = ConversationMetadata diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index b46992e018f..a254f170483 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -20,10 +20,11 @@ module Wire.API.Routes.Internal.Galley where import Control.Lens ((.~)) import Data.Domain import Data.Id as Id +import Data.LegalHold (UserLegalHoldStatus) import Data.OpenApi (OpenApi, info, title) import Data.Range import GHC.TypeLits (AppendSymbol) -import Imports hiding (head) +import Imports import Servant import Servant.OpenApi import Wire.API.Bot @@ -52,6 +53,7 @@ import Wire.API.Routes.QualifiedCapture import Wire.API.Routes.Version import Wire.API.Team import Wire.API.Team.Feature +import Wire.API.Team.LegalHold qualified as LegalHold import Wire.API.Team.Member import Wire.API.Team.Member.Info import Wire.API.Team.SearchVisibility @@ -550,7 +552,7 @@ type IMiscAPI = (RespondEmpty 200 "OK") ) :<|> Named - "test-delete-client" + "remove-client" ( "clients" :> ZUser :> Capture "cid" ClientId @@ -622,6 +624,21 @@ type IMiscAPI = :> Capture "domain" Domain :> MultiVerb1 'DELETE '[JSON] (RespondEmpty 200 "OK") ) + :<|> Named + "get-user-lh-status" + ( "users" + :> Capture "uid" UserId + :> "lh-status" + :> QueryParam "team_id" TeamId + :> Get '[JSON] UserLegalHoldStatus + ) + :<|> Named + "get-users-lh-status" + ( "users" + :> "lh-status" + :> ReqBody '[JSON] UserIds + :> Post '[JSON] [LegalHold.UserLegalHoldStatusEntry] + ) type IEJPDAPI = Named diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs index 8a89b925412..9d113b6edb8 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Meetings.hs @@ -62,6 +62,23 @@ type MeetingsAPI = '[Respond 200 "Meeting updated" Meeting] Meeting ) + :<|> Named + "delete-meeting" + ( Summary "Delete a meeting" + :> From 'V15 + :> ZLocalUser + :> ZConn + :> "meetings" + :> Capture "domain" Domain + :> Capture "id" MeetingId + :> CanThrow 'MeetingNotFound + :> CanThrow 'AccessDenied + :> MultiVerb + 'DELETE + '[JSON] + '[RespondEmpty 200 "Meeting deleted"] + () + ) :<|> Named "get-meeting" ( Summary "Get a single meeting by ID" diff --git a/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs b/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs index 7915eb9a126..638da672409 100644 --- a/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs +++ b/libs/wire-api/src/Wire/API/Team/FeatureFlags.hs @@ -25,6 +25,8 @@ module Wire.API.Team.FeatureFlags FeatureFlags, FanoutLimit, featureDefaults, + defaultFanoutLimit, + currentFanoutLimit, notTeamMember, findTeamMember, isTeamMember, @@ -42,7 +44,7 @@ import Data.ByteString.UTF8 qualified as UTF8 import Data.Default import Data.Id (UserId) import Data.OpenApi qualified as S -import Data.Range (Range) +import Data.Range (Range, fromRange, toRange, unsafeRange) import Data.SOP import Data.Schema import Data.Set qualified as Set @@ -53,6 +55,15 @@ import Wire.API.Team.Permission type FanoutLimit = Range 1 HardTruncationLimit Int32 +defaultFanoutLimit :: FanoutLimit +defaultFanoutLimit = toRange (Proxy @HardTruncationLimit) + +currentFanoutLimit :: Word32 -> Maybe FanoutLimit -> FanoutLimit +currentFanoutLimit maxTeamSize maxFanoutSize = + let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defaultFanoutLimit maxFanoutSize + maxSize = fromIntegral maxTeamSize + in unsafeRange (min maxSize optFanoutLimit) + -- | Used to extract the feature config type out of 'FeatureDefaults' or -- related types. type family ConfigOf a diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold.hs b/libs/wire-api/src/Wire/API/Team/LegalHold.hs index a7c65addd22..492229be234 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold.hs @@ -22,6 +22,7 @@ module Wire.API.Team.LegalHold ViewLegalHoldService (..), ViewLegalHoldServiceInfo (..), UserLegalHoldStatusResponse (..), + UserLegalHoldStatusEntry (..), RemoveLegalHoldSettingsRequest (..), DisableLegalHoldForUserRequest (..), ApproveLegalHoldForUserRequest (..), @@ -162,6 +163,24 @@ instance ToSchema UserLegalHoldStatusResponse where <*> ulhsrLastPrekey .= maybe_ (optField "last_prekey" schema) <*> (fmap IdObject . ulhsrClientId) .= maybe_ (optField "client" (fromIdObject <$> schema)) +-------------------------------------------------------------------------------- +-- UserLegalHoldStatusEntry + +data UserLegalHoldStatusEntry = UserLegalHoldStatusEntry + { ulhseUser :: UserId, + ulhseStatus :: UserLegalHoldStatus + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform UserLegalHoldStatusEntry) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema UserLegalHoldStatusEntry) + +instance ToSchema UserLegalHoldStatusEntry where + schema = + object $ + UserLegalHoldStatusEntry + <$> ulhseUser .= field "user" schema + <*> ulhseStatus .= field "status" schema + -------------------------------------------------------------------------------- -- RemoveLegalHoldSettingsRequest diff --git a/libs/wire-api/src/Wire/API/Team/Size.hs b/libs/wire-api/src/Wire/API/Team/Size.hs index 65f6c23b0d7..d751769a903 100644 --- a/libs/wire-api/src/Wire/API/Team/Size.hs +++ b/libs/wire-api/src/Wire/API/Team/Size.hs @@ -16,30 +16,67 @@ -- with this program. If not, see . module Wire.API.Team.Size - ( TeamSize (TeamSize), + ( TeamSize (..), + teamSizeTotal, + updateTeamSize, ) where import Control.Lens ((?~)) import Data.Aeson qualified as A +import Data.Aeson.Types qualified as A import Data.OpenApi qualified as S import Data.Schema import Imports import Numeric.Natural import Test.QuickCheck (arbitrarySizedNatural) +import Wire.API.User.Search import Wire.Arbitrary -newtype TeamSize = TeamSize Natural +data TeamSize = TeamSize + { regulars :: Natural, + apps :: Natural + } deriving (Show, Eq) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema TeamSize) +-- | Total team members (regulars + apps). +teamSizeTotal :: TeamSize -> Natural +teamSizeTotal ts = ts.regulars + ts.apps + +-- Increase or decrease a team size component, depending on user type. + +-- If the result of a decrease is <0, it is set to 1 (regulars) or 0 +-- (apps). This handles corner cases where ES reports lower numbers +-- from the past. +updateTeamSize :: UserTypeFilter -> TeamSize -> Int -> TeamSize +updateTeamSize = go + where + go :: UserTypeFilter -> TeamSize -> Int -> TeamSize + go UserTypeFilterRegular (TeamSize rs as) n = TeamSize (upd 1 rs n) as + go UserTypeFilterApp (TeamSize rs as) n = TeamSize rs (upd 0 as n) + + upd :: Int -> Natural -> Int -> Natural + upd low n i = fromIntegral . max low $ fromIntegral n + i + instance ToSchema TeamSize where schema = - objectWithDocModifier (description ?~ "A simple object with a total number of team members.") $ - TeamSize <$> (unTeamSize .= fieldWithDocModifier "teamSize" (description ?~ "Team size.") schema) + objectWithDocModifier (description ?~ "Team member counts broken down by user type.") $ + fromTeamSize .= tripleSchema `withParser` validate where - unTeamSize :: TeamSize -> Natural - unTeamSize (TeamSize n) = n + fromTeamSize :: TeamSize -> (Natural, Natural, Maybe Natural) + fromTeamSize ts = (ts.regulars, ts.apps, Just (teamSizeTotal ts)) + tripleSchema :: ObjectSchema SwaggerDoc (Natural, Natural, Maybe Natural) + tripleSchema = + (,,) + <$> (\(r, _, _) -> r) .= fieldWithDocModifier "teamSizeRegulars" (description ?~ "Number of regular users in team.") schema + <*> (\(_, a, _) -> a) .= fieldWithDocModifier "teamSizeApps" (description ?~ "Number of apps in team.") schema + <*> (\(_, _, t) -> t) .= maybe_ (optFieldWithDocModifier "teamSize" (description ?~ "Total team members (teamSizeRegulars + teamSizeApps).") schema) + validate :: (Natural, Natural, Maybe Natural) -> A.Parser TeamSize + validate (r, a, Nothing) = pure TeamSize {regulars = r, apps = a} + validate (r, a, Just t) + | r + a == t = pure TeamSize {regulars = r, apps = a} + | otherwise = fail $ "teamSize (" <> show t <> ") != regulars + apps (" <> show (r + a) <> ")" instance Arbitrary TeamSize where - arbitrary = TeamSize <$> arbitrarySizedNatural + arbitrary = TeamSize <$> arbitrarySizedNatural <*> arbitrarySizedNatural diff --git a/libs/wire-api/src/Wire/API/User/Search.hs b/libs/wire-api/src/Wire/API/User/Search.hs index 07a5c27cd29..13325e91915 100644 --- a/libs/wire-api/src/Wire/API/User/Search.hs +++ b/libs/wire-api/src/Wire/API/User/Search.hs @@ -317,6 +317,9 @@ instance FromByteString RoleFilter where parts <- C8.split ',' <$> parser RoleFilter <$> traverse (maybe (fail "Invalid role") pure . fromByteString) parts +-- In some places, we don't have bots as an option, so we don't want +-- to use 'UserType'. Once bots are removed from the picture, +-- 'UserType' and 'UserTypeFilter' will be the same ething. data UserTypeFilter = UserTypeFilterRegular | UserTypeFilterApp deriving (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserTypeFilter) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/TeamSize.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/TeamSize.hs index 8686e290a49..8137fe05501 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/TeamSize.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/TeamSize.hs @@ -21,10 +21,10 @@ import Imports import Wire.API.Team.Size testObject_TeamSize_1 :: TeamSize -testObject_TeamSize_1 = TeamSize 0 +testObject_TeamSize_1 = TeamSize 0 0 testObject_TeamSize_2 :: TeamSize -testObject_TeamSize_2 = TeamSize 100 +testObject_TeamSize_2 = TeamSize 100 400 testObject_TeamSize_3 :: TeamSize -testObject_TeamSize_3 = TeamSize (fromIntegral $ maxBound @Word64) +testObject_TeamSize_3 = TeamSize (fromIntegral $ maxBound @Word64) (fromIntegral $ maxBound @Word64) diff --git a/libs/wire-api/test/golden/testObject_TeamSize_1.json b/libs/wire-api/test/golden/testObject_TeamSize_1.json index c883020b742..92dda71f2da 100644 --- a/libs/wire-api/test/golden/testObject_TeamSize_1.json +++ b/libs/wire-api/test/golden/testObject_TeamSize_1.json @@ -1,3 +1,5 @@ { - "teamSize": 0 + "teamSize": 0, + "teamSizeApps": 0, + "teamSizeRegulars": 0 } diff --git a/libs/wire-api/test/golden/testObject_TeamSize_2.json b/libs/wire-api/test/golden/testObject_TeamSize_2.json index b33bf1f3bd8..5b9794591db 100644 --- a/libs/wire-api/test/golden/testObject_TeamSize_2.json +++ b/libs/wire-api/test/golden/testObject_TeamSize_2.json @@ -1,3 +1,5 @@ { - "teamSize": 100 + "teamSize": 500, + "teamSizeApps": 400, + "teamSizeRegulars": 100 } diff --git a/libs/wire-api/test/golden/testObject_TeamSize_3.json b/libs/wire-api/test/golden/testObject_TeamSize_3.json index 2e47b19f3e7..421801b4b47 100644 --- a/libs/wire-api/test/golden/testObject_TeamSize_3.json +++ b/libs/wire-api/test/golden/testObject_TeamSize_3.json @@ -1,3 +1,5 @@ { - "teamSize": 1.8446744073709551615e19 + "teamSize": 3.689348814741910323e19, + "teamSizeApps": 1.8446744073709551615e19, + "teamSizeRegulars": 1.8446744073709551615e19 } diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index e62655cecc3..24131b80a51 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -25,10 +25,12 @@ , bytestring-conversion , case-insensitive , cassandra-util +, comonad , conduit , constraints , containers , contravariant +, cookie , cql , crypton , crypton-pem @@ -69,6 +71,7 @@ , imports , iproute , iso639 +, kan-extensions , lens , lens-aeson , lib @@ -164,10 +167,12 @@ mkDerivation { bytestring-conversion case-insensitive cassandra-util + comonad conduit constraints containers contravariant + cookie cql crypton crypton-pem @@ -204,6 +209,7 @@ mkDerivation { imports iproute iso639 + kan-extensions lens lens-aeson lrucaching @@ -289,10 +295,12 @@ mkDerivation { bytestring-conversion case-insensitive cassandra-util + comonad conduit constraints containers contravariant + cookie cql crypton crypton-pem @@ -330,6 +338,7 @@ mkDerivation { imports iproute iso639 + kan-extensions lens lens-aeson lrucaching diff --git a/libs/wire-subsystems/postgres-migrations/20260428072649-create-conv-parent-index.sql b/libs/wire-subsystems/postgres-migrations/20260428072649-create-conv-parent-index.sql new file mode 100644 index 00000000000..a77c81bcfaf --- /dev/null +++ b/libs/wire-subsystems/postgres-migrations/20260428072649-create-conv-parent-index.sql @@ -0,0 +1 @@ +CREATE INDEX CONCURRENTLY IF NOT EXISTS conversation_parent_conv_idx ON conversation (parent_conv); diff --git a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs index 7353ad6092f..a319f729a8c 100644 --- a/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/BackgroundJobsRunner/Interpreter.hs @@ -43,7 +43,7 @@ import Wire.API.Team.HardTruncationLimit (hardTruncationLimit) import Wire.API.UserGroup import Wire.BackgroundJobsPublisher import Wire.BackgroundJobsRunner (BackgroundJobsRunner (..)) -import Wire.ConversationStore (ConversationStore, getConversation, upsertMembers) +import Wire.ConversationStore (ConversationStore, upsertMembers) import Wire.ConversationSubsystem import Wire.Sem.Random import Wire.StoredConversation @@ -96,7 +96,7 @@ runSyncUserGroupAndChannel (SyncUserGroupAndChannel {..}) = do . field "user_group" (toByteString userGroupId) . field "conv" (toByteString convId) . msg (val "User group not found for sync") - mConv <- getConversation convId + mConv <- internalGetConversation convId when (isNothing mConv) $ Log.warn $ field "conv" (toByteString convId) diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs index a4e53f2b9b3..ceec1624944 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs @@ -17,66 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.BrigAPIAccess - ( -- * Brig access effect - BrigAPIAccess (..), - - -- * Connections - getConnectionsUnqualified, - getConnectionsUnqualifiedBidi, - getConnections, - putConnectionInternal, - - -- * Users - reauthUser, - lookupActivatedUsers, - getUser, - getUsers, - deleteUser, - getContactList, - getRichInfoMultiUser, - getUserExportData, - updateSearchIndex, - getAccountsBy, - getUsersByVariousKeys, - - -- * Teams - getSize, - - -- * Clients - lookupClients, - lookupClientsFull, - notifyClientsAboutLegalHoldRequest, - getLegalHoldAuthToken, - addLegalHoldClientToUser, - removeLegalHoldClientFromUser, - OpaqueAuthToken (..), - - -- * MLS - getLocalMLSClients, - getLocalMLSClient, - - -- * Features - getAccountConferenceCallingConfigClient, - updateSearchVisibilityInbound, - - -- * Bots - deleteBot, - getAppIdsForTeam, - - -- * User Groups - createGroupInternal, - getGroupInternal, - getGroupsInternal, - updateGroup, - deleteGroupInternal, - deleteApp, - DeleteGroupManagedError (..), - - -- * Account status - setAccountStatus, - ) -where +module Wire.BrigAPIAccess where import Data.Aeson import Data.ByteString.Conversion @@ -90,17 +31,23 @@ import Network.HTTP.Types.Status import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Polysemy.Error +import SAML2.WebSSO qualified as SAML +import Web.Cookie (SetCookie) import Web.Scim.Filter qualified as Scim import Wire.API.Connection +import Wire.API.Error import Wire.API.Error.Galley +import Wire.API.Locale import Wire.API.MLS.CipherSuite import Wire.API.Routes.Internal.Brig import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Team.Export import Wire.API.Team.Feature +import Wire.API.Team.Role (Role) import Wire.API.Team.Size import Wire.API.User +import Wire.API.User.Auth (CookieLabel) import Wire.API.User.Auth.ReAuth import Wire.API.User.Client import Wire.API.User.Client.Prekey @@ -176,6 +123,46 @@ data BrigAPIAccess m a where DeleteApp :: TeamId -> UserId -> BrigAPIAccess m () GetAppIdsForTeam :: TeamId -> BrigAPIAccess m [UserId] SetAccountStatus :: UserId -> AccountStatus -> BrigAPIAccess m () + -- SAML / SCIM user management (migrated from Spar.Sem.BrigAccess) + CreateSAML :: + SAML.UserRef -> + UserId -> + TeamId -> + Name -> + ManagedBy -> + Maybe Handle -> + Maybe RichInfo -> + Maybe Locale -> + Role -> + BrigAPIAccess m UserId + CreateNoSAML :: + Text -> + EmailAddress -> + UserId -> + TeamId -> + Name -> + Maybe Locale -> + Role -> + BrigAPIAccess m UserId + UpdateEmail :: UserId -> EmailAddress -> EmailActivation -> BrigAPIAccess m () + GetAccount :: HavePendingInvitations -> UserId -> BrigAPIAccess m (Maybe User) + GetAccountByHandle :: Handle -> BrigAPIAccess m (Maybe User) + GetByEmail :: EmailAddress -> BrigAPIAccess m (Maybe User) + SetName :: UserId -> Name -> BrigAPIAccess m () + SetHandle :: UserId -> Handle -> BrigAPIAccess m () + SetManagedBy :: UserId -> ManagedBy -> BrigAPIAccess m () + SetSSOId :: UserId -> UserSSOId -> BrigAPIAccess m () + SetRichInfo :: UserId -> RichInfo -> BrigAPIAccess m () + SetLocale :: UserId -> Maybe Locale -> BrigAPIAccess m () + GetRichInfo :: UserId -> BrigAPIAccess m RichInfo + CheckHandleAvailable :: Handle -> BrigAPIAccess m Bool + SsoLogin :: UserId -> Maybe CookieLabel -> BrigAPIAccess m SetCookie + GetStatus :: UserId -> BrigAPIAccess m AccountStatus + GetStatusMaybe :: UserId -> BrigAPIAccess m (Maybe AccountStatus) + SetStatus :: UserId -> AccountStatus -> BrigAPIAccess m () + GetDefaultUserLocale :: BrigAPIAccess m Locale + CheckAdminGetTeamId :: UserId -> BrigAPIAccess m (Either Wai.Error TeamId) + SendSAMLIdPChangedEmail :: IdpChangedNotification -> BrigAPIAccess m () makeSem ''BrigAPIAccess @@ -198,3 +185,17 @@ getConnectionsUnqualifiedBidi uids1 uids2 mrel1 mrel2 = do res1 <- getConnectionsUnqualified uids1 (Just uids2) mrel1 res2 <- getConnectionsUnqualified uids2 (Just uids1) mrel2 pure (res1, res2) + +ensureConnectedToLocals :: + ( Member (ErrorS 'NotConnected) r, + Member BrigAPIAccess r + ) => + UserId -> + [UserId] -> + Sem r () +ensureConnectedToLocals _ [] = pure () +ensureConnectedToLocals u uids = do + (connsFrom, connsTo) <- + getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) + unless (length connsFrom == length uids && length connsTo == length uids) $ + throwS @'NotConnected diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs index 32703e2f923..f4bd3d9ea47 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs @@ -22,7 +22,7 @@ import Control.Monad.Catch (throwM) import Data.Aeson import Data.ByteString.Char8 qualified as BSC import Data.ByteString.Conversion -import Data.Handle (Handle) +import Data.Handle import Data.HavePendingInvitations (HavePendingInvitations (..)) import Data.Id import Data.Misc @@ -39,37 +39,44 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog +import SAML2.WebSSO qualified as SAML import System.Logger.Message qualified as Logger import Util.Options +import Web.Cookie (SetCookie, parseSetCookie) import Web.HttpApiData import Web.Scim.Filter as Scim import Wire.API.Connection import Wire.API.Error.Galley +import Wire.API.Locale import Wire.API.MLS.CipherSuite -import Wire.API.Routes.Internal.Brig (CreateGroupInternalRequest (..), GetBy, UpdateGroupInternalRequest (..)) +import Wire.API.Routes.Internal.Brig (CreateGroupInternalRequest (..), GetBy, IdpChangedNotification (..), UpdateGroupInternalRequest (..)) import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Team.Export import Wire.API.Team.Feature import Wire.API.Team.LegalHold.Internal +import Wire.API.Team.Role (Role) import Wire.API.Team.Size -import Wire.API.User (AccountStatus (..), AccountStatusUpdate (..), EmailAddress, UpdateConnectionsInternal, User, UserIds (..), UserSet (..)) +import Wire.API.User hiding (DeleteUser (..)) +import Wire.API.User.Auth (CookieLabel) import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth +import Wire.API.User.Auth.Sso qualified as Sso import Wire.API.User.Client import Wire.API.User.Client.Prekey -import Wire.API.User.Profile (ManagedBy) import Wire.API.User.RichInfo import Wire.API.UserGroup (NewUserGroup, UserGroup) import Wire.API.UserGroup.Pagination import Wire.BrigAPIAccess (BrigAPIAccess (..), DeleteGroupManagedError (..), OpaqueAuthToken (..)) import Wire.ParseException import Wire.Rpc +import Wire.RpcException interpretBrigAccess :: ( Member TinyLog r, Member Rpc r, - Member (Error ParseException) r + Member (Error ParseException) r, + Member (Error RpcException) r ) => Endpoint -> Sem (BrigAPIAccess ': r) a -> @@ -136,12 +143,54 @@ interpretBrigAccess brigEndpoint = updateGroup req DeleteGroupInternal managedBy teamId groupId -> deleteGroupInternal managedBy teamId groupId - DeleteApp teamId userId -> - deleteApp teamId userId GetAppIdsForTeam teamId -> getAppIdsForTeam teamId SetAccountStatus uid status -> setAccountStatus uid status + DeleteApp teamId uid -> + deleteApp teamId uid + CreateSAML uref buid teamid name managedBy handle richInfo mLocale role -> + createSAML uref buid teamid name managedBy handle richInfo mLocale role + CreateNoSAML extId email uid teamid uname locale role -> + createNoSAML extId email uid teamid uname locale role + UpdateEmail uid email activation -> + updateEmail uid email activation + GetAccount havePending uid -> + getAccount havePending uid + GetAccountByHandle handle -> + getByHandle handle + GetByEmail email -> + getByEmail email + SetName uid name -> + setName uid name + SetHandle uid handle -> + setHandle uid handle + SetManagedBy uid managedBy -> + setManagedBy uid managedBy + SetSSOId uid ssoId -> + setSSOId uid ssoId + SetRichInfo uid richInfo -> + setRichInfo uid richInfo + SetLocale uid mLocale -> + setLocale uid mLocale + GetRichInfo uid -> + getRichInfo uid + CheckHandleAvailable handle -> + checkHandleAvailable handle + SsoLogin uid mLabel -> + ssoLogin uid mLabel + GetStatus uid -> + getStatus uid + GetStatusMaybe uid -> + getStatusMaybe uid + SetStatus uid status -> + setStatus uid status + GetDefaultUserLocale -> + getDefaultUserLocale + CheckAdminGetTeamId uid -> + checkAdminGetTeamId uid + SendSAMLIdPChangedEmail notif -> + sendSAMLIdPChangedEmail notif brigRequest :: (Member Rpc r, Member (Input Endpoint) r) => (Request -> Request) -> Sem r (Response (Maybe LByteString)) brigRequest req = do @@ -713,11 +762,11 @@ deleteApp :: TeamId -> UserId -> Sem r () -deleteApp teamId userId = do +deleteApp teamId uid = do void $ brigRequest $ method DELETE - . paths ["i", "teams", toByteString' teamId, "apps", toByteString' userId] + . paths ["i", "teams", toByteString' teamId, "apps", toByteString' uid] . expect2xx getAppIdsForTeam :: @@ -750,3 +799,376 @@ is2xx = statusIs2xx . statusCode statusIs2xx :: Int -> Bool statusIs2xx s = s >= 200 && s < 300 + +-- SAML / SCIM user management (migrated from Spar.Intra.Brig) + +createSAML :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + SAML.UserRef -> + UserId -> + TeamId -> + Name -> + ManagedBy -> + Maybe Handle -> + Maybe RichInfo -> + Maybe Locale -> + Role -> + Sem r UserId +createSAML uref (Id buid) teamid name managedBy handle richInfo mLocale role = do + let newUser = + NewUserSpar + { newUserSparUUID = buid, + newUserSparDisplayName = name, + newUserSparSSOId = UserSSOId uref, + newUserSparTeamId = teamid, + newUserSparManagedBy = managedBy, + newUserSparHandle = handle, + newUserSparRichInfo = richInfo, + newUserSparLocale = mLocale, + newUserSparRole = role + } + resp <- brigRequest $ method POST . path "/i/users/spar" . json newUser + if statusCode resp `elem` [200, 201] + then userId . selfUser <$> decodeBodyOrThrow @SelfProfile "brig" resp + else rethrow "brig" resp + +createNoSAML :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + Text -> + EmailAddress -> + UserId -> + TeamId -> + Name -> + Maybe Locale -> + Role -> + Sem r UserId +createNoSAML extId email uid teamid uname locale role = do + let newUser = NewUserScimInvitation teamid uid extId locale uname email role + resp <- + brigRequest $ + method POST + . paths ["/i/teams", toByteString' teamid, "invitations"] + . json newUser + if statusCode resp `elem` [200, 201] + then userId <$> decodeBodyOrThrow @User "brig" resp + else + rethrow "brig" resp + +updateEmail :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + EmailAddress -> + EmailActivation -> + Sem r () +updateEmail buid email activation = do + resp <- + brigRequest $ + method PUT + . path "/i/self/email" + . header "Z-User" (toByteString' buid) + . query + [ ("activation", Just (toByteString' activation)), + ("validate", Just (fromBool validate)), + ("activate", Just (fromBool activate)) + ] + . json (EmailUpdate email) + case statusCode resp of + 204 -> pure () + 202 -> pure () + _ -> rethrow "brig" resp + where + (validate, activate) = case activation of + AutoActivate -> (False, True) + SendActivationEmail -> (True, False) + + fromBool :: Bool -> ByteString + fromBool True = "true" + fromBool False = "false" + +getAccount :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + HavePendingInvitations -> + UserId -> + Sem r (Maybe User) +getAccount havePending buid = do + resp <- + brigRequest $ + method GET + . paths ["/i/users"] + . query + [ ("ids", Just $ toByteString' buid), + ( "includePendingInvitations", + Just . toByteString' $ + case havePending of + WithPendingInvitations -> True + NoPendingInvitations -> False + ) + ] + case statusCode resp of + 200 -> + decodeBodyOrThrow @[User] "brig" resp >>= \case + [account] -> + pure $ + if userDeleted account + then Nothing + else Just account + _ -> pure Nothing + 404 -> pure Nothing + _ -> rethrow "brig" resp + +getByHandle :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + Handle -> + Sem r (Maybe User) +getByHandle handle = do + resp <- + brigRequest $ + method GET + . path "/i/users" + . queryItem "handles" (toByteString' handle) + . queryItem "includePendingInvitations" "true" + case statusCode resp of + 200 -> listToMaybe <$> decodeBodyOrThrow @[User] "brig" resp + 404 -> pure Nothing + _ -> rethrow "brig" resp + +getByEmail :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + EmailAddress -> + Sem r (Maybe User) +getByEmail email = do + resp <- + brigRequest $ + method GET + . path "/i/users" + . queryItem "email" (toByteString' email) + . queryItem "includePendingInvitations" "true" + case statusCode resp of + 200 -> do + macc <- listToMaybe <$> decodeBodyOrThrow @[User] "brig" resp + case userEmail =<< macc of + Just email' | email' == email -> pure macc + _ -> pure Nothing + 404 -> pure Nothing + _ -> rethrow "brig" resp + +setName :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + Name -> + Sem r () +setName buid (Name name) = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' buid, "name"] + . json (NameUpdate name) + if statusCode resp < 300 + then pure () + else rethrow "brig" resp + +setHandle :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + Handle -> + Sem r () +setHandle buid handle = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' buid, "handle"] + . json (HandleUpdate (fromHandle handle)) + case (statusCode resp, Wai.label <$> responseJsonMaybe @Wai.Error resp) of + (200, Nothing) -> pure () + _ -> rethrow "brig" resp + +setManagedBy :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + ManagedBy -> + Sem r () +setManagedBy buid managedBy = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' buid, "managed-by"] + . json (ManagedByUpdate managedBy) + unless (statusCode resp == 200) $ + rethrow "brig" resp + +setSSOId :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + UserSSOId -> + Sem r () +setSSOId buid ssoId = do + resp <- + brigRequest $ + method PUT + . paths ["i", "users", toByteString' buid, "sso-id"] + . json ssoId + unless (statusCode resp == 200) $ + rethrow "brig" resp + +setRichInfo :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + RichInfo -> + Sem r () +setRichInfo buid richInfo = do + resp <- + brigRequest $ + method PUT + . paths ["i", "users", toByteString' buid, "rich-info"] + . json (RichInfoUpdate $ unRichInfo richInfo) + unless (statusCode resp == 200) $ + rethrow "brig" resp + +setLocale :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + Maybe Locale -> + Sem r () +setLocale buid = \case + Just locale -> do + resp <- + brigRequest $ + method PUT + . paths ["i", "users", toByteString' buid, "locale"] + . json (LocaleUpdate locale) + unless (statusCode resp == 200) $ + rethrow "brig" resp + Nothing -> do + resp <- + brigRequest $ + method DELETE + . paths ["i", "users", toByteString' buid, "locale"] + unless (statusCode resp == 200) $ + rethrow "brig" resp + +getRichInfo :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + UserId -> + Sem r RichInfo +getRichInfo buid = do + resp <- + brigRequest $ + method GET + . paths ["/i/users", toByteString' buid, "rich-info"] + if statusCode resp == 200 + then decodeBodyOrThrow "brig" resp + else rethrow "brig" resp + +checkHandleAvailable :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + Handle -> + Sem r Bool +checkHandleAvailable hnd = do + resp <- + brigRequest $ + method HEAD + . paths ["/i/users/handles", toByteString' hnd] + case statusCode resp of + 200 -> pure False -- handle exists + 404 -> pure True -- 404: handle not found + _ -> rethrow "brig" resp + +ssoLogin :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + UserId -> + Maybe CookieLabel -> + Sem r SetCookie +ssoLogin buid mlabel = do + resp <- + brigRequest $ + method POST + . path "/i/sso-login" + . json (Sso.SsoLogin buid mlabel) + . queryItem "persist" "true" + case statusCode resp of + 200 -> + case getHeader "Set-Cookie" resp of + Nothing -> throw $ ParseException "brig" "Missing Set-Cookie header in SSO login response" + Just cky -> pure $ parseSetCookie cky + _ -> rethrow "brig" resp + +getStatusRaw :: + (Member Rpc r, Member (Input Endpoint) r) => + UserId -> + Sem r ResponseLBS +getStatusRaw uid = + brigRequest $ + check [status200, status404] + . method GET + . paths ["/i/users", toByteString' uid, "status"] + +getStatus :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + UserId -> + Sem r AccountStatus +getStatus uid = do + resp <- getStatusRaw uid + case statusCode resp of + 200 -> fromAccountStatusResp <$> decodeBodyOrThrow @AccountStatusResp "brig" resp + _ -> rethrow "brig" resp + +getStatusMaybe :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + UserId -> + Sem r (Maybe AccountStatus) +getStatusMaybe uid = do + resp <- getStatusRaw uid + case statusCode resp of + 200 -> Just . fromAccountStatusResp <$> decodeBodyOrThrow @AccountStatusResp "brig" resp + 404 -> pure Nothing + _ -> rethrow "brig" resp + +setStatus :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + UserId -> + AccountStatus -> + Sem r () +setStatus uid status = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' uid, "status"] + . json (AccountStatusUpdate status) + unless (statusCode resp == 200) $ + rethrow "brig" resp + +getDefaultUserLocale :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + Sem r Locale +getDefaultUserLocale = do + resp <- brigRequest $ method GET . path "/i/users/locale" + case statusCode resp of + 200 -> luLocale <$> decodeBodyOrThrow @LocaleUpdate "brig" resp + _ -> rethrow "brig" resp + +checkAdminGetTeamId :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r, Member (Error RpcException) r) => + UserId -> + Sem r (Either Wai.Error TeamId) +checkAdminGetTeamId uid = do + resp <- + brigRequest $ + check [status200, status403] + . method GET + . paths ["/i/users", toByteString' uid, "check-admin-get-team-id"] + case statusCode resp of + 200 -> Right <$> decodeBodyOrThrow "brig" resp + _ -> rethrow "brig" resp + +sendSAMLIdPChangedEmail :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error RpcException) r) => + IdpChangedNotification -> + Sem r () +sendSAMLIdPChangedEmail notif = do + resp <- + brigRequest $ + method POST + . path "/i/idp/send-idp-changed-email" + . json notif + unless (statusCode resp == 200) $ + rethrow "brig" resp diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs index 6fdd631757d..bc36f8de6bc 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs @@ -455,7 +455,7 @@ addMembers conv (UserList lusers rusers) = do -- User is remote, so we only add it to the member_remote_user -- table, but the reverse mapping has to be done on the remote -- backend; so we assume an additional call to their backend has - -- been (or will be) made separately. See Galley.API.Update.addMembers + -- been (or will be) made separately. See Wire.ConversationSubsystem.Update.addMembers addPrepQuery Cql.insertRemoteMember (conv, domain, uid, role) pure (map newMemberWithRole lusers, map newRemoteMemberWithRole rusers) diff --git a/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs b/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs index 2573cfdd0fd..f3e620ed1de 100644 --- a/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs +++ b/libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs @@ -174,6 +174,10 @@ cmSingleton cid idx = (cidQualifiedUser cid) (Map.singleton (ciClient cid) idx) +-- | Construct the subset of the first client map consisting of users that are present in the second. +cmIntersect :: ClientMap a -> ClientMap b -> ClientMap a +cmIntersect (ClientMap m1) (ClientMap m2) = ClientMap (Map.intersection m1 m2) + -- | Inform a handler for 'POST /conversations/list-ids' if the MLS global team -- conversation and the MLS self-conversation should be included in the -- response. diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs index 3a4593cf22a..44605b64467 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem.hs @@ -17,18 +17,64 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.ConversationSubsystem where +module Wire.ConversationSubsystem + ( module Wire.ConversationSubsystem, + Util.BotsAndMembers (..), + Util.canDeleteMember, + Util.isMember, + Util.userLHEnabled, + MLSRemoval.RemoveUserIncludeMain (..), + LegalholdConflicts.guardLegalholdPolicyConflicts, + ) +where +import Data.Code qualified as Code +import Data.CommaSeparatedList (CommaSeparatedList) +import Data.Domain import Data.Id +import Data.Misc (IpAddr) import Data.Qualified -import Data.Range (Range) +import Data.Range import Data.Singletons (Sing) -import Galley.Types.Clients (Clients) import Imports import Polysemy -import Wire.API.Conversation (ConvIdsPage, ConversationPagingState, ExtraConversationData, NewConv, NewOne2OneConv) +import Wire.API.Bot (AddBot, RemoveBot) +import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation qualified as Public import Wire.API.Conversation.Action +import Wire.API.Conversation.CellsState (CellsState) +import Wire.API.Conversation.Code (ConversationCodeInfo, CreateConversationCodeRequest, JoinConversationByCode) +import Wire.API.Conversation.Pagination (ConversationPage) +import Wire.API.Conversation.Protocol +import Wire.API.Conversation.Role (ConversationRolesList) +import Wire.API.Conversation.Typing import Wire.API.Event.Conversation +import Wire.API.Federation.API.Common +import Wire.API.Federation.API.Galley +import Wire.API.MLS.CommitBundle +import Wire.API.MLS.GroupInfo (GroupInfoData) +import Wire.API.MLS.Keys (MLSKeys, MLSKeysByPurpose, MLSPublicKey, MLSPublicKeyFormat, SomeKey) +import Wire.API.MLS.Message +import Wire.API.MLS.OutOfSync (EnableOutOfSyncCheck) +import Wire.API.MLS.Serialisation +import Wire.API.MLS.SubConversation (ConvOrSubConvId, PublicSubConversation, SubConvId) +import Wire.API.Message (ClientMismatch, IgnoreMissing, MessageSendingStatus, NewOtrMessage, QualifiedNewOtrMessage, ReportMissing) +import Wire.API.Pagination (PageSize, SortOrder) +import Wire.API.Provider.Bot qualified as Public (BotConvView) +import Wire.API.Routes.Internal.Galley.ConversationsIntra (UpsertOne2OneConversationRequest) +import Wire.API.Routes.Public (ZHostValue) +import Wire.API.Routes.Public.Galley.Conversation +import Wire.API.Routes.Public.Galley.MLS (MLSReset) +import Wire.API.Routes.Public.Galley.Messaging (MessageNotSent, PostOtrResponse) +import Wire.API.Routes.Public.Util (UpdateResult) +import Wire.API.Routes.Version +import Wire.API.ServantProto (RawProto (..)) +import Wire.API.Team.Feature (GuestLinksConfig, LockableFeature) +import Wire.ConversationStore.MLS.Types (ListGlobalSelfConvs) +import Wire.ConversationSubsystem.LegalholdConflicts qualified as LegalholdConflicts +import Wire.ConversationSubsystem.MLS.IncomingMessage (IncomingBundle, IncomingMessage) +import Wire.ConversationSubsystem.MLS.Removal qualified as MLSRemoval +import Wire.ConversationSubsystem.Util qualified as Util import Wire.NotificationSubsystem (LocalConversationUpdate) import Wire.StoredConversation @@ -45,24 +91,39 @@ data ConversationSubsystem m a where ConversationAction (tag :: ConversationActionTag) -> ExtraConversationData -> ConversationSubsystem r LocalConversationUpdate - CreateGroupConversation :: + InternalCreateGroupConversation :: Local UserId -> Maybe ConnId -> NewConv -> ConversationSubsystem m StoredConversation + CreateLegacyGroupConversation :: + Local UserId -> + Maybe ConnId -> + NewConv -> + ConversationSubsystem m (ConversationResponse Public.OwnConversation) + CreateGroupOwnConversation :: + Local UserId -> + Maybe ConnId -> + NewConv -> + ConversationSubsystem m CreateGroupConversationResponseV9 + CreateGroupConversation :: + Local UserId -> + Maybe ConnId -> + NewConv -> + ConversationSubsystem m CreateGroupConversation + CreateProteusSelfConversation :: + Local UserId -> + ConversationSubsystem m (ConversationResponse Public.OwnConversation) CreateOne2OneConversation :: Local UserId -> ConnId -> NewOne2OneConv -> - ConversationSubsystem m (StoredConversation, Bool) - CreateProteusSelfConversation :: - Local UserId -> - ConversationSubsystem m (StoredConversation, Bool) + ConversationSubsystem m (ConversationResponse Public.OwnConversation) CreateConnectConversation :: Local UserId -> Maybe ConnId -> Connect -> - ConversationSubsystem m (StoredConversation, Bool) + ConversationSubsystem m (ConversationResponse Public.OwnConversation) GetConversations :: [ConvId] -> ConversationSubsystem m [StoredConversation] @@ -71,10 +132,509 @@ data ConversationSubsystem m a where Range 1 1000 Int32 -> Maybe ConversationPagingState -> ConversationSubsystem r ConvIdsPage - InternalGetClientIds :: [UserId] -> ConversationSubsystem m Clients InternalGetLocalMember :: ConvId -> UserId -> ConversationSubsystem m (Maybe LocalMember) + InternalGetMember :: + Qualified ConvId -> + UserId -> + ConversationSubsystem m (Maybe Public.Member) + GetConversationMeta :: + ConvId -> + ConversationSubsystem m ConversationMetadata + GetMLSOne2OneConversationInternal :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m Public.OwnConversation + IsMLSOne2OneEstablished :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m Bool + GetLocalConversationInternal :: + ConvId -> + ConversationSubsystem m Conversation + RemoveClient :: + UserId -> + ClientId -> + ConversationSubsystem m () + AddBot :: + Local UserId -> + ConnId -> + AddBot -> + ConversationSubsystem m Event + RmBot :: + Local UserId -> + Maybe ConnId -> + RemoveBot -> + ConversationSubsystem m (UpdateResult Event) + UpdateCellsState :: + ConvId -> + CellsState -> + ConversationSubsystem m () + RemoveUser :: + Local StoredConversation -> + MLSRemoval.RemoveUserIncludeMain -> + Qualified UserId -> + ConversationSubsystem m () + PostMLSCommitBundle :: + Local x -> + Qualified UserId -> + ClientId -> + ConvType -> + Qualified ConvOrSubConvId -> + Maybe ConnId -> + EnableOutOfSyncCheck -> + IncomingBundle -> + ConversationSubsystem m [LocalConversationUpdate] + PostMLSCommitBundleFromLocalUser :: + Version -> + Local UserId -> + ClientId -> + ConnId -> + RawMLS CommitBundle -> + ConversationSubsystem m MLSMessageSendingStatus + PostMLSMessage :: + Local x -> + Qualified UserId -> + ClientId -> + ConvType -> + Qualified ConvOrSubConvId -> + Maybe ConnId -> + EnableOutOfSyncCheck -> + IncomingMessage -> + ConversationSubsystem m [LocalConversationUpdate] + PostMLSMessageFromLocalUser :: + Version -> + Local UserId -> + ClientId -> + ConnId -> + RawMLS Message -> + ConversationSubsystem m MLSMessageSendingStatus + IsMLSEnabled :: ConversationSubsystem m Bool + GetConversationsInternal :: + Local UserId -> + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Maybe ConvId -> + Maybe (Range 1 500 Int32) -> + ConversationSubsystem m (Public.ConversationList StoredConversation) + RemoveMemberFromLocalConv :: + Local ConvId -> + Local UserId -> + Maybe ConnId -> + Qualified UserId -> + ConversationSubsystem m (Maybe Event) + FederationOnConversationCreated :: + Domain -> + ConversationCreated ConvId -> + ConversationSubsystem m EmptyResponse + FederationGetConversations :: + Domain -> + GetConversationsRequest -> + ConversationSubsystem m GetRemoteConversationViewsResponse + FederationLeaveConversation :: + Domain -> + LeaveConversationRequest -> + ConversationSubsystem m LeaveConversationResponse + FederationSendMessage :: + Domain -> + ProteusMessageSendRequest -> + ConversationSubsystem m MessageSendResponse + FederationUpdateConversation :: + Domain -> + ConversationUpdateRequest -> + ConversationSubsystem m ConversationUpdateResponse + FederationMlsSendWelcome :: + Domain -> + MLSWelcomeRequest -> + ConversationSubsystem m MLSWelcomeResponse + FederationSendMLSMessage :: + Domain -> + MLSMessageSendRequest -> + ConversationSubsystem m MLSMessageResponse + FederationSendMLSCommitBundle :: + Domain -> + MLSMessageSendRequest -> + ConversationSubsystem m MLSMessageResponse + FederationQueryGroupInfo :: + Domain -> + GetGroupInfoRequest -> + ConversationSubsystem m GetGroupInfoResponse + FederationUpdateTypingIndicator :: + Domain -> + TypingDataUpdateRequest -> + ConversationSubsystem m TypingDataUpdateResponse + FederationOnTypingIndicatorUpdated :: + Domain -> + TypingDataUpdated -> + ConversationSubsystem m EmptyResponse + FederationGetSubConversationForRemoteUser :: + Domain -> + GetSubConversationsRequest -> + ConversationSubsystem m GetSubConversationsResponse + FederationDeleteSubConversationForRemoteUser :: + Domain -> + DeleteSubConversationFedRequest -> + ConversationSubsystem m DeleteSubConversationResponse + FederationLeaveSubConversation :: + Domain -> + LeaveSubConversationRequest -> + ConversationSubsystem m LeaveSubConversationResponse + FederationGetLegacyOne2OneConversation :: + Domain -> + GetOne2OneConversationRequest -> + ConversationSubsystem m GetOne2OneConversationResponse + FederationGetOne2OneConversation :: + Domain -> + GetOne2OneConversationRequest -> + ConversationSubsystem m GetOne2OneConversationResponseV2 + FederationOnClientRemoved :: + Domain -> + ClientRemovedRequest -> + ConversationSubsystem m EmptyResponse + FederationOnMessageSent :: + Domain -> + RemoteMessage ConvId -> + ConversationSubsystem m EmptyResponse + FederationOnMLSMessageSent :: + Domain -> + RemoteMLSMessage -> + ConversationSubsystem m EmptyResponse + FederationOnConversationUpdated :: + Domain -> + ConversationUpdate -> + ConversationSubsystem m EmptyResponse + FederationOnUserDeleted :: + Domain -> + UserDeletedConversationsNotification -> + ConversationSubsystem m EmptyResponse + PostOtrMessageUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> + NewOtrMessage -> + ConversationSubsystem m (PostOtrResponse ClientMismatch) + PostOtrBroadcastUnqualified :: + Local UserId -> + ConnId -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> + NewOtrMessage -> + ConversationSubsystem m (PostOtrResponse ClientMismatch) + PostProteusMessage :: + Local UserId -> + ConnId -> + Qualified ConvId -> + RawProto QualifiedNewOtrMessage -> + ConversationSubsystem m (PostOtrResponse MessageSendingStatus) + PostProteusBroadcast :: + Local UserId -> + ConnId -> + QualifiedNewOtrMessage -> + ConversationSubsystem m (PostOtrResponse MessageSendingStatus) + DeleteLocalConversation :: + Local UserId -> + ConnId -> + Local ConvId -> + ConversationSubsystem m (UpdateResult Event) + GetMLSPublicKeys :: + Maybe MLSPublicKeyFormat -> + ConversationSubsystem m (MLSKeysByPurpose (MLSKeys SomeKey)) + ResetMLSConversation :: + Local UserId -> + MLSReset -> + ConversationSubsystem m () + GetSubConversation :: + Local UserId -> + Qualified ConvId -> + SubConvId -> + ConversationSubsystem m PublicSubConversation + GetBotConversation :: + BotId -> + ConvId -> + ConversationSubsystem m Public.BotConvView + -- Query functions + GetUnqualifiedOwnConversation :: + Local UserId -> + ConvId -> + ConversationSubsystem m Public.OwnConversation + GetOwnConversation :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m Public.OwnConversation + GetPaginatedConversations :: + Local UserId -> + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Maybe ConvId -> + Maybe (Range 1 500 Int32) -> + ConversationSubsystem m (Public.ConversationList Public.OwnConversation) + GetConversation :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m Public.Conversation + InternalGetConversation :: + ConvId -> + ConversationSubsystem m (Maybe StoredConversation) + GetConversationRoles :: + Local UserId -> + ConvId -> + ConversationSubsystem m ConversationRolesList + SearchChannels :: + Local UserId -> + TeamId -> + Maybe Text -> + Maybe SortOrder -> + Maybe PageSize -> + Maybe Text -> + Maybe ConvId -> + Bool -> + ConversationSubsystem m ConversationPage + GetGroupInfo :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m GroupInfoData + ConversationIdsPageFromUnqualified :: + Local UserId -> + Maybe ConvId -> + Maybe (Range 1 1000 Int32) -> + ConversationSubsystem m (ConversationList ConvId) + ConversationIdsPaginated :: + ListGlobalSelfConvs -> + Local UserId -> + Public.GetPaginatedConversationIds -> + ConversationSubsystem m Public.ConvIdsPage + ConversationIdsPageFrom :: + Local UserId -> + Public.GetPaginatedConversationIds -> + ConversationSubsystem m Public.ConvIdsPage + ListConversations :: + Local UserId -> + Public.ListConversations -> + ConversationSubsystem m ConversationsResponse + GetConversationByReusableCode :: + Local UserId -> + Code.Key -> + Code.Value -> + ConversationSubsystem m ConversationCoverView + GetMLSSelfConversationWithError :: + Local UserId -> + ConversationSubsystem m Public.OwnConversation + GetMLSOne2OneOwnConversation :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m Public.OwnConversation + GetMLSOne2OneMLSConversation :: + Local UserId -> + Qualified UserId -> + ConversationSubsystem m (MLSOne2OneConversation MLSPublicKey) + GetMLSOne2OneConversation :: + Local UserId -> + Qualified UserId -> + Maybe MLSPublicKeyFormat -> + ConversationSubsystem m (MLSOne2OneConversation SomeKey) + GetLocalSelf :: + Local UserId -> + ConvId -> + ConversationSubsystem m (Maybe Public.Member) + GetSelfMember :: + Local UserId -> + Qualified ConvId -> + ConversationSubsystem m (Maybe Public.Member) + GetConversationGuestLinksStatus :: + UserId -> + ConvId -> + ConversationSubsystem m (LockableFeature GuestLinksConfig) + GetCode :: + Maybe Text -> + Local UserId -> + ConvId -> + ConversationSubsystem m ConversationCodeInfo + -- Update functions + + AddQualifiedMembersUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + InviteQualified -> + ConversationSubsystem m (UpdateResult Event) + AddMembers :: + Local UserId -> + ConnId -> + Qualified ConvId -> + InviteQualified -> + ConversationSubsystem m (UpdateResult Event) + ReplaceMembers :: + Local UserId -> + ConnId -> + Qualified ConvId -> + InviteQualified -> + ConversationSubsystem m () + JoinConversationById :: + Local UserId -> + ConnId -> + ConvId -> + ConversationSubsystem m (UpdateResult Event) + JoinConversationByReusableCode :: + Local UserId -> + ConnId -> + JoinConversationByCode -> + ConversationSubsystem m (UpdateResult Event) + CheckReusableCode :: + IpAddr -> + ConversationCode -> + ConversationSubsystem m () + AddCodeUnqualified :: + Maybe CreateConversationCodeRequest -> + UserId -> + Maybe ZHostValue -> + Maybe ConnId -> + ConvId -> + ConversationSubsystem m AddCodeResult + RmCodeUnqualified :: + Local UserId -> + ConnId -> + ConvId -> + ConversationSubsystem m Event + MemberTyping :: + Local UserId -> + ConnId -> + Qualified ConvId -> + TypingStatus -> + ConversationSubsystem m () + RemoveMemberQualified :: + Local UserId -> + ConnId -> + Qualified ConvId -> + Qualified UserId -> + ConversationSubsystem m (Maybe Event) + UpdateOtherMember :: + Local UserId -> + ConnId -> + Qualified ConvId -> + Qualified UserId -> + OtherMemberUpdate -> + ConversationSubsystem m () + UpdateConversationName :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationRename -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationMessageTimer :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationMessageTimerUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationReceiptMode :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationReceiptModeUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationAccess :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationAccessData -> + ConversationSubsystem m (UpdateResult Event) + UpdateConversationHistory :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ConversationHistoryUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateSelfMember :: + Local UserId -> + ConnId -> + Qualified ConvId -> + MemberUpdate -> + ConversationSubsystem m () + UpdateConversationProtocolWithLocalUser :: + Local UserId -> + ConnId -> + Qualified ConvId -> + ProtocolUpdate -> + ConversationSubsystem m (UpdateResult Event) + UpdateChannelAddPermission :: + Local UserId -> + ConnId -> + Qualified ConvId -> + AddPermissionUpdate -> + ConversationSubsystem m (UpdateResult Event) + PostBotMessageUnqualified :: + BotId -> + ConvId -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> + NewOtrMessage -> + ConversationSubsystem m (Either (MessageNotSent ClientMismatch) ClientMismatch) + -- Sub-conversation functions + DeleteSubConversation :: + Local UserId -> + Qualified ConvId -> + SubConvId -> + MLSReset -> + ConversationSubsystem m () + GetSubConversationGroupInfo :: + Local UserId -> + Qualified ConvId -> + SubConvId -> + ConversationSubsystem m GroupInfoData + LeaveSubConversation :: + Local UserId -> + ClientId -> + Qualified ConvId -> + SubConvId -> + ConversationSubsystem m () + SendConversationActionNotifications :: + forall tag m. + Sing tag -> + Qualified UserId -> + Bool -> + Maybe ConnId -> + Local StoredConversation -> + Util.BotsAndMembers -> + ConversationAction (tag :: ConversationActionTag) -> + ExtraConversationData -> + ConversationSubsystem m LocalConversationUpdate + InternalUpsertOne2OneConversation :: + UpsertOne2OneConversationRequest -> + ConversationSubsystem m () + AcceptConv :: + QualifiedWithTag QLocal UserId -> + Maybe ConnId -> + ConvId -> + ConversationSubsystem m OwnConversation + BlockConv :: + QualifiedWithTag QLocal UserId -> + Qualified ConvId -> + ConversationSubsystem m () + UnblockConv :: + QualifiedWithTag QLocal UserId -> + Maybe ConnId -> + Qualified ConvId -> + ConversationSubsystem m () makeSem ''ConversationSubsystem + +iterateConversations :: + (Member ConversationSubsystem r) => + Local UserId -> + Range 1 500 Int32 -> + ([StoredConversation] -> Sem r a) -> + Sem r [a] +iterateConversations luid pageSize handleConvs = go Nothing + where + go mbConv = do + convResult <- getConversationsInternal luid Nothing mbConv (Just pageSize) + resultHead <- handleConvs (convList convResult) + resultTail <- case convList convResult of + (conv : rest) -> + if convHasMore convResult + then go (Just (maximum ((.id_) <$> (conv : rest)))) + else pure [] + _ -> pure [] + pure $ resultHead : resultTail diff --git a/services/galley/src/Galley/API/Action.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action.hs similarity index 97% rename from services/galley/src/Galley/API/Action.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action.hs index 7a0816a0153..3c81ed700f9 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action +module Wire.ConversationSubsystem.Action ( -- * Conversation action types ConversationActionTag (..), ConversationJoin (..), @@ -73,14 +73,6 @@ import Data.Set qualified as Set import Data.Singletons import Data.Time.Clock import GHC.TypeLits (KnownNat) -import Galley.API.Action.Kick -import Galley.API.Action.Leave -import Galley.API.Action.Notify -import Galley.API.Action.Reset -import Galley.API.MLS.Conversation -import Galley.API.MLS.Migration -import Galley.API.MLS.Removal -import Galley.API.Teams.Features.Get import Galley.Types.Error import Imports hiding ((\\)) import Polysemy @@ -122,7 +114,13 @@ import Wire.BrigAPIAccess qualified as E import Wire.CodeStore import Wire.CodeStore qualified as E import Wire.ConversationStore qualified as E -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action.Kick +import Wire.ConversationSubsystem.Action.Leave +import Wire.ConversationSubsystem.Action.Notify +import Wire.ConversationSubsystem.Action.Reset +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.Migration +import Wire.ConversationSubsystem.MLS.Removal import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FeaturesConfigSubsystem @@ -140,7 +138,7 @@ import Wire.StoredConversation import Wire.StoredConversation qualified as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (ConsentGiven (..), TeamSubsystem, consentGiven) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList import Wire.Util @@ -189,7 +187,6 @@ instance IsConversationAction 'ConversationJoinTag where HasConversationActionEffects 'ConversationJoinTag r = ( -- TODO: Replace with subsystems Member BackendNotificationQueueAccess r, - Member ConversationSubsystem r, Member TeamCollaboratorsSubsystem r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -461,7 +458,6 @@ instance IsConversationAction 'ConversationAccessDataTag where Member Random r, Member (Error FederationError) r, Member BackendNotificationQueueAccess r, - Member ConversationSubsystem r, Member TeamSubsystem r ) @@ -694,7 +690,6 @@ instance IsConversationAction 'ConversationResetTag where ( Member BackendNotificationQueueAccess r, Member (E.FederationAPIAccess FederatorClient) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member E.ConversationStore r, Member NotificationSubsystem r, Member ProposalStore r, @@ -825,7 +820,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role joinType) = do -- - ensure that a consented conv admin exists -- - and kick all existing members that do not consent to LH from the conversation -- See also: "Brig.API.Connection.checkLegalholdPolicyConflict" - -- and "Galley.API.LegalHold.Conflicts.guardLegalholdPolicyConflictsUid". + -- and "Wire.ConversationSubsystem.LegalholdConflicts.guardLegalholdPolicyConflictsUid". checkLHPolicyConflictsLocal :: [UserId] -> Sem r () @@ -843,7 +838,7 @@ performConversationJoin qusr lconv (ConversationJoin invited role joinType) = do throwS @'MissingLegalholdConsent convUsersLHStatus <- do - uidsStatus <- getLHStatusForUsers ((.id_) <$> convUsers) + uidsStatus <- TeamSubsystem.getLHStatusForUsers ((.id_) <$> convUsers) pure $ zipWith (\mem (_, status) -> (mem, status)) convUsers uidsStatus if any @@ -995,7 +990,6 @@ updateLocalConversationJoin :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationJoinTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamCollaboratorsSubsystem r, Member TeamSubsystem r, @@ -1034,7 +1028,6 @@ updateLocalConversationLeave :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationLeaveTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r, Member ExternalAccess r, @@ -1057,7 +1050,10 @@ updateLocalConversationMemberUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationMemberUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member (ErrorS ConvMemberNotFound) r, Member E.ConversationStore r @@ -1074,7 +1070,10 @@ updateLocalConversationDelete :: ( Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationDeleteTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member CodeStore r, Member E.ConversationStore r, @@ -1093,7 +1092,10 @@ updateLocalConversationRename :: ( Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationRenameTag))) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member (Error InvalidInput) r, Member E.ConversationStore r, @@ -1112,7 +1114,10 @@ updateLocalConversationMessageTimerUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationMessageTimerUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member E.ConversationStore r, Member (Error NoChanges) r @@ -1130,7 +1135,10 @@ updateLocalConversationReceiptModeUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationReceiptModeUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r, Member E.ConversationStore r, Member (Error NoChanges) r, @@ -1149,7 +1157,6 @@ updateLocalConversationAccessData :: Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationAccessDataTag))) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member (Error NoChanges) r, Member TinyLog r, Member E.ConversationStore r, @@ -1179,7 +1186,6 @@ updateLocalConversationRemoveMembers :: ( Member BackendNotificationQueueAccess r, Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationRemoveMembersTag))) r, - Member ConversationSubsystem r, Member (Error NoChanges) r, Member TinyLog r, Member E.ConversationStore r, @@ -1207,7 +1213,6 @@ updateLocalConversationUpdateProtocol :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationUpdateProtocolTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member (Error NoChanges) r, Member (E.FederationAPIAccess FederatorClient) r, Member TinyLog r, @@ -1237,7 +1242,10 @@ updateLocalConversationUpdateAddPermission :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationUpdateAddPermissionTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member (Error NoChanges) r, Member E.ConversationStore r, Member TeamSubsystem r, @@ -1257,7 +1265,6 @@ updateLocalConversationReset :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationResetTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member (E.FederationAPIAccess FederatorClient) r, Member TinyLog r, Member E.ConversationStore r, @@ -1285,7 +1292,10 @@ updateLocalConversationHistoryUpdate :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationHistoryUpdateTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, Member E.ConversationStore r, Member TeamSubsystem r, Member (ErrorS HistoryNotSupported) r @@ -1304,7 +1314,6 @@ updateLocalConversationUncheckedJoin :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationJoinTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamCollaboratorsSubsystem r, Member TeamSubsystem r, @@ -1343,7 +1352,6 @@ updateLocalConversationUncheckedRemoveMembers :: Member (ErrorS ('ActionDenied (ConversationActionPermission 'ConversationRemoveMembersTag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r, Member (Error NoChanges) r, @@ -1370,7 +1378,10 @@ updateLocalConversation :: Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, HasConversationActionEffects tag r, IsConversationAction tag, SingI tag, @@ -1405,7 +1416,10 @@ updateLocalConversationUnchecked :: Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member Now r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, HasConversationActionEffects tag r, Member TeamSubsystem r ) => diff --git a/services/galley/src/Galley/API/Action/Kick.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Kick.hs similarity index 93% rename from services/galley/src/Galley/API/Action/Kick.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Kick.hs index 7356b04c10b..ddb1caae8a0 100644 --- a/services/galley/src/Galley/API/Action/Kick.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Kick.hs @@ -15,14 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Kick where +module Wire.ConversationSubsystem.Action.Kick where import Data.Default import Data.Id import Data.Qualified import Data.Singletons -import Galley.API.Action.Leave -import Galley.API.Action.Notify import Imports hiding ((\\)) import Polysemy import Polysemy.Error @@ -35,7 +33,8 @@ import Wire.API.Event.LeaveReason import Wire.API.Federation.Error import Wire.BackendNotificationQueueAccess import Wire.ConversationStore (ConversationStore) -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action.Leave +import Wire.ConversationSubsystem.Action.Notify import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.NotificationSubsystem @@ -53,7 +52,6 @@ kickMember :: ( Member BackendNotificationQueueAccess r, Member (Error FederationError) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member ProposalStore r, Member Now r, diff --git a/services/galley/src/Galley/API/Action/Leave.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Leave.hs similarity index 94% rename from services/galley/src/Galley/API/Action/Leave.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Leave.hs index 0141cc4ad2c..4e88fd77f9a 100644 --- a/services/galley/src/Galley/API/Action/Leave.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Leave.hs @@ -15,12 +15,11 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Leave (leaveConversation) where +module Wire.ConversationSubsystem.Action.Leave (leaveConversation) where import Control.Lens import Data.Id import Data.Qualified -import Galley.API.MLS.Removal import Imports hiding ((\\)) import Polysemy import Polysemy.Error @@ -30,6 +29,7 @@ import Wire.API.Conversation.Config (ConversationSubsystemConfig) import Wire.API.Federation.Error import Wire.BackendNotificationQueueAccess import Wire.ConversationStore (ConversationStore) +import Wire.ConversationSubsystem.MLS.Removal import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.NotificationSubsystem diff --git a/services/galley/src/Galley/API/Action/Notify.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Notify.hs similarity index 76% rename from services/galley/src/Galley/API/Action/Notify.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Notify.hs index 77c8167ebc3..4a11ac20012 100644 --- a/services/galley/src/Galley/API/Action/Notify.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Notify.hs @@ -15,24 +15,34 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Notify where +module Wire.ConversationSubsystem.Action.Notify where import Data.Id import Data.Qualified import Data.Singletons import Imports hiding ((\\)) import Polysemy +import Polysemy.Error import Wire.API.Conversation hiding (Conversation, Member) import Wire.API.Conversation.Action import Wire.API.Event.Conversation -import Wire.ConversationSubsystem +import Wire.API.Federation.Error +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) +import Wire.ConversationSubsystem.Notify (notifyConversationActionImpl) import Wire.ConversationSubsystem.Util +import Wire.ExternalAccess (ExternalAccess) import Wire.NotificationSubsystem +import Wire.Sem.Now (Now) import Wire.StoredConversation sendConversationActionNotifications :: forall tag r. - (Member ConversationSubsystem r) => + ( Member BackendNotificationQueueAccess r, + Member ExternalAccess r, + Member (Error FederationError) r, + Member Now r, + Member NotificationSubsystem r + ) => Sing tag -> Qualified UserId -> Bool -> @@ -43,7 +53,7 @@ sendConversationActionNotifications :: ExtraConversationData -> Sem r LocalConversationUpdate sendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData = do - notifyConversationAction + notifyConversationActionImpl tag (EventFromUser quid) notifyOrigDomain diff --git a/services/galley/src/Galley/API/Action/Reset.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Reset.hs similarity index 96% rename from services/galley/src/Galley/API/Action/Reset.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Reset.hs index 49614ab300d..c31399a3b4d 100644 --- a/services/galley/src/Galley/API/Action/Reset.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Action/Reset.hs @@ -15,15 +15,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Action.Reset (resetLocalMLSMainConversation) where +module Wire.ConversationSubsystem.Action.Reset (resetLocalMLSMainConversation) where import Control.Monad.Codensity hiding (reset) import Data.Aeson qualified as A import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Qualified -import Galley.API.Action.Kick -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -47,7 +45,8 @@ import Wire.API.Routes.Public.Galley.MLS import Wire.API.VersionInfo import Wire.BackendNotificationQueueAccess import Wire.ConversationStore -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action.Kick +import Wire.ConversationSubsystem.MLS.Util import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FederationAPIAccess @@ -65,7 +64,6 @@ resetLocalMLSMainConversation :: Member BackendNotificationQueueAccess r, Member (FederationAPIAccess FederatorClient) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member ProposalStore r, Member Random r, diff --git a/services/galley/src/Galley/API/Clients.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Clients.hs similarity index 89% rename from services/galley/src/Galley/API/Clients.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Clients.hs index 7aa4c2f12e9..52dae02033a 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Clients.hs @@ -15,9 +15,8 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Clients - ( getClients, - rmClient, +module Wire.ConversationSubsystem.Clients + ( rmClient, ) where @@ -25,8 +24,6 @@ import Data.Id import Data.Proxy import Data.Qualified import Data.Range -import Galley.API.MLS.Removal -import Galley.API.Query qualified as Query import Galley.Types.Clients (clientIds) import Galley.Types.Error import Imports @@ -45,7 +42,8 @@ import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.Routes.MultiTablePaging import Wire.BackendNotificationQueueAccess import Wire.ConversationStore (ConversationStore, getConversation) -import Wire.ConversationSubsystem qualified as ConvSubsystem +import Wire.ConversationSubsystem.MLS.Removal qualified as Removal +import Wire.ConversationSubsystem.Query qualified as Query import Wire.ExternalAccess (ExternalAccess) import Wire.NotificationSubsystem import Wire.ProposalStore (ProposalStore) @@ -54,12 +52,6 @@ import Wire.Sem.Random (Random) import Wire.UserClientIndexStore qualified as E import Wire.Util -getClients :: - (Member ConvSubsystem.ConversationSubsystem r) => - UserId -> - Sem r [ClientId] -getClients usr = clientIds usr <$> ConvSubsystem.internalGetClientIds [usr] - -- | Remove a client from conversations it is part of according to the -- conversation protocol (Proteus or MLS). In addition, remove the client from -- the "clients" table in Galley. @@ -67,7 +59,6 @@ rmClient :: forall r. ( Member E.UserClientIndexStore r, Member ConversationStore r, - Member ConvSubsystem.ConversationSubsystem r, Member (Error FederationError) r, Member ExternalAccess r, Member BackendNotificationQueueAccess r, @@ -107,7 +98,7 @@ rmClient usr cid = do mConv <- getConversation convId for_ mConv $ \conv -> do lconv <- qualifyLocal conv - removeClient lconv (tUntagged lusr) cid + Removal.removeClient lconv (tUntagged lusr) cid traverse_ removeRemoteMLSClients (rangedChunks remoteConvs) when (mtpHasMore page) $ do let nextState = mtpPagingState page diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs new file mode 100644 index 00000000000..983fd7f0af2 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Create.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 Wire.ConversationSubsystem.Create where + +import Data.Id +import Data.Qualified +import Data.Set qualified as Set +import Galley.Types.Error +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog qualified as P +import Wire.API.Conversation hiding (Member) +import Wire.API.Conversation qualified as Public +import Wire.API.Conversation.Config +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Event.Conversation +import Wire.API.Federation.Client (FederatorClient) +import Wire.API.Federation.Error +import Wire.API.FederationStatus (RemoteDomains (..)) +import Wire.API.Routes.Public.Galley.Conversation +import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) +import Wire.API.User +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) +import Wire.BrigAPIAccess +import Wire.ConversationStore (ConversationStore) +import Wire.ConversationSubsystem.CreateInternal +import Wire.ConversationSubsystem.Util +import Wire.FeaturesConfigSubsystem +import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.FederationSubsystem (FederationSubsystem, checkFederationStatus, enforceFederationProtocol) +import Wire.LegalHoldStore (LegalHoldStore) +import Wire.NotificationSubsystem as NS +import Wire.Sem.Now (Now) +import Wire.Sem.Random (Random) +import Wire.StoredConversation +import Wire.TeamCollaboratorsSubsystem +import Wire.TeamStore (TeamStore) +import Wire.TeamSubsystem (TeamSubsystem) + +---------------------------------------------------------------------------- +-- API Handlers + +createLegacyGroupConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS 'MLSNotEnabled) r, + Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member (ErrorS HistoryNotSupported) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member (Error UnreachableBackendsLegacy) r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r (ConversationResponse Public.OwnConversation) +createLegacyGroupConversation lusr conn newConv = mapError UnreachableBackendsLegacy $ do + dbConv <- createGroupConversationGeneric lusr conn newConv + maybe (throwIfNotOwnConversation lusr dbConv.id_) (pure . Created) $ ownConversationView lusr dbConv + +createGroupOwnConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS 'MLSNotEnabled) r, + Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member (ErrorS HistoryNotSupported) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member (Error InternalError) r, + Member FederationSubsystem r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversationResponseV9 +createGroupOwnConversation lusr conn newConv = do + let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) + enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) + dbConv <- createGroupConversationGeneric lusr conn newConv + maybe (throwIfNotOwnConversation lusr dbConv.id_) (pure . GroupConversationCreatedV9) $ + (CreateGroupOwnConversation <$> ownConversationView lusr dbConv <*> pure mempty) + +createGroupConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (ErrorS 'ConvAccessDenied) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotConnected) r, + Member (ErrorS 'MLSNotEnabled) r, + Member (ErrorS 'MLSNonEmptyMemberList) r, + Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'ChannelsNotEnabled) r, + Member (ErrorS 'NotAnMlsConversation) r, + Member (ErrorS HistoryNotSupported) r, + Member (Input ConversationSubsystemConfig) r, + Member LegalHoldStore r, + Member TeamStore r, + Member FeaturesConfigSubsystem r, + Member TeamCollaboratorsSubsystem r, + Member Random r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member FederationSubsystem r + ) => + Local UserId -> + Maybe ConnId -> + NewConv -> + Sem r CreateGroupConversation +createGroupConversation lusr conn newConv = do + let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) + enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains + checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) + dbConv <- createGroupConversationGeneric lusr conn newConv + pure $ + CreateGroupConversation + { conversation = conversationView (qualifyAs lusr ()) (Just lusr) dbConv, + failedToAdd = mempty + } + +createProteusSelfConversation :: + ( Member ConversationStore r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + Sem r (ConversationResponse Public.OwnConversation) +createProteusSelfConversation lusr = do + (c, created) <- createProteusSelfConversationLogic lusr + let mConv = + if created + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c + maybe (throwIfNotOwnConversation lusr c.id_) pure mConv + +createOne2OneConversation :: + ( Member BrigAPIAccess r, + Member ConversationStore r, + Member (Error FederationError) r, + Member (Error UnreachableBackends) r, + Member (Error InvalidInput) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NonBindingTeam) r, + Member (ErrorS 'NoBindingTeamMembers) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member (ErrorS 'NotConnected) r, + Member TeamStore r, + Member TeamCollaboratorsSubsystem r, + Member TeamSubsystem r, + Member Now r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member (FederationAPIAccess FederatorClient) r, + Member (Error InternalError) r, + Member P.TinyLog r + ) => + Local UserId -> + ConnId -> + NewOne2OneConv -> + Sem r (ConversationResponse Public.OwnConversation) +createOne2OneConversation lusr zcon j = do + (c, created) <- createOne2OneConversationLogic lusr zcon j + let mConv = + if created + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c + maybe (throwIfNotOwnConversation lusr c.id_) pure mConv + +---------------------------------------------------------------------------- +-- Helpers + +createConnectConversation :: + ( Member ConversationStore r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member (Error UnreachableBackends) r, + Member (ErrorS 'ConvNotFound) r, + Member (ErrorS 'InvalidOperation) r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member Now r, + Member (FederationAPIAccess FederatorClient) r, + Member P.TinyLog r + ) => + Local UserId -> + Maybe ConnId -> + Connect -> + Sem r (ConversationResponse Public.OwnConversation) +createConnectConversation lusr conn j = do + (c, created) <- createConnectConversationLogic lusr conn j + let mConv = + if created + then Created <$> ownConversationView lusr c + else Existed <$> ownConversationView lusr c + maybe (throwIfNotOwnConversation lusr c.id_) pure mConv diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs index f2aab2d82e3..e28425c9061 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/CreateInternal.hs @@ -80,7 +80,7 @@ import Wire.StoredConversation qualified as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore (TeamStore) import Wire.TeamStore qualified as TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, permissionCheck) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList (UserList (UserList), toUserList, ulAddLocal, ulAll, ulFromLocals, ulLocals, ulRemotes) diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs new file mode 100644 index 00000000000..ec74e2b5267 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Errors.hs @@ -0,0 +1,325 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 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 Wire.ConversationSubsystem.Errors + ( mapErrors, + ConversationSubsystemError (..), + ) +where + +import Data.Tagged +import Galley.Types.Error (InternalError, InvalidInput (..)) +import Imports +import Network.Wai.Utilities.JSONResponse (JSONResponse) +import Polysemy +import Polysemy.Error +import Wire.API.Conversation.Role qualified as ConvRole +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Federation.Error +import Wire.API.Routes.API (ServerEffect (interpretServerEffect)) + +data ConversationSubsystemError + = ConversationSubsystemErrorConvAccessDenied + | ConversationSubsystemErrorNotATeamMember + | ConversationSubsystemErrorperationDenied + | ConversationSubsystemErrorNotConnected + | ConversationSubsystemErrorMLSNotEnabled + | ConversationSubsystemErrorMLSNonEmptyMemberList + | ConversationSubsystemErrorMissingLegalholdConsent + | ConversationSubsystemErrorNonBindingTeam + | ConversationSubsystemErrorNoBindingTeamMembers + | ConversationSubsystemErrorTeamNotFound + | ConversationSubsystemErrorInvalidOperation + | ConversationSubsystemErrorConvNotFound + | ConversationSubsystemErrorChannelsNotEnabled + | ConversationSubsystemErrorNotAnMlsConversation + | ConversationSubsystemErrorMLSLegalholdIncompatible + | ConversationSubsystemErrorMLSIdentityMismatch + | ConversationSubsystemErrorMLSUnsupportedMessage + | ConversationSubsystemErrorMLSStaleMessage + | ConversationSubsystemErrorMLSProposalNotFound + | ConversationSubsystemErrorMLSCommitMissingReferences + | ConversationSubsystemErrorMLSSelfRemovalNotAllowed + | ConversationSubsystemErrorMLSClientSenderUserMismatch + | ConversationSubsystemErrorMLSSubConvClientNotInParent + | ConversationSubsystemErrorMLSInvalidLeafNodeSignature + | ConversationSubsystemErrorMLSClientMismatch + | ConversationSubsystemErrorMLSInvalidLeafNodeIndex + | ConversationSubsystemErrorMLSUnsupportedProposal + | ConversationSubsystemErrorGroupIdVersionNotSupported + | ConversationSubsystemErrorConvMemberNotFound + | ConversationSubsystemErrorHistoryNotSupported + | ConversationSubsystemErrorLSGroupConversationMismatch + | ConversationSubsystemErrorActionDeniedLeaveConversation + | ConversationSubsystemErrorActionDeniedRemoveConversationMember + | ConversationSubsystemErrorActionDeniedDeleteConversation + | ConversationSubsystemErrorBroadcastLimitExceeded + | ConversationSubsystemErrorMLSFederatedResetNotSupported + | ConversationSubsystemErrorMLSSubConvUnsupportedConvType + | ConversationSubsystemErrorTeamMemberNotFound + | ConversationSubsystemErrorAccessDenied + | ConversationSubsystemErrorMLSMissingGroupInfo + | ConversationSubsystemErrorCodeNotFound + | ConversationSubsystemErrorInvalidConversationPassword + | ConversationSubsystemErrorGuestLinksDisabled + | ConversationSubsystemErrorMLSFederatedOne2OneNotSupported + | ConversationSubsystemErrorTooManyMembers + | ConversationSubsystemErrorCreateConversationCodeConflict + | ConversationSubsystemErrorInvalidTarget + | ConversationSubsystemErrorMLSReadReceiptsNotAllowed + | ConversationSubsystemErrorInvalidTargetAccess + | ConversationSubsystemErrorConvInvalidProtocolTransition + | ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied + | ConversationSubsystemErrorActionDeniedAddConversationMember + | ConversationSubsystemErrorActionDeniedModifyOtherConversationMember + | ConversationSubsystemErrorActionDeniedModifyConversationName + | ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer + | ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode + | ConversationSubsystemErrorActionDeniedModifyConversationAccess + | ConversationSubsystemErrorActionDeniedModifyAddPermission + | ConversationSubsystemErrorFederationError FederationError + | ConversationSubsystemErrorUnreachableBackends UnreachableBackends + | ConversationSubsystemErrorInternalError InternalError + | ConversationSubsystemErrorInvalidInput InvalidInput + | ConversationSubsystemErrorMLSProtocolError MLSProtocolError + | ConversationSubsystemErrorGroupInfoDiagnostics GroupInfoDiagnostics + | ConversationSubsystemErrorMLSOutOfSyncError MLSOutOfSyncError + | ConversationSubsystemErrorNonFederatingBackends NonFederatingBackends + | ConversationSubsystemErrorUnreachableBackendsLegacy UnreachableBackendsLegacy + +instance APIError ConversationSubsystemError where + toResponse = + \case + ConversationSubsystemErrorConvAccessDenied -> toResponse $ Tagged @'ConvAccessDenied () + ConversationSubsystemErrorNotATeamMember -> toResponse $ Tagged @'NotATeamMember () + ConversationSubsystemErrorperationDenied -> toResponse $ Tagged @OperationDenied () + ConversationSubsystemErrorNotConnected -> toResponse $ Tagged @'NotConnected () + ConversationSubsystemErrorMLSNotEnabled -> toResponse $ Tagged @'MLSNotEnabled () + ConversationSubsystemErrorMLSNonEmptyMemberList -> toResponse $ Tagged @'MLSNonEmptyMemberList () + ConversationSubsystemErrorMissingLegalholdConsent -> toResponse $ Tagged @'MissingLegalholdConsent () + ConversationSubsystemErrorNonBindingTeam -> toResponse $ Tagged @'NonBindingTeam () + ConversationSubsystemErrorNoBindingTeamMembers -> toResponse $ Tagged @'NoBindingTeamMembers () + ConversationSubsystemErrorTeamNotFound -> toResponse $ Tagged @'TeamNotFound () + ConversationSubsystemErrorInvalidOperation -> toResponse $ Tagged @'InvalidOperation () + ConversationSubsystemErrorConvNotFound -> toResponse $ Tagged @'ConvNotFound () + ConversationSubsystemErrorChannelsNotEnabled -> toResponse $ Tagged @'ChannelsNotEnabled () + ConversationSubsystemErrorNotAnMlsConversation -> toResponse $ Tagged @'NotAnMlsConversation () + ConversationSubsystemErrorMLSLegalholdIncompatible -> toResponse $ Tagged @'MLSLegalholdIncompatible () + ConversationSubsystemErrorMLSIdentityMismatch -> toResponse $ Tagged @'MLSIdentityMismatch () + ConversationSubsystemErrorMLSUnsupportedMessage -> toResponse $ Tagged @'MLSUnsupportedMessage () + ConversationSubsystemErrorMLSStaleMessage -> toResponse $ Tagged @'MLSStaleMessage () + ConversationSubsystemErrorMLSProposalNotFound -> toResponse $ Tagged @'MLSProposalNotFound () + ConversationSubsystemErrorMLSCommitMissingReferences -> toResponse $ Tagged @'MLSCommitMissingReferences () + ConversationSubsystemErrorMLSSelfRemovalNotAllowed -> toResponse $ Tagged @'MLSSelfRemovalNotAllowed () + ConversationSubsystemErrorMLSClientSenderUserMismatch -> toResponse $ Tagged @'MLSClientSenderUserMismatch () + ConversationSubsystemErrorMLSSubConvClientNotInParent -> toResponse $ Tagged @'MLSSubConvClientNotInParent () + ConversationSubsystemErrorMLSInvalidLeafNodeSignature -> toResponse $ Tagged @'MLSInvalidLeafNodeSignature () + ConversationSubsystemErrorMLSClientMismatch -> toResponse $ Tagged @'MLSClientMismatch () + ConversationSubsystemErrorMLSInvalidLeafNodeIndex -> toResponse $ Tagged @'MLSInvalidLeafNodeIndex () + ConversationSubsystemErrorMLSUnsupportedProposal -> toResponse $ Tagged @'MLSUnsupportedProposal () + ConversationSubsystemErrorGroupIdVersionNotSupported -> toResponse $ Tagged @'GroupIdVersionNotSupported () + ConversationSubsystemErrorConvMemberNotFound -> toResponse $ Tagged @'ConvMemberNotFound () + ConversationSubsystemErrorHistoryNotSupported -> toResponse $ Tagged @'HistoryNotSupported () + ConversationSubsystemErrorLSGroupConversationMismatch -> toResponse $ Tagged @MLSGroupConversationMismatch () + ConversationSubsystemErrorActionDeniedLeaveConversation -> toResponse $ Tagged @('ActionDenied ConvRole.LeaveConversation) () + ConversationSubsystemErrorActionDeniedRemoveConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.RemoveConversationMember) () + ConversationSubsystemErrorActionDeniedDeleteConversation -> toResponse $ Tagged @('ActionDenied ConvRole.DeleteConversation) () + ConversationSubsystemErrorBroadcastLimitExceeded -> toResponse $ Tagged @'BroadcastLimitExceeded () + ConversationSubsystemErrorMLSFederatedResetNotSupported -> toResponse $ Tagged @'MLSFederatedResetNotSupported () + ConversationSubsystemErrorMLSSubConvUnsupportedConvType -> toResponse $ Tagged @'MLSSubConvUnsupportedConvType () + ConversationSubsystemErrorTeamMemberNotFound -> toResponse $ Tagged @'TeamMemberNotFound () + ConversationSubsystemErrorAccessDenied -> toResponse $ Tagged @'AccessDenied () + ConversationSubsystemErrorMLSMissingGroupInfo -> toResponse $ Tagged @'MLSMissingGroupInfo () + ConversationSubsystemErrorCodeNotFound -> toResponse $ Tagged @'CodeNotFound () + ConversationSubsystemErrorInvalidConversationPassword -> toResponse $ Tagged @'InvalidConversationPassword () + ConversationSubsystemErrorGuestLinksDisabled -> toResponse $ Tagged @'GuestLinksDisabled () + ConversationSubsystemErrorMLSFederatedOne2OneNotSupported -> toResponse $ Tagged @'MLSFederatedOne2OneNotSupported () + ConversationSubsystemErrorTooManyMembers -> toResponse $ Tagged @'TooManyMembers () + ConversationSubsystemErrorCreateConversationCodeConflict -> toResponse $ Tagged @'CreateConversationCodeConflict () + ConversationSubsystemErrorInvalidTarget -> toResponse $ Tagged @'InvalidTarget () + ConversationSubsystemErrorMLSReadReceiptsNotAllowed -> toResponse $ Tagged @'MLSReadReceiptsNotAllowed () + ConversationSubsystemErrorInvalidTargetAccess -> toResponse $ Tagged @'InvalidTargetAccess () + ConversationSubsystemErrorConvInvalidProtocolTransition -> toResponse $ Tagged @'ConvInvalidProtocolTransition () + ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied -> toResponse $ Tagged @'MLSMigrationCriteriaNotSatisfied () + ConversationSubsystemErrorActionDeniedAddConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.AddConversationMember) () + ConversationSubsystemErrorActionDeniedModifyOtherConversationMember -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyOtherConversationMember) () + ConversationSubsystemErrorActionDeniedModifyConversationName -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationName) () + ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationMessageTimer) () + ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationReceiptMode) () + ConversationSubsystemErrorActionDeniedModifyConversationAccess -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyConversationAccess) () + ConversationSubsystemErrorActionDeniedModifyAddPermission -> toResponse $ Tagged @('ActionDenied ConvRole.ModifyAddPermission) () + ConversationSubsystemErrorFederationError x -> toResponse x + ConversationSubsystemErrorUnreachableBackends x -> toResponse x + ConversationSubsystemErrorInternalError x -> toResponse x + ConversationSubsystemErrorInvalidInput x -> toResponse x + ConversationSubsystemErrorMLSProtocolError x -> toResponse $ (dynError @(MapError 'MLSProtocolErrorTag)) {eMessage = unTagged x} + ConversationSubsystemErrorGroupInfoDiagnostics x -> toResponse x + ConversationSubsystemErrorMLSOutOfSyncError x -> toResponse x + ConversationSubsystemErrorNonFederatingBackends x -> toResponse x + ConversationSubsystemErrorUnreachableBackendsLegacy x -> toResponse x + +type ConversationSubsystemErrorEffects = + '[ ErrorS 'ConvAccessDenied, + ErrorS 'NotATeamMember, + ErrorS OperationDenied, + ErrorS 'NotConnected, + ErrorS 'MLSNotEnabled, + ErrorS 'MLSNonEmptyMemberList, + ErrorS 'MissingLegalholdConsent, + ErrorS 'NonBindingTeam, + ErrorS 'NoBindingTeamMembers, + ErrorS 'TeamNotFound, + ErrorS 'InvalidOperation, + ErrorS 'ConvNotFound, + ErrorS 'ChannelsNotEnabled, + ErrorS 'NotAnMlsConversation, + ErrorS 'MLSLegalholdIncompatible, + ErrorS 'MLSIdentityMismatch, + ErrorS 'MLSUnsupportedMessage, + ErrorS 'MLSStaleMessage, + ErrorS 'MLSProposalNotFound, + ErrorS 'MLSCommitMissingReferences, + ErrorS 'MLSSelfRemovalNotAllowed, + ErrorS 'MLSClientSenderUserMismatch, + ErrorS 'MLSSubConvClientNotInParent, + ErrorS 'MLSInvalidLeafNodeSignature, + ErrorS 'MLSClientMismatch, + ErrorS 'MLSInvalidLeafNodeIndex, + ErrorS 'MLSUnsupportedProposal, + ErrorS 'GroupIdVersionNotSupported, + ErrorS 'ConvMemberNotFound, + ErrorS 'HistoryNotSupported, + ErrorS MLSGroupConversationMismatch, + ErrorS ('ActionDenied ConvRole.LeaveConversation), + ErrorS ('ActionDenied ConvRole.RemoveConversationMember), + ErrorS ('ActionDenied ConvRole.DeleteConversation), + ErrorS 'BroadcastLimitExceeded, + ErrorS 'MLSFederatedResetNotSupported, + ErrorS 'MLSSubConvUnsupportedConvType, + ErrorS 'TeamMemberNotFound, + ErrorS 'AccessDenied, + ErrorS 'MLSMissingGroupInfo, + ErrorS 'CodeNotFound, + ErrorS 'InvalidConversationPassword, + ErrorS 'GuestLinksDisabled, + ErrorS 'MLSFederatedOne2OneNotSupported, + ErrorS 'TooManyMembers, + ErrorS 'CreateConversationCodeConflict, + ErrorS 'InvalidTarget, + ErrorS 'MLSReadReceiptsNotAllowed, + ErrorS 'InvalidTargetAccess, + ErrorS 'ConvInvalidProtocolTransition, + ErrorS 'MLSMigrationCriteriaNotSatisfied, + ErrorS ('ActionDenied ConvRole.AddConversationMember), + ErrorS ('ActionDenied ConvRole.ModifyOtherConversationMember), + ErrorS ('ActionDenied ConvRole.ModifyConversationName), + ErrorS ('ActionDenied ConvRole.ModifyConversationMessageTimer), + ErrorS ('ActionDenied ConvRole.ModifyConversationReceiptMode), + ErrorS ('ActionDenied ConvRole.ModifyConversationAccess), + ErrorS ('ActionDenied ConvRole.ModifyAddPermission), + Error FederationError, + Error UnreachableBackends, + Error InternalError, + Error InvalidInput, + Error AuthenticationError, + Error MLSProtocolError, + Error GroupInfoDiagnostics, + Error MLSOutOfSyncError, + Error MLSProposalFailure, + Error NonFederatingBackends, + Error UnreachableBackendsLegacy + ] + +mapErrors :: + ( Member (Error ConversationSubsystemError) r, + Member (Error JSONResponse) r, + Member (Error DynError) r + ) => + InterpretersFor ConversationSubsystemErrorEffects r +mapErrors = + mapError (ConversationSubsystemErrorUnreachableBackendsLegacy) + . mapError (ConversationSubsystemErrorNonFederatingBackends) + . interpretServerEffect + . mapError (ConversationSubsystemErrorMLSOutOfSyncError) + . mapError (ConversationSubsystemErrorGroupInfoDiagnostics) + . mapError (ConversationSubsystemErrorMLSProtocolError) + . interpretServerEffect + . mapError (ConversationSubsystemErrorInvalidInput) + . mapError (ConversationSubsystemErrorInternalError) + . mapError (ConversationSubsystemErrorUnreachableBackends) + . mapError (ConversationSubsystemErrorFederationError) + . mapError (const ConversationSubsystemErrorActionDeniedModifyAddPermission) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationAccess) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationReceiptMode) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationMessageTimer) + . mapError (const ConversationSubsystemErrorActionDeniedModifyConversationName) + . mapError (const ConversationSubsystemErrorActionDeniedModifyOtherConversationMember) + . mapError (const ConversationSubsystemErrorActionDeniedAddConversationMember) + . mapError (const ConversationSubsystemErrorMLSMigrationCriteriaNotSatisfied) + . mapError (const ConversationSubsystemErrorConvInvalidProtocolTransition) + . mapError (const ConversationSubsystemErrorInvalidTargetAccess) + . mapError (const ConversationSubsystemErrorMLSReadReceiptsNotAllowed) + . mapError (const ConversationSubsystemErrorInvalidTarget) + . mapError (const ConversationSubsystemErrorCreateConversationCodeConflict) + . mapError (const ConversationSubsystemErrorTooManyMembers) + . mapError (const ConversationSubsystemErrorMLSFederatedOne2OneNotSupported) + . mapError (const ConversationSubsystemErrorGuestLinksDisabled) + . mapError (const ConversationSubsystemErrorInvalidConversationPassword) + . mapError (const ConversationSubsystemErrorCodeNotFound) + . mapError (const ConversationSubsystemErrorMLSMissingGroupInfo) + . mapError (const ConversationSubsystemErrorAccessDenied) + . mapError (const ConversationSubsystemErrorTeamMemberNotFound) + . mapError (const ConversationSubsystemErrorMLSSubConvUnsupportedConvType) + . mapError (const ConversationSubsystemErrorMLSFederatedResetNotSupported) + . mapError (const ConversationSubsystemErrorBroadcastLimitExceeded) + . mapError (const ConversationSubsystemErrorActionDeniedDeleteConversation) + . mapError (const ConversationSubsystemErrorActionDeniedRemoveConversationMember) + . mapError (const ConversationSubsystemErrorActionDeniedLeaveConversation) + . mapError (const ConversationSubsystemErrorLSGroupConversationMismatch) + . mapError (const ConversationSubsystemErrorHistoryNotSupported) + . mapError (const ConversationSubsystemErrorConvMemberNotFound) + . mapError (const ConversationSubsystemErrorGroupIdVersionNotSupported) + . mapError (const ConversationSubsystemErrorMLSUnsupportedProposal) + . mapError (const ConversationSubsystemErrorMLSInvalidLeafNodeIndex) + . mapError (const ConversationSubsystemErrorMLSClientMismatch) + . mapError (const ConversationSubsystemErrorMLSInvalidLeafNodeSignature) + . mapError (const ConversationSubsystemErrorMLSSubConvClientNotInParent) + . mapError (const ConversationSubsystemErrorMLSClientSenderUserMismatch) + . mapError (const ConversationSubsystemErrorMLSSelfRemovalNotAllowed) + . mapError (const ConversationSubsystemErrorMLSCommitMissingReferences) + . mapError (const ConversationSubsystemErrorMLSProposalNotFound) + . mapError (const ConversationSubsystemErrorMLSStaleMessage) + . mapError (const ConversationSubsystemErrorMLSUnsupportedMessage) + . mapError (const ConversationSubsystemErrorMLSIdentityMismatch) + . mapError (const ConversationSubsystemErrorMLSLegalholdIncompatible) + . mapError (const ConversationSubsystemErrorNotAnMlsConversation) + . mapError (const ConversationSubsystemErrorChannelsNotEnabled) + . mapError (const ConversationSubsystemErrorConvNotFound) + . mapError (const ConversationSubsystemErrorInvalidOperation) + . mapError (const ConversationSubsystemErrorTeamNotFound) + . mapError (const ConversationSubsystemErrorNoBindingTeamMembers) + . mapError (const ConversationSubsystemErrorNonBindingTeam) + . mapError (const ConversationSubsystemErrorMissingLegalholdConsent) + . mapError (const ConversationSubsystemErrorMLSNonEmptyMemberList) + . mapError (const ConversationSubsystemErrorMLSNotEnabled) + . mapError (const ConversationSubsystemErrorNotConnected) + . mapError (const ConversationSubsystemErrorperationDenied) + . mapError (const ConversationSubsystemErrorNotATeamMember) + . mapError (const ConversationSubsystemErrorConvAccessDenied) diff --git a/services/galley/src/Galley/API/Federation/Handlers.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs similarity index 92% rename from services/galley/src/Galley/API/Federation/Handlers.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs index b62d7ed3980..34a22f5dd4f 100644 --- a/services/galley/src/Galley/API/Federation/Handlers.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Federation.hs @@ -18,7 +18,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Federation.Handlers where +module Wire.ConversationSubsystem.Federation where import Control.Error hiding (note) import Control.Lens @@ -36,20 +36,6 @@ import Data.Set qualified as Set import Data.Singletons (SingI (..), demote, sing) import Data.Tagged import Data.Text.Lazy qualified as LT -import Galley.API.Action -import Galley.API.MLS -import Galley.API.MLS.Enabled -import Galley.API.MLS.GroupInfo -import Galley.API.MLS.GroupInfoCheck (GroupInfoCheckEnabled) -import Galley.API.MLS.Message -import Galley.API.MLS.One2One -import Galley.API.MLS.Removal -import Galley.API.MLS.SubConversation hiding (leaveSubConversation) -import Galley.API.MLS.Util -import Galley.API.MLS.Welcome -import Galley.API.Mapping -import Galley.API.Mapping qualified as Mapping -import Galley.API.Message import Galley.Types.Conversations.One2One import Galley.Types.Error import Imports @@ -83,12 +69,24 @@ import Wire.API.Message import Wire.API.Push.V2 (RecipientClients (..)) import Wire.API.Routes.Public.Galley.MLS import Wire.API.ServantProto +import Wire.API.Team.FeatureFlags (FeatureFlags) import Wire.API.User (BaseProtocolTag (..)) import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.CodeStore import Wire.ConversationStore qualified as E -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.Enabled +import Wire.ConversationSubsystem.MLS.GroupInfo +import Wire.ConversationSubsystem.MLS.GroupInfoCheck (GroupInfoCheckEnabled) +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.Message +import Wire.ConversationSubsystem.MLS.One2One +import Wire.ConversationSubsystem.MLS.Removal +import Wire.ConversationSubsystem.MLS.SubConversation hiding (leaveSubConversation) +import Wire.ConversationSubsystem.MLS.Util +import Wire.ConversationSubsystem.MLS.Welcome +import Wire.ConversationSubsystem.Message import Wire.ConversationSubsystem.Util import Wire.ExternalAccess (ExternalAccess) import Wire.FeaturesConfigSubsystem @@ -97,7 +95,6 @@ import Wire.FederationSubsystem (FederationSubsystem) import Wire.FireAndForget qualified as E import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem -import Wire.Options.Galley import Wire.ProposalStore (ProposalStore) import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now @@ -184,28 +181,18 @@ onConversationCreated domain rc = do pushConversationEvent Nothing () event (qualifyAs loc [qUnqualified . Public.memId $ mem]) [] pure EmptyResponse -getConversationsV1 :: - ( Member E.ConversationStore r, - Member (Input (Local ())) r - ) => - Domain -> - GetConversationsRequest -> - Sem r GetConversationsResponse -getConversationsV1 domain req = - getConversationsResponseFromV2 <$> Galley.API.Federation.Handlers.getConversations domain req - getConversations :: ( Member E.ConversationStore r, Member (Input (Local ())) r ) => Domain -> GetConversationsRequest -> - Sem r GetConversationsResponseV2 + Sem r GetRemoteConversationViewsResponse getConversations domain (GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid loc <- qualifyLocal () - GetConversationsResponseV2 - . mapMaybe (Mapping.conversationToRemote (tDomain loc) ruid) + GetRemoteConversationViewsResponse + . mapMaybe (conversationToRemote (tDomain loc) ruid) <$> E.getConversations cids -- | Update the local database with information on conversation members joining @@ -226,27 +213,12 @@ onConversationUpdated requestingDomain cu = do void $ updateLocalStateOfRemoteConv rcu Nothing pure EmptyResponse -onConversationUpdatedV0 :: - ( Member BrigAPIAccess r, - Member NotificationSubsystem r, - Member ExternalAccess r, - Member (Input (Local ())) r, - Member E.ConversationStore r, - Member P.TinyLog r - ) => - Domain -> - ConversationUpdateV0 -> - Sem r EmptyResponse -onConversationUpdatedV0 domain cu = - onConversationUpdated domain (conversationUpdateFromV0 cu) - -- as of now this will not generate the necessary events on the leaver's domain leaveConversation :: ( Member BackendNotificationQueueAccess r, Member E.ConversationStore r, Member (Error InternalError) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member Now r, @@ -365,13 +337,14 @@ onMessageSent domain rmUnqualified = do sendMessage :: ( Member BrigAPIAccess r, Member UserClientIndexStore r, + Member (Input IntraListing) r, + Member (Input FeatureFlags) r, Member E.ConversationStore r, Member (Error InvalidInput) r, Member (FederationAPIAccess FederatorClient) r, Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member (Input (Local ())) r, - Member (Input Opts) r, Member Now r, Member ExternalAccess r, Member TeamSubsystem r, @@ -394,7 +367,6 @@ onUserDeleted :: Member E.FireAndForget r, Member (Error FederationError) r, Member ExternalAccess r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member Now r, @@ -456,7 +428,6 @@ updateConversation :: Member (Error InvalidInput) r, Member ExternalAccess r, Member (FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member Now r, Member LegalHoldStore r, @@ -559,6 +530,16 @@ updateConversation origDomain updateRequest = do . runError @UnreachableBackends . fmap ConversationUpdateResponseUpdate +type MLSBundleStaticErrors = + Append + MLSMessageStaticErrors + '[ ErrorS 'MLSWelcomeMismatch, + ErrorS 'MLSIdentityMismatch, + ErrorS 'GroupIdVersionNotSupported, + ErrorS 'MLSInvalidLeafNodeSignature, + ErrorS 'MLSGroupConversationMismatch + ] + handleMLSMessageErrors :: ( r1 ~ Append @@ -599,8 +580,10 @@ sendMLSCommitBundle :: Member ExternalAccess r, Member (Error FederationError) r, Member (Error InternalError) r, + Member (ErrorS 'MLSClientMismatch) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r, + Member (ErrorS 'MLSUnsupportedProposal) r, Member (FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input (Maybe GroupInfoCheckEnabled)) r, @@ -635,25 +618,25 @@ sendMLSCommitBundle remoteDomain msr = handleMLSMessageErrors $ do when (qUnqualified qConvOrSub /= msr.convOrSubId) $ throwS @'MLSGroupConversationMismatch -- this cannot throw the error since we always pass the sender which is qualified to be remote - runInputConst (fromMaybe def msr.enableOutOfSyncCheck) $ - MLSMessageResponseUpdates - . fmap lcuUpdate - <$> mapToRuntimeError @MLSLegalholdIncompatible - (InternalErrorWithDescription "expected group conversation while handling policy conflicts") - ( postMLSCommitBundle - loc - -- Type application to prevent future changes from introducing errors. - -- It is only safe to assume that we can discard the error when the sender - -- is actually remote. - -- Since `tUntagged` works on local and remote, a future changed may - -- go unchecked without this. - (tUntagged @QRemote sender) - msr.senderClient - ctype - qConvOrSub - Nothing - ibundle - ) + MLSMessageResponseUpdates + . fmap lcuUpdate + <$> mapToRuntimeError @MLSLegalholdIncompatible + (InternalErrorWithDescription "expected group conversation while handling policy conflicts") + ( postMLSCommitBundle + loc + -- Type application to prevent future changes from introducing errors. + -- It is only safe to assume that we can discard the error when the sender + -- is actually remote. + -- Since `tUntagged` works on local and remote, a future changed may + -- go unchecked without this. + (tUntagged @QRemote sender) + msr.senderClient + ctype + qConvOrSub + Nothing + (fromMaybe def msr.enableOutOfSyncCheck) + ibundle + ) sendMLSMessage :: ( Member BackendNotificationQueueAccess r, @@ -663,6 +646,9 @@ sendMLSMessage :: Member (Error FederationError) r, Member (Error InternalError) r, Member (FederationAPIAccess FederatorClient) r, + Member (ErrorS 'MLSClientMismatch) r, + Member (ErrorS 'MLSInvalidLeafNodeIndex) r, + Member (ErrorS 'MLSUnsupportedProposal) r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, @@ -684,16 +670,16 @@ sendMLSMessage remoteDomain msr = handleMLSMessageErrors $ do msg <- noteS @'MLSUnsupportedMessage $ mkIncomingMessage raw (ctype, qConvOrSub) <- getConvFromGroupId msg.groupId when (qUnqualified qConvOrSub /= msr.convOrSubId) $ throwS @'MLSGroupConversationMismatch - runInputConst (fromMaybe def msr.enableOutOfSyncCheck) $ - MLSMessageResponseUpdates . map lcuUpdate - <$> postMLSMessage - loc - (tUntagged sender) - msr.senderClient - ctype - qConvOrSub - Nothing - msg + MLSMessageResponseUpdates . map lcuUpdate + <$> postMLSMessage + loc + (tUntagged sender) + msr.senderClient + ctype + qConvOrSub + Nothing + (fromMaybe def msr.enableOutOfSyncCheck) + msg getSubConversationForRemoteUser :: ( Member E.ConversationStore r, @@ -760,7 +746,7 @@ deleteSubConversationForRemoteUser domain DeleteSubConversationFedRequest {..} = lconv <- qualifyLocal dscreqConv resetLocalSubConversation qusr lconv dscreqSubConv dsc -getOne2OneConversationV1 :: +getLegacyOne2OneConversation :: ( Member (Input (Local ())) r, Member BrigAPIAccess r, Member (Error InvalidInput) r @@ -768,7 +754,7 @@ getOne2OneConversationV1 :: Domain -> GetOne2OneConversationRequest -> Sem r GetOne2OneConversationResponse -getOne2OneConversationV1 domain (GetOne2OneConversationRequest self other) = +getLegacyOne2OneConversation domain (GetOne2OneConversationRequest self other) = fmap (Imports.fromRight GetOne2OneConversationNotConnected) . runError @(Tagged 'NotConnected ()) $ do diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs index 68bf8c32a3d..2d36e8eeb7c 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Internal.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.ConversationSubsystem.Internal (internalGetClientIdsImpl) where +module Wire.ConversationSubsystem.Internal (internalGetClientIds) where import Data.Id import Galley.Types.Clients (Clients, fromUserClients) @@ -27,14 +27,14 @@ import Wire.BrigAPIAccess import Wire.UserClientIndexStore (UserClientIndexStore) import Wire.UserClientIndexStore qualified as UserClientIndexStore -internalGetClientIdsImpl :: +internalGetClientIds :: ( Member BrigAPIAccess r, Member UserClientIndexStore r, Member (Input ConversationSubsystemConfig) r ) => [UserId] -> Sem r Clients -internalGetClientIdsImpl users = do +internalGetClientIds users = do isInternal <- inputs (.listClientsUsingBrig) if isInternal then fromUserClients <$> lookupClients users diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs index 9a3d9270bc4..672372cf8bc 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs @@ -19,60 +19,80 @@ module Wire.ConversationSubsystem.Interpreter ( interpretConversationSubsystem, + GroupInfoCheckEnabled (..), + IntraListing (..), + ConversationSubsystemError (..), ) where -import Galley.Types.Error (InternalError, InvalidInput (..)) +import Data.Qualified import Imports +import Network.Wai.Utilities.JSONResponse (JSONResponse) import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.Resource (Resource) +import Polysemy.TinyLog (TinyLog) import Wire.API.Conversation.Config import Wire.API.Error -import Wire.API.Error.Galley import Wire.API.Federation.Client (FederatorClient) -import Wire.API.Federation.Error +import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureFlags) import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) import Wire.BrigAPIAccess +import Wire.CodeStore (CodeStore) import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as ConvStore -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem (ConversationSubsystem (..)) +import Wire.ConversationSubsystem.Action.Notify qualified as ActionNotify +import Wire.ConversationSubsystem.Clients as Clients +import Wire.ConversationSubsystem.Create qualified as Create import Wire.ConversationSubsystem.CreateInternal qualified as CreateInternal +import Wire.ConversationSubsystem.Errors +import Wire.ConversationSubsystem.Federation qualified as Federation import Wire.ConversationSubsystem.Fetch qualified as Fetch -import Wire.ConversationSubsystem.Internal qualified as Internal +import Wire.ConversationSubsystem.MLS qualified as MLS +import Wire.ConversationSubsystem.MLS.Enabled qualified as MLSEnabled +import Wire.ConversationSubsystem.MLS.GroupInfo qualified as MLSGroupInfo +import Wire.ConversationSubsystem.MLS.GroupInfoCheck (GroupInfoCheckEnabled (..)) +import Wire.ConversationSubsystem.MLS.Message qualified as MLSMessage +import Wire.ConversationSubsystem.MLS.Removal qualified as MLSRemoval +import Wire.ConversationSubsystem.MLS.Reset qualified as MLSReset +import Wire.ConversationSubsystem.MLS.SubConversation qualified as MLSSubConversation +import Wire.ConversationSubsystem.Message (IntraListing (..)) import Wire.ConversationSubsystem.Notify qualified as Notify +import Wire.ConversationSubsystem.One2One qualified as One2One +import Wire.ConversationSubsystem.Query qualified as Query +import Wire.ConversationSubsystem.Update qualified as Update import Wire.ExternalAccess (ExternalAccess) import Wire.FeaturesConfigSubsystem import Wire.FederationAPIAccess (FederationAPIAccess) +import Wire.FederationSubsystem (FederationSubsystem) +import Wire.FireAndForget (FireAndForget) +import Wire.HashPassword (HashPassword) import Wire.LegalHoldStore (LegalHoldStore) import Wire.NotificationSubsystem as NS +import Wire.Options.Galley (GuestLinkTTLSeconds) +import Wire.ProposalStore (ProposalStore) +import Wire.RateLimit (RateLimit) import Wire.Sem.Now (Now) import Wire.Sem.Random (Random) import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore (TeamStore) import Wire.TeamSubsystem (TeamSubsystem) import Wire.UserClientIndexStore (UserClientIndexStore) +import Wire.UserGroupStore (UserGroupStore) interpretConversationSubsystem :: - ( Member (Error FederationError) r, - Member (Error UnreachableBackends) r, - Member (Error InternalError) r, - Member (Error InvalidInput) r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS 'MLSNotEnabled) r, - Member (ErrorS 'MLSNonEmptyMemberList) r, - Member (ErrorS 'MissingLegalholdConsent) r, - Member (ErrorS 'NonBindingTeam) r, - Member (ErrorS 'NoBindingTeamMembers) r, - Member (ErrorS 'TeamNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'ChannelsNotEnabled) r, - Member (ErrorS 'NotAnMlsConversation) r, - Member (ErrorS HistoryNotSupported) r, + ( Member (Error ConversationSubsystemError) r, + Member (Error JSONResponse) r, + Member (Error DynError) r, + Member UserGroupStore r, + Member (Input (Maybe GuestLinkTTLSeconds)) r, + Member HashPassword r, + Member RateLimit r, + Member CodeStore r, + Member FireAndForget r, Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member ExternalAccess r, @@ -84,29 +104,235 @@ interpretConversationSubsystem :: Member TeamCollaboratorsSubsystem r, Member Random r, Member TeamSubsystem r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member (Input ConversationSubsystemConfig) r, + Member (Input (Local ())) r, + Member (Input (Maybe GroupInfoCheckEnabled)) r, + Member ProposalStore r, Member LegalHoldStore r, Member TeamStore r, - Member UserClientIndexStore r + Member ConvStore.MLSCommitLockStore r, + Member FederationSubsystem r, + Member Resource r, + Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member UserClientIndexStore r, + Member (Input FanoutLimit) r, + Member TinyLog r ) => - Sem (ConversationSubsystem : r) a -> - Sem r a + InterpreterFor ConversationSubsystem r interpretConversationSubsystem = interpret $ \case NotifyConversationAction tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData -> - Notify.notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData + mapErrors $ Notify.notifyConversationActionImpl tag quid notifyOrigDomain con lconv targetsLocal targetsRemote targetsBots action extraData + InternalCreateGroupConversation lusr conn newConv -> + mapErrors $ CreateInternal.createGroupConversationGeneric lusr conn newConv + CreateLegacyGroupConversation lusr conn newConv -> + mapErrors $ Create.createLegacyGroupConversation lusr conn newConv + CreateGroupOwnConversation lusr conn newConv -> + mapErrors $ Create.createGroupOwnConversation lusr conn newConv CreateGroupConversation lusr conn newConv -> - CreateInternal.createGroupConversationGeneric lusr conn newConv - CreateOne2OneConversation lusr conn newOne2One -> - CreateInternal.createOne2OneConversationLogic lusr conn newOne2One + mapErrors $ Create.createGroupConversation lusr conn newConv CreateProteusSelfConversation lusr -> - CreateInternal.createProteusSelfConversationLogic lusr + mapErrors $ Create.createProteusSelfConversation lusr + CreateOne2OneConversation lusr zcon j -> + mapErrors $ Create.createOne2OneConversation lusr zcon j CreateConnectConversation lusr conn j -> - CreateInternal.createConnectConversationLogic lusr conn j + mapErrors $ Create.createConnectConversation lusr conn j GetConversations convIds -> - ConvStore.getConversations convIds + mapErrors $ ConvStore.getConversations convIds GetConversationIds lusr maxIds pagingState -> - Fetch.getConversationIdsImpl lusr maxIds pagingState - InternalGetClientIds uids -> - Internal.internalGetClientIdsImpl uids + mapErrors $ Fetch.getConversationIdsImpl lusr maxIds pagingState InternalGetLocalMember cid uid -> - ConvStore.getLocalMember cid uid + mapErrors $ ConvStore.getLocalMember cid uid + PostMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle -> + mapErrors $ MLSMessage.postMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle + PostMLSCommitBundleFromLocalUser v lusr c conn bundle -> + mapErrors $ MLSMessage.postMLSCommitBundleFromLocalUser v lusr c conn bundle + PostMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg -> + mapErrors $ MLSMessage.postMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg + PostMLSMessageFromLocalUser v lusr c conn smsg -> + mapErrors $ MLSMessage.postMLSMessageFromLocalUser v lusr c conn smsg + IsMLSEnabled -> + mapErrors $ MLSEnabled.isMLSEnabled + GetConversationsInternal luser mids mstart msize -> + mapErrors $ Query.getConversationsInternal luser mids mstart msize + RemoveMemberFromLocalConv lcnv lusr con victim -> + mapErrors $ Update.removeMemberFromLocalConv lcnv lusr con victim + FederationOnConversationCreated domain rc -> + mapErrors $ Federation.onConversationCreated domain rc + FederationGetConversations domain req -> + mapErrors $ Federation.getConversations domain req + FederationLeaveConversation domain lc -> + mapErrors $ Federation.leaveConversation domain lc + FederationSendMessage domain msr -> + mapErrors $ Federation.sendMessage domain msr + FederationUpdateConversation domain uc -> + mapErrors $ Federation.updateConversation domain uc + FederationMlsSendWelcome domain req -> + mapErrors $ Federation.mlsSendWelcome domain req + FederationSendMLSMessage domain msr -> + mapErrors $ Federation.sendMLSMessage domain msr + FederationSendMLSCommitBundle domain msr -> + mapErrors $ Federation.sendMLSCommitBundle domain msr + FederationQueryGroupInfo domain req -> + mapErrors $ Federation.queryGroupInfo domain req + FederationUpdateTypingIndicator domain req -> + mapErrors $ Federation.updateTypingIndicator domain req + FederationOnTypingIndicatorUpdated domain td -> + mapErrors $ Federation.onTypingIndicatorUpdated domain td + FederationGetSubConversationForRemoteUser domain req -> + mapErrors $ Federation.getSubConversationForRemoteUser domain req + FederationDeleteSubConversationForRemoteUser domain req -> + mapErrors $ Federation.deleteSubConversationForRemoteUser domain req + FederationLeaveSubConversation domain lscr -> + mapErrors $ Federation.leaveSubConversation domain lscr + FederationGetLegacyOne2OneConversation domain req -> + mapErrors $ Federation.getLegacyOne2OneConversation domain req + FederationGetOne2OneConversation domain req -> + mapErrors $ Federation.getOne2OneConversation domain req + FederationOnClientRemoved domain req -> + mapErrors $ Federation.onClientRemoved domain req + FederationOnMessageSent domain rm -> + mapErrors $ Federation.onMessageSent domain rm + FederationOnMLSMessageSent domain rmm -> + mapErrors $ Federation.onMLSMessageSent domain rmm + FederationOnConversationUpdated domain cu -> + mapErrors $ Federation.onConversationUpdated domain cu + FederationOnUserDeleted domain udcn -> + mapErrors $ Federation.onUserDeleted domain udcn + PostOtrMessageUnqualified lusr con cnv ignore report msg -> + mapErrors $ Update.postOtrMessageUnqualified lusr con cnv ignore report msg + PostOtrBroadcastUnqualified lusr con ignore report msg -> + mapErrors $ Update.postOtrBroadcastUnqualified lusr con ignore report msg + PostProteusMessage lusr con cnv msg -> + mapErrors $ Update.postProteusMessage lusr con cnv msg + PostProteusBroadcast lusr con msg -> + mapErrors $ Update.postProteusBroadcast lusr con msg + DeleteLocalConversation lusr con lcnv -> + mapErrors $ Update.deleteLocalConversation lusr con lcnv + GetMLSPublicKeys fmt -> + mapErrors $ MLS.getMLSPublicKeys fmt + ResetMLSConversation lusr reset -> + mapErrors $ MLSReset.resetMLSConversation lusr reset + GetSubConversation lusr cnv sub -> + mapErrors $ MLSSubConversation.getSubConversation lusr cnv sub + GetBotConversation bid cnv -> + mapErrors $ Query.getBotConversation bid cnv + GetUnqualifiedOwnConversation lusr cnv -> + mapErrors $ Query.getUnqualifiedOwnConversation lusr cnv + GetOwnConversation lusr qcnv -> + mapErrors $ Query.getOwnConversation lusr qcnv + GetConversation lusr qcnv -> + mapErrors $ Query.getConversation lusr qcnv + InternalGetConversation cnv -> + mapErrors $ ConvStore.getConversation cnv + GetConversationRoles lusr cnv -> + mapErrors $ Query.getConversationRoles lusr cnv + GetGroupInfo lusr qcnv -> + mapErrors $ MLSGroupInfo.getGroupInfo lusr qcnv + ConversationIdsPageFromUnqualified lusr mstart msize -> + mapErrors $ Query.conversationIdsPageFromUnqualified lusr mstart msize + ConversationIdsPaginated listGlobalSelf lself req -> + mapErrors $ Query.conversationIdsPaginated listGlobalSelf lself req + ConversationIdsPageFrom lusr req -> + mapErrors $ Query.conversationIdsPageFrom lusr req + ListConversations luser req -> + mapErrors $ Query.listConversations luser req + GetConversationByReusableCode lusr key value -> + mapErrors $ Query.getConversationByReusableCode lusr key value + GetMLSSelfConversationWithError lusr -> + mapErrors $ Query.getMLSSelfConversationWithError lusr + GetMLSOne2OneOwnConversation lself qother -> + mapErrors $ Query.getMLSOne2OneOwnConversation lself qother + GetMLSOne2OneMLSConversation lself qother -> + mapErrors $ Query.getMLSOne2OneMLSConversation lself qother + GetMLSOne2OneConversation lself qother fmt -> + mapErrors $ Query.getMLSOne2OneConversation lself qother fmt + GetLocalSelf lusr cnv -> + mapErrors $ Query.getLocalSelf lusr cnv + GetSelfMember lusr qcnv -> + mapErrors $ Query.getSelfMember lusr qcnv + GetConversationGuestLinksStatus uid cid -> + mapErrors $ Query.getConversationGuestLinksStatus uid cid + GetCode mcode lusr cnv -> + mapErrors $ Update.getCode mcode lusr cnv + AddQualifiedMembersUnqualified lusr con cnv invite -> + mapErrors $ Update.addQualifiedMembersUnqualified lusr con cnv invite + AddMembers lusr zcon qcnv invite -> + mapErrors $ Update.addMembers lusr zcon qcnv invite + ReplaceMembers lusr zcon qcnv invite -> + mapErrors $ Update.replaceMembers lusr zcon qcnv invite + JoinConversationById lusr con cnv -> + mapErrors $ Update.joinConversationById lusr con cnv + JoinConversationByReusableCode lusr con req -> + mapErrors $ Update.joinConversationByReusableCode lusr con req + CheckReusableCode addr code -> + mapErrors $ Update.checkReusableCode addr code + AddCodeUnqualified mReq usr mbZHost mZcon cnv -> + mapErrors $ Update.addCodeUnqualified mReq usr mbZHost mZcon cnv + RmCodeUnqualified lusr con cnv -> + mapErrors $ Update.rmCodeUnqualified lusr con cnv + MemberTyping lusr con qcnv status -> + mapErrors $ Update.memberTyping lusr con qcnv status + RemoveMemberQualified lusr con qcnv quid -> + mapErrors $ Update.removeMemberQualified lusr con qcnv quid + UpdateOtherMember lusr con qcnv quid update -> + mapErrors $ Update.updateOtherMember lusr con qcnv quid update + UpdateConversationName lusr zcon qcnv rename -> + mapErrors $ Update.updateConversationName lusr zcon qcnv rename + UpdateConversationMessageTimer lusr zcon qcnv update -> + mapErrors $ Update.updateConversationMessageTimer lusr zcon qcnv update + UpdateConversationReceiptMode lusr zcon qcnv update -> + mapErrors $ Update.updateConversationReceiptMode lusr zcon qcnv update + UpdateConversationAccess lusr zcon qcnv update -> + mapErrors $ Update.updateConversationAccess lusr zcon qcnv update + UpdateConversationHistory lusr zcon qcnv update -> + mapErrors $ Update.updateConversationHistory lusr zcon qcnv update + UpdateSelfMember lusr zcon qcnv update -> + mapErrors $ Update.updateSelfMember lusr zcon qcnv update + UpdateConversationProtocolWithLocalUser lusr conn qcnv update -> + mapErrors $ Update.updateConversationProtocolWithLocalUser lusr conn qcnv update + UpdateChannelAddPermission lusr conn qcnv update -> + mapErrors $ Update.updateChannelAddPermission lusr conn qcnv update + PostBotMessageUnqualified bid cnv ignore report msg -> + mapErrors $ Update.postBotMessageUnqualified bid cnv ignore report msg + DeleteSubConversation lusr qcnv sub reset -> + mapErrors $ MLSSubConversation.deleteSubConversation lusr qcnv sub reset + GetSubConversationGroupInfo lusr qcnv sub -> + mapErrors $ MLSSubConversation.getSubConversationGroupInfo lusr qcnv sub + LeaveSubConversation lusr cli qcnv sub -> + mapErrors $ MLSSubConversation.leaveSubConversation lusr cli qcnv sub + SendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData -> + mapErrors $ ActionNotify.sendConversationActionNotifications tag quid notifyOrigDomain con lconv targets action extraData + GetPaginatedConversations lusr mids mstart msize -> + mapErrors $ Query.getConversations lusr mids mstart msize + SearchChannels lusr tid searchString sortOrder pageSize lastName lastId discoverable -> + mapErrors $ Query.searchChannels lusr tid searchString sortOrder pageSize lastName lastId discoverable + InternalGetMember qcnv usr -> + mapErrors $ Query.internalGetMember qcnv usr + GetConversationMeta cnv -> + mapErrors $ Query.getConversationMeta cnv + GetMLSOne2OneConversationInternal lself qother -> + mapErrors $ Query.getMLSOne2OneConversationInternal lself qother + IsMLSOne2OneEstablished lself qother -> + mapErrors $ Query.isMLSOne2OneEstablished lself qother + GetLocalConversationInternal cid -> + mapErrors $ Query.getLocalConversationInternal cid + RemoveClient uid cid -> + mapErrors $ Clients.rmClient uid cid + AddBot lusr zcon b -> + mapErrors $ Update.addBot lusr zcon b + RmBot lusr zcon b -> + mapErrors $ Update.rmBot lusr zcon b + UpdateCellsState cnv state -> + mapErrors $ Update.updateCellsState cnv state + RemoveUser lc includeMain qusr -> + mapErrors $ MLSRemoval.removeUser lc includeMain qusr + InternalUpsertOne2OneConversation req -> + mapErrors $ One2One.internalUpsertOne2OneConversation req + AcceptConv lusr conn cnv -> + mapErrors $ Update.acceptConv lusr conn cnv + BlockConv lusr qcnv -> + mapErrors $ Update.blockConv lusr qcnv + UnblockConv lusr conn qcnv -> + mapErrors $ Update.unblockConv lusr conn qcnv diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/LegalholdConflicts.hs similarity index 96% rename from services/galley/src/Galley/API/LegalHold/Conflicts.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/LegalholdConflicts.hs index 23adf1c22bb..0c45f09b645 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/LegalholdConflicts.hs @@ -17,7 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.LegalHold.Conflicts +module Wire.ConversationSubsystem.LegalholdConflicts ( guardQualifiedLegalholdPolicyConflicts, guardLegalholdPolicyConflicts, LegalholdConflicts (LegalholdConflicts), @@ -46,7 +46,6 @@ import Wire.API.Team.Member import Wire.API.User import Wire.API.User.Client as Client import Wire.BrigAPIAccess -import Wire.Options.Galley import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.Util @@ -59,7 +58,7 @@ guardQualifiedLegalholdPolicyConflicts :: ( Member BrigAPIAccess r, Member (Error LegalholdConflicts) r, Member (Input (Local ())) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member TeamSubsystem r ) => @@ -83,7 +82,7 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do guardLegalholdPolicyConflicts :: ( Member BrigAPIAccess r, Member (Error LegalholdConflicts) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member TeamSubsystem r ) => @@ -94,7 +93,7 @@ guardLegalholdPolicyConflicts LegalholdPlusFederationNotImplemented _otherClient guardLegalholdPolicyConflicts UnprotectedBot _otherClients = pure () guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do opts <- input - case view (settings . featureFlags . to npProject) opts of + case view (to npProject) opts of FeatureLegalHoldDisabledPermanently -> case FutureWork @'LegalholdPlusFederationNotImplemented () of FutureWork () -> -- FUTUREWORK: once we support federation and LH in combination, we still need to run @@ -107,7 +106,7 @@ guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do -- | Guard notification handling against legal-hold policy conflicts. -- Ensures that if any user has a LH client then no user can be missing consent. -- See also: "Brig.API.Connection.checkLegalholdPolicyConflict" --- and "Galley.API.Action.checkLHPolicyConflictsLocal". +-- and "Wire.ConversationSubsystem.Action.checkLHPolicyConflictsLocal". guardLegalholdPolicyConflictsUid :: forall r. ( Member BrigAPIAccess r, diff --git a/services/galley/src/Galley/API/MLS.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS.hs similarity index 88% rename from services/galley/src/Galley/API/MLS.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS.hs index 8da6d00620c..a8fedb7fd5d 100644 --- a/services/galley/src/Galley/API/MLS.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS.hs @@ -15,28 +15,22 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS - ( isMLSEnabled, - assertMLSEnabled, - postMLSMessage, - postMLSCommitBundleFromLocalUser, - postMLSMessageFromLocalUser, - getMLSPublicKeys, +module Wire.ConversationSubsystem.MLS + ( getMLSPublicKeys, formatPublicKeys, ) where import Data.Default -import Galley.API.MLS.Enabled -import Galley.API.MLS.Message import Galley.Types.Error import Imports import Polysemy import Polysemy.Error import Polysemy.Input -import Wire.API.Error +import Wire.API.Error (ErrorS) import Wire.API.Error.Galley import Wire.API.MLS.Keys +import Wire.ConversationSubsystem.MLS.Enabled (getMLSPrivateKeys) getMLSPublicKeys :: ( Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, diff --git a/services/galley/src/Galley/API/MLS/CheckClients.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/CheckClients.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/CheckClients.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/CheckClients.hs index 22ff3de4813..388d6a16422 100644 --- a/services/galley/src/Galley/API/MLS/CheckClients.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/CheckClients.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.CheckClients +module Wire.ConversationSubsystem.MLS.CheckClients ( checkClients, getClientData, ClientData (..), @@ -29,7 +29,6 @@ import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set import Data.Tuple.Extra -import Galley.API.MLS.Commit.Core import Imports import Polysemy import Polysemy.Error @@ -43,6 +42,7 @@ import Wire.API.MLS.LeafNode import Wire.API.User.Client import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Commit.Core import Wire.FederationAPIAccess (FederationAPIAccess) checkClients :: diff --git a/services/galley/src/Galley/API/MLS/Commit/Core.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Commit/Core.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs index 0318881e606..a51f0adcbcd 100644 --- a/services/galley/src/Galley/API/MLS/Commit/Core.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Commit.Core +module Wire.ConversationSubsystem.MLS.Commit.Core ( getCommitData, incrementEpoch, getClientInfo, @@ -31,9 +31,6 @@ where import Control.Comonad import Data.Id import Data.Qualified -import Galley.API.MLS.Conversation -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.Proposal import Galley.Types.Error import Imports import Polysemy @@ -66,6 +63,9 @@ import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.Proposal import Wire.ExternalAccess import Wire.FederationAPIAccess import Wire.LegalHoldStore (LegalHoldStore) diff --git a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs similarity index 96% rename from services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs index 9aec3fa0ea1..10fa4e6bd58 100644 --- a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Commit.ExternalCommit +module Wire.ConversationSubsystem.MLS.Commit.ExternalCommit ( ExternalCommitAction (..), getExternalCommitData, processExternalCommit, @@ -28,11 +28,6 @@ import Control.Monad.Codensity import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.Commit.Core -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.Proposal -import Galley.API.MLS.Removal -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -51,6 +46,11 @@ import Wire.API.MLS.ProposalTag import Wire.API.MLS.SubConversation import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Commit.Core +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.Proposal +import Wire.ConversationSubsystem.MLS.Removal +import Wire.ConversationSubsystem.MLS.Util data ExternalCommitAction = ExternalCommitAction { add :: LeafIndex, diff --git a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/InternalCommit.hs similarity index 96% rename from services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/InternalCommit.hs index 53c51cfa62a..8abc46eefb0 100644 --- a/services/galley/src/Galley/API/MLS/Commit/InternalCommit.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/InternalCommit.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Commit.InternalCommit (processInternalCommit) where +module Wire.ConversationSubsystem.MLS.Commit.InternalCommit (processInternalCommit) where import Control.Comonad import Control.Error.Util (hush) @@ -29,14 +29,6 @@ import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set import Data.Tuple.Extra -import Galley.API.Action -import Galley.API.MLS.CheckClients -import Galley.API.MLS.Commit.Core -import Galley.API.MLS.Conversation -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.One2One -import Galley.API.MLS.Proposal -import Galley.API.MLS.Util import Galley.Types.Error import Imports import Polysemy @@ -60,7 +52,14 @@ import Wire.API.MLS.SubConversation import Wire.API.Unreachable import Wire.ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.CheckClients +import Wire.ConversationSubsystem.MLS.Commit.Core +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.One2One +import Wire.ConversationSubsystem.MLS.Proposal +import Wire.ConversationSubsystem.MLS.Util import Wire.ConversationSubsystem.Util import Wire.FederationSubsystem import Wire.ProposalStore @@ -78,7 +77,6 @@ processInternalCommit :: Member (ErrorS 'MLSIdentityMismatch) r, Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'GroupIdVersionNotSupported) r, - Member ConversationSubsystem r, Member Resource r, Member Random r, Member (ErrorS MLSInvalidLeafNodeSignature) r, @@ -258,7 +256,6 @@ processInternalCommit senderIdentity con lConvOrSub ciphersuite ciphersuiteUpdat addMembers :: ( HasProposalActionEffects r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamSubsystem r ) => @@ -286,7 +283,6 @@ addMembers qusr con lConvOrSub users = case tUnqualified lConvOrSub of removeMembers :: ( HasProposalActionEffects r, - Member ConversationSubsystem r, Member TeamSubsystem r ) => Qualified UserId -> diff --git a/services/galley/src/Galley/API/MLS/Conversation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Conversation.hs similarity index 97% rename from services/galley/src/Galley/API/MLS/Conversation.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Conversation.hs index 0b979880816..b129d31c00e 100644 --- a/services/galley/src/Galley/API/MLS/Conversation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Conversation.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Conversation +module Wire.ConversationSubsystem.MLS.Conversation ( mkMLSConversation, newMLSConversation, mcConv, diff --git a/services/galley/src/Galley/API/MLS/Enabled.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Enabled.hs similarity index 95% rename from services/galley/src/Galley/API/MLS/Enabled.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Enabled.hs index 158d511e291..1910f5945fb 100644 --- a/services/galley/src/Galley/API/MLS/Enabled.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Enabled.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Enabled where +module Wire.ConversationSubsystem.MLS.Enabled where import Imports hiding (getFirst) import Polysemy @@ -25,7 +25,7 @@ import Wire.API.Error.Galley import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) isMLSEnabled :: (Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r) => Sem r Bool -isMLSEnabled = inputs (isJust) +isMLSEnabled = inputs isJust -- | Fail if MLS is not enabled. Only use this function at the beginning of an -- MLS endpoint, NOT in utility functions. diff --git a/services/galley/src/Galley/API/MLS/GroupInfo.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfo.hs similarity index 95% rename from services/galley/src/Galley/API/MLS/GroupInfo.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfo.hs index 69f667cab77..f52928307d2 100644 --- a/services/galley/src/Galley/API/MLS/GroupInfo.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfo.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.GroupInfo +module Wire.ConversationSubsystem.MLS.GroupInfo ( MLSGroupInfoStaticErrors, getGroupInfo, getGroupInfoFromLocalConv, @@ -26,8 +26,6 @@ where import Data.Id as Id import Data.Json.Util import Data.Qualified -import Galley.API.MLS.Enabled -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -42,6 +40,8 @@ import Wire.API.MLS.GroupInfo import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.MLS.SubConversation import Wire.ConversationStore qualified as E +import Wire.ConversationSubsystem.MLS.Enabled +import Wire.ConversationSubsystem.MLS.Util import Wire.ConversationSubsystem.Util import Wire.FederationAPIAccess qualified as E diff --git a/services/galley/src/Galley/API/MLS/GroupInfoCheck.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs similarity index 96% rename from services/galley/src/Galley/API/MLS/GroupInfoCheck.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs index 667a29dc3fe..d3bdabf3e3b 100644 --- a/services/galley/src/Galley/API/MLS/GroupInfoCheck.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/GroupInfoCheck.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.GroupInfoCheck +module Wire.ConversationSubsystem.MLS.GroupInfoCheck ( checkGroupState, GroupInfoMismatch (..), GroupInfoCheckEnabled (..), @@ -24,7 +24,6 @@ where import Data.Bifunctor import Data.Id -import Galley.API.Teams.Features.Get import Imports import Polysemy import Polysemy.Error @@ -43,7 +42,7 @@ import Wire.API.MLS.Serialisation import Wire.API.Team.Feature import Wire.ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) +import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getFeatureForTeam) data GroupInfoMismatch = GroupInfoMismatch {clients :: [(Int, ClientIdentity)]} diff --git a/services/galley/src/Galley/API/MLS/IncomingMessage.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/IncomingMessage.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/IncomingMessage.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/IncomingMessage.hs index 3a3fba62514..b88c90fbf7d 100644 --- a/services/galley/src/Galley/API/MLS/IncomingMessage.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/IncomingMessage.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.IncomingMessage +module Wire.ConversationSubsystem.MLS.IncomingMessage ( IncomingMessage (..), IncomingMessageContent (..), IncomingPublicMessageContent (..), diff --git a/services/galley/src/Galley/API/MLS/Keys.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Keys.hs similarity index 95% rename from services/galley/src/Galley/API/MLS/Keys.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Keys.hs index ddafc4e0e2d..b5a84d89f50 100644 --- a/services/galley/src/Galley/API/MLS/Keys.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Keys.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Keys (getMLSRemovalKey, SomeKeyPair (..)) where +module Wire.ConversationSubsystem.MLS.Keys (getMLSRemovalKey, SomeKeyPair (..)) where import Control.Error.Util (hush) import Data.Proxy diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs similarity index 89% rename from services/galley/src/Galley/API/MLS/Message.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs index 6425512192b..dde9267c7e8 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Message.hs @@ -15,17 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Message - ( IncomingBundle (..), - mkIncomingBundle, - IncomingMessage (..), - mkIncomingMessage, +module Wire.ConversationSubsystem.MLS.Message + ( MLSMessageStaticErrors, postMLSCommitBundle, postMLSCommitBundleFromLocalUser, postMLSMessageFromLocalUser, postMLSMessage, - MLSMessageStaticErrors, - MLSBundleStaticErrors, ) where @@ -40,27 +35,11 @@ import Data.Set qualified as Set import Data.Tagged import Data.Text.Lazy qualified as LT import Data.Tuple.Extra -import Galley.API.Action -import Galley.API.LegalHold.Get (getUserStatus) -import Galley.API.MLS.Commit.Core (getCommitData) -import Galley.API.MLS.Commit.ExternalCommit -import Galley.API.MLS.Commit.InternalCommit -import Galley.API.MLS.Conversation -import Galley.API.MLS.Enabled -import Galley.API.MLS.GroupInfoCheck -import Galley.API.MLS.IncomingMessage -import Galley.API.MLS.One2One -import Galley.API.MLS.OutOfSync -import Galley.API.MLS.Propagate -import Galley.API.MLS.Proposal -import Galley.API.MLS.Util -import Galley.API.MLS.Welcome (sendWelcomes) import Galley.Types.Error import Imports import Polysemy import Polysemy.Error import Polysemy.Input -import Polysemy.Internal import Polysemy.Output import Polysemy.Resource (Resource) import Polysemy.TinyLog @@ -88,7 +67,20 @@ import Wire.API.Team.LegalHold import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.Commit.Core (getCommitData) +import Wire.ConversationSubsystem.MLS.Commit.ExternalCommit +import Wire.ConversationSubsystem.MLS.Commit.InternalCommit +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.Enabled +import Wire.ConversationSubsystem.MLS.GroupInfoCheck +import Wire.ConversationSubsystem.MLS.IncomingMessage +import Wire.ConversationSubsystem.MLS.One2One +import Wire.ConversationSubsystem.MLS.OutOfSync +import Wire.ConversationSubsystem.MLS.Propagate +import Wire.ConversationSubsystem.MLS.Proposal +import Wire.ConversationSubsystem.MLS.Util +import Wire.ConversationSubsystem.MLS.Welcome (sendWelcomes) import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FeaturesConfigSubsystem @@ -99,7 +91,7 @@ import Wire.Sem.Now qualified as Now import Wire.Sem.Random (Random) import Wire.StoredConversation import Wire.TeamStore qualified as TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, getUserStatus) -- FUTUREWORK -- - Check that the capabilities of a leaf node in an add proposal contains all @@ -116,25 +108,12 @@ type MLSMessageStaticErrors = ErrorS 'MLSStaleMessage, ErrorS 'MLSProposalNotFound, ErrorS 'MissingLegalholdConsent, - ErrorS 'MLSInvalidLeafNodeIndex, - ErrorS 'MLSClientMismatch, - ErrorS 'MLSUnsupportedProposal, ErrorS 'MLSCommitMissingReferences, ErrorS 'MLSSelfRemovalNotAllowed, ErrorS 'MLSClientSenderUserMismatch, - ErrorS 'MLSGroupConversationMismatch, ErrorS 'MLSSubConvClientNotInParent ] -type MLSBundleStaticErrors = - Append - MLSMessageStaticErrors - '[ ErrorS 'MLSWelcomeMismatch, - ErrorS 'MLSIdentityMismatch, - ErrorS 'GroupIdVersionNotSupported, - ErrorS 'MLSInvalidLeafNodeSignature - ] - enableOutOfSyncCheckFromVersion :: Version -> EnableOutOfSyncCheck enableOutOfSyncCheckFromVersion v | v < V13 = DisableOutOfSyncCheck @@ -149,7 +128,6 @@ postMLSMessageFromLocalUser :: Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'MLSClientSenderUserMismatch) r, Member (ErrorS 'MLSCommitMissingReferences) r, - Member (ErrorS 'MLSGroupConversationMismatch) r, Member (ErrorS 'MLSNotEnabled) r, Member (ErrorS 'MLSProposalNotFound) r, Member (ErrorS 'MLSSelfRemovalNotAllowed) r, @@ -171,9 +149,8 @@ postMLSMessageFromLocalUser v lusr c conn smsg = do imsg <- noteS @'MLSUnsupportedMessage $ mkIncomingMessage smsg (ctype, cnvOrSub) <- getConvFromGroupId imsg.groupId events <- - runInputConst (enableOutOfSyncCheckFromVersion v) $ - map lcuEvent - <$> postMLSMessage lusr (tUntagged lusr) c ctype cnvOrSub (Just conn) imsg + map lcuEvent + <$> postMLSMessage lusr (tUntagged lusr) c ctype cnvOrSub (Just conn) (enableOutOfSyncCheckFromVersion v) imsg t <- toUTCTimeMillis <$> Now.get pure $ MLSMessageSendingStatus events t @@ -183,13 +160,12 @@ postMLSCommitBundle :: Member (Error GroupInfoDiagnostics) r, Member (Error MLSOutOfSyncError) r, Member (ErrorS GroupIdVersionNotSupported) r, - Member (Input EnableOutOfSyncCheck) r, Member (Input (Maybe GroupInfoCheckEnabled)) r, Member Random r, Member Resource r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, + Member (ErrorS 'MLSInvalidLeafNodeSignature) r, HasProposalEffects r, - Member ConversationSubsystem r, Member MLSCommitLockStore r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -202,14 +178,16 @@ postMLSCommitBundle :: ConvType -> Qualified ConvOrSubConvId -> Maybe ConnId -> + EnableOutOfSyncCheck -> IncomingBundle -> Sem r [LocalConversationUpdate] -postMLSCommitBundle loc qusr c ctype qConvOrSub conn bundle = - foldQualified - loc - (postMLSCommitBundleToLocalConv qusr c conn bundle ctype) - (postMLSCommitBundleToRemoteConv loc qusr c conn bundle ctype) - qConvOrSub +postMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle = + runInputConst oosCheck $ + foldQualified + loc + (postMLSCommitBundleToLocalConv qusr c conn bundle ctype) + (postMLSCommitBundleToRemoteConv loc qusr c conn bundle ctype) + qConvOrSub postMLSCommitBundleFromLocalUser :: ( Member (ErrorS MLSLegalholdIncompatible) r, @@ -221,9 +199,9 @@ postMLSCommitBundleFromLocalUser :: Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, Member Random r, Member Resource r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, + Member (ErrorS 'MLSInvalidLeafNodeSignature) r, HasProposalEffects r, - Member ConversationSubsystem r, Member MLSCommitLockStore r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -242,9 +220,8 @@ postMLSCommitBundleFromLocalUser v lusr c conn bundle = do (ctype, qConvOrSub) <- getConvFromGroupId ibundle.groupId events <- - runInputConst (enableOutOfSyncCheckFromVersion v) $ - map lcuEvent - <$> postMLSCommitBundle lusr (tUntagged lusr) c ctype qConvOrSub (Just conn) ibundle + map lcuEvent + <$> postMLSCommitBundle lusr (tUntagged lusr) c ctype qConvOrSub (Just conn) (enableOutOfSyncCheckFromVersion v) ibundle t <- toUTCTimeMillis <$> Now.get pure $ MLSMessageSendingStatus events t @@ -258,9 +235,9 @@ postMLSCommitBundleToLocalConv :: Member (Input (Maybe GroupInfoCheckEnabled)) r, Member Random r, Member Resource r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, + Member (ErrorS 'MLSInvalidLeafNodeSignature) r, HasProposalEffects r, - Member ConversationSubsystem r, Member MLSCommitLockStore r, Member FederationSubsystem r, Member TeamSubsystem r, @@ -320,7 +297,7 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do senderIdentity <- getSenderIdentity qusr c bundle.sender lConvOrSub - (events, newClients) <- handleGroupInfoMismatch lConvOrSubId bundle $ lowerCodensity $ do + (events, newClients, lConvOrSub') <- handleGroupInfoMismatch lConvOrSubId bundle $ lowerCodensity $ do (events, newClients) <- case senderIdentity.index of Just _ -> do -- extract added/removed clients from bundle @@ -364,11 +341,16 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do action bundle.commit.value.path pure ([], mempty) - lift $ do + lConvOrSub' <- lift $ do updateOutOfSyncFlag senderIdentity.client lConvOrSub storeGroupInfo convOrSub.id (GroupInfoData bundle.groupInfo.raw) - propagateMessage qusr (Just c) lConvOrSub conn bundle.rawMessage convOrSub.members - pure (events, newClients) + -- reload conversation from db to make sure we have an up-to-date list of members + lConvOrSub' <- fetchConvOrSub qusr bundle.groupId ctype lConvOrSubId + let convOrSub' = tUnqualified lConvOrSub' + mems = cmIntersect (void convOrSub.members) convOrSub'.members + propagateMessage qusr (Just c) lConvOrSub conn bundle.rawMessage mems + pure lConvOrSub' + pure (events, newClients, lConvOrSub') -- send welcome messages for_ bundle.welcome $ \welcome -> @@ -376,11 +358,8 @@ postMLSCommitBundleToLocalConv qusr c conn bundle ctype lConvOrSubId = do -- send application message for_ bundle.appMessage $ \msg -> do - -- reload conversation from db to make sure we have an up-to-date list of members - lConvOrSub' <- fetchConvOrSub qusr bundle.groupId ctype lConvOrSubId let convOrSub' = tUnqualified lConvOrSub' - propagateMessage qusr (Just c) lConvOrSub' conn msg.rawMessage $ - void convOrSub'.members + propagateMessage qusr (Just c) lConvOrSub' conn msg.rawMessage convOrSub'.members pure events @@ -405,7 +384,7 @@ handleGroupInfoMismatch lConvId bundle m = postMLSCommitBundleToRemoteConv :: ( Member BrigAPIAccess r, - Members MLSBundleStaticErrors r, + Members MLSMessageStaticErrors r, Member (Error FederationError) r, Member (Error MLSProtocolError) r, Member (Error MLSProposalFailure) r, @@ -448,7 +427,7 @@ postMLSCommitBundleToRemoteConv loc qusr c con bundle ctype rConvOrSubId = do enableOutOfSyncCheck } case resp of - MLSMessageResponseError e -> rethrowErrors @MLSBundleStaticErrors e + MLSMessageResponseError e -> rethrowErrors @MLSMessageStaticErrors e MLSMessageResponseProtocolError e -> throw (mlsProtocolError e) MLSMessageResponseProposalFailure e -> throw (MLSProposalFailure e) MLSMessageResponseUnreachableBackends ds -> throw (UnreachableBackends (toList ds)) @@ -470,7 +449,6 @@ postMLSMessage :: Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'MLSClientSenderUserMismatch) r, Member (ErrorS 'MLSCommitMissingReferences) r, - Member (ErrorS 'MLSGroupConversationMismatch) r, Member (ErrorS 'MLSProposalNotFound) r, Member (ErrorS 'MLSSelfRemovalNotAllowed) r, Member (ErrorS 'MLSStaleMessage) r, @@ -478,8 +456,7 @@ postMLSMessage :: Member (ErrorS 'MLSSubConvClientNotInParent) r, Member (ErrorS MLSInvalidLeafNodeSignature) r, Member (Error MLSOutOfSyncError) r, - Member (Error GroupInfoDiagnostics) r, - Member (Input EnableOutOfSyncCheck) r + Member (Error GroupInfoDiagnostics) r ) => Local x -> Qualified UserId -> @@ -487,14 +464,16 @@ postMLSMessage :: ConvType -> Qualified ConvOrSubConvId -> Maybe ConnId -> + EnableOutOfSyncCheck -> IncomingMessage -> Sem r [LocalConversationUpdate] -postMLSMessage loc qusr c ctype qconvOrSub con msg = do - foldQualified - loc - (postMLSMessageToLocalConv qusr c con msg ctype) - (postMLSMessageToRemoteConv loc qusr c con msg) - qconvOrSub +postMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg = do + runInputConst oosCheck $ + foldQualified + loc + (postMLSMessageToLocalConv qusr c con msg ctype) + (postMLSMessageToRemoteConv loc qusr c con msg) + qconvOrSub getSenderIdentity :: ( Member (ErrorS 'MLSClientSenderUserMismatch) r, diff --git a/services/galley/src/Galley/API/MLS/Migration.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Migration.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Migration.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Migration.hs index 1db5ce29576..0922d1588f2 100644 --- a/services/galley/src/Galley/API/MLS/Migration.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Migration.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Migration where +module Wire.ConversationSubsystem.MLS.Migration where import Data.Qualified import Data.Set qualified as Set diff --git a/services/galley/src/Galley/API/MLS/One2One.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs similarity index 97% rename from services/galley/src/Galley/API/MLS/One2One.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs index 3f8550b4b94..2db148d7aae 100644 --- a/services/galley/src/Galley/API/MLS/One2One.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/One2One.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.One2One +module Wire.ConversationSubsystem.MLS.One2One ( localMLSOne2OneConversation, localMLSOne2OneConversationAsRemote, localMLSOne2OneConversationMetadata, @@ -65,7 +65,7 @@ localMLSOne2OneConversation lself (tUntagged -> convId) = -- conversation to be returned to a remote backend. localMLSOne2OneConversationAsRemote :: Local ConvId -> - RemoteConversationV2 + RemoteConversationView localMLSOne2OneConversationAsRemote lcnv = let members = RemoteConvMembers @@ -73,7 +73,7 @@ localMLSOne2OneConversationAsRemote lcnv = others = [] } (metadata, mlsData) = localMLSOne2OneConversationMetadata (tUntagged lcnv) - in RemoteConversationV2 + in RemoteConversationView { id = tUnqualified lcnv, metadata = metadata, members = members, diff --git a/services/galley/src/Galley/API/MLS/OutOfSync.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/OutOfSync.hs similarity index 97% rename from services/galley/src/Galley/API/MLS/OutOfSync.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/OutOfSync.hs index 03556f89ade..b9aaceb5bbd 100644 --- a/services/galley/src/Galley/API/MLS/OutOfSync.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/OutOfSync.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.OutOfSync +module Wire.ConversationSubsystem.MLS.OutOfSync ( checkConversationOutOfSync, updateOutOfSyncFlag, ) @@ -25,7 +25,6 @@ import Data.Id import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.CheckClients import Imports import Polysemy import Polysemy.Error @@ -39,6 +38,7 @@ import Wire.API.MLS.SubConversation import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.CheckClients import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.StoredConversation diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Propagate.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Propagate.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Propagate.hs index 8e71e7463e3..8445a089f4b 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Propagate.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Propagate where +module Wire.ConversationSubsystem.MLS.Propagate where import Control.Comonad import Data.Id diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs similarity index 99% rename from services/galley/src/Galley/API/MLS/Proposal.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs index fdff658e2ad..712fd32aee4 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Proposal +module Wire.ConversationSubsystem.MLS.Proposal ( -- * Proposal processing derefOrCheckProposal, checkProposal, @@ -38,7 +38,6 @@ import Data.Id import Data.Map qualified as Map import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.IncomingMessage import Galley.Types.Error import Imports import Polysemy @@ -67,6 +66,7 @@ import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.IncomingMessage import Wire.ExternalAccess import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.LegalHoldStore (LegalHoldStore) diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Removal.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Removal.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Removal.hs index fbdc427bbcf..3daa9b661ed 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Removal.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Removal +module Wire.ConversationSubsystem.MLS.Removal ( createAndSendRemoveProposals, removeExtraneousClients, removeClient, @@ -31,9 +31,6 @@ import Data.Map qualified as Map import Data.Proxy import Data.Qualified import Data.Set qualified as Set -import Galley.API.MLS.Conversation -import Galley.API.MLS.Keys -import Galley.API.MLS.Propagate import Imports import Polysemy import Polysemy.Error @@ -54,6 +51,9 @@ import Wire.API.MLS.SubConversation import Wire.BackendNotificationQueueAccess import Wire.ConversationStore import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem.MLS.Conversation +import Wire.ConversationSubsystem.MLS.Keys +import Wire.ConversationSubsystem.MLS.Propagate import Wire.ExternalAccess import Wire.NotificationSubsystem import Wire.ProposalStore diff --git a/services/galley/src/Galley/API/MLS/Reset.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Reset.hs similarity index 93% rename from services/galley/src/Galley/API/MLS/Reset.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Reset.hs index 18955e75c1e..0f88ab79699 100644 --- a/services/galley/src/Galley/API/MLS/Reset.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Reset.hs @@ -15,14 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Reset (resetMLSConversation) where +module Wire.ConversationSubsystem.MLS.Reset (resetMLSConversation) where import Data.Id import Data.Qualified -import Galley.API.Action -import Galley.API.MLS.Enabled -import Galley.API.MLS.Util -import Galley.API.Update import Galley.Types.Error import Imports import Polysemy @@ -42,7 +38,10 @@ import Wire.API.Routes.Public.Galley.MLS import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ConversationStore -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.MLS.Enabled (assertMLSEnabled) +import Wire.ConversationSubsystem.MLS.Util +import Wire.ConversationSubsystem.Update import Wire.ExternalAccess (ExternalAccess) import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.NotificationSubsystem @@ -52,10 +51,8 @@ import Wire.Sem.Random (Random) import Wire.TeamSubsystem (TeamSubsystem) resetMLSConversation :: - ( Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, - Member Now r, + ( Member Now r, Member (Input (Local ())) r, - Member (ErrorS MLSNotEnabled) r, Member (ErrorS MLSStaleMessage) r, Member (ErrorS (ActionDenied LeaveConversation)) r, Member (ErrorS ConvNotFound) r, @@ -63,6 +60,8 @@ resetMLSConversation :: Member (Error InternalError) r, Member (ErrorS InvalidOperation) r, Member (ErrorS MLSFederatedResetNotSupported) r, + Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member (ErrorS MLSNotEnabled) r, Member BackendNotificationQueueAccess r, Member ConversationStore r, Member (FederationAPIAccess FederatorClient) r, @@ -70,7 +69,6 @@ resetMLSConversation :: Member (Error FederationError) r, Member BrigAPIAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member ProposalStore r, Member Random r, Member Resource r, diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/SubConversation.hs similarity index 94% rename from services/galley/src/Galley/API/MLS/SubConversation.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/SubConversation.hs index a404476e377..14574b31c26 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/SubConversation.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.SubConversation +module Wire.ConversationSubsystem.MLS.SubConversation ( getSubConversation, getLocalSubConversation, deleteSubConversation, @@ -35,11 +35,6 @@ import Control.Arrow import Control.Monad.Codensity hiding (reset) import Data.Id import Data.Qualified -import Galley.API.MLS -import Galley.API.MLS.Conversation -import Galley.API.MLS.GroupInfo -import Galley.API.MLS.Removal -import Galley.API.MLS.Util import Imports import Polysemy import Polysemy.Error @@ -65,6 +60,11 @@ import Wire.API.Routes.Public.Galley.MLS import Wire.BackendNotificationQueueAccess import Wire.ConversationStore qualified as Conversation import Wire.ConversationStore.MLS.Types as Conversation +import Wire.ConversationSubsystem.MLS.Conversation (mkMLSConversation) +import Wire.ConversationSubsystem.MLS.Enabled (assertMLSEnabled) +import Wire.ConversationSubsystem.MLS.GroupInfo (getGroupInfoFromRemoteConv) +import Wire.ConversationSubsystem.MLS.Removal (createAndSendRemoveProposals) +import Wire.ConversationSubsystem.MLS.Util (getLocalConvForUser, withCommitLock) import Wire.ConversationSubsystem.Util import Wire.ExternalAccess (ExternalAccess) import Wire.FederationAPIAccess @@ -169,10 +169,12 @@ getSubConversationGroupInfo :: '[ Conversation.ConversationStore, Error FederationError, FederationAPIAccess FederatorClient, - Input (Maybe (MLSKeysByPurpose MLSPrivateKeys)) + Input (Maybe (MLSKeysByPurpose MLSPrivateKeys)), + ErrorS 'MLSNotEnabled, + ErrorS 'ConvNotFound, + ErrorS 'MLSMissingGroupInfo ] - r, - Members MLSGroupInfoStaticErrors r + r ) => Local UserId -> Qualified ConvId -> @@ -187,8 +189,10 @@ getSubConversationGroupInfo lusr qcnvId subconv = do qcnvId getSubConversationGroupInfoFromLocalConv :: - (Member Conversation.ConversationStore r) => - (Members MLSGroupInfoStaticErrors r) => + ( Member Conversation.ConversationStore r, + Member (ErrorS 'ConvNotFound) r, + Member (ErrorS 'MLSMissingGroupInfo) r + ) => Qualified UserId -> SubConvId -> Local ConvId -> diff --git a/services/galley/src/Galley/API/MLS/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Util.hs similarity index 98% rename from services/galley/src/Galley/API/MLS/Util.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Util.hs index 742f820b1bb..814603f64ff 100644 --- a/services/galley/src/Galley/API/MLS/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Util.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Util where +module Wire.ConversationSubsystem.MLS.Util where import Control.Comonad import Control.Monad.Codensity diff --git a/services/galley/src/Galley/API/MLS/Welcome.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Welcome.hs similarity index 99% rename from services/galley/src/Galley/API/MLS/Welcome.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Welcome.hs index 44484dda0a5..b16bb87e1af 100644 --- a/services/galley/src/Galley/API/MLS/Welcome.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Welcome.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS.Welcome +module Wire.ConversationSubsystem.MLS.Welcome ( sendWelcomes, sendLocalWelcomes, ) diff --git a/services/galley/src/Galley/API/Message.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Message.hs similarity index 97% rename from services/galley/src/Galley/API/Message.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Message.hs index ff384a45fe9..214bdcf6ed8 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Message.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Message +module Wire.ConversationSubsystem.Message ( UserType (..), sendLocalMessages, postQualifiedOtrMessage, @@ -24,6 +24,7 @@ module Galley.API.Message legacyClientMismatchStrategy, Unqualify (..), MessageMetadata (..), + IntraListing (..), -- * Only exported for tests checkMessageClients, @@ -48,7 +49,6 @@ import Data.Range import Data.Set qualified as Set import Data.Set.Lens import Data.Time.Clock (UTCTime) -import Galley.API.LegalHold.Conflicts import Galley.Types.Clients qualified as Clients import Imports hiding (forkIO) import Network.AMQP qualified as Q @@ -57,6 +57,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger.Class qualified as Log +import Wire.API.Conversation.Config (ConversationSubsystemConfig) import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Error.Galley @@ -68,7 +69,7 @@ import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error import Wire.API.Message import Wire.API.Routes.Public.Galley.Messaging -import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureFlags) import Wire.API.Team.LegalHold import Wire.API.Team.Member import Wire.API.User.Client @@ -76,22 +77,26 @@ import Wire.API.UserMap (UserMap (..)) import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess import Wire.ConversationStore -import Wire.ConversationSubsystem qualified as ConvSubsystem +import Wire.ConversationSubsystem.Internal qualified as ConvSubsystem +import Wire.ConversationSubsystem.LegalholdConflicts import Wire.ConversationSubsystem.Util import Wire.ExternalAccess import Wire.FederationAPIAccess import Wire.NotificationSubsystem (BotMap, NotificationSubsystem, newMessagePush, runMessagePush) -import Wire.Options.Galley import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now import Wire.StoredConversation import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, getTeamMembersForFanout) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserClientIndexStore data UserType = User | Bot -- FUTUREWORK: there is UserType in Wire.API.User now, should we use that? (there is also UserType variant for searcho/contacts, but there is a good reason for that one.) +newtype IntraListing + = IntraListing {unIntraListing :: Bool} + deriving stock (Eq, Ord, Show) + userToProtectee :: UserType -> UserId -> LegalholdProtectee userToProtectee User user = ProtectedUser user userToProtectee Bot _ = UnprotectedBot @@ -259,14 +264,15 @@ postBroadcast :: Member (ErrorS 'NonBindingTeam) r, Member (ErrorS 'BroadcastLimitExceeded) r, Member ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member Now r, Member TeamStore r, Member P.TinyLog r, Member NotificationSubsystem r, Member (Input FanoutLimit) r, + Member (Input ConversationSubsystemConfig) r, Member TeamSubsystem r, - Member ConvSubsystem.ConversationSubsystem r + Member UserClientIndexStore r ) => Local UserId -> Maybe ConnId -> @@ -354,7 +360,6 @@ postBroadcast lusr con msg = runError $ do maybeFetchAllMembersInTeam :: ( Member (ErrorS 'BroadcastLimitExceeded) r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> @@ -372,7 +377,8 @@ postQualifiedOtrMessage :: Member (FederationAPIAccess FederatorClient) r, Member BackendNotificationQueueAccess r, Member ExternalAccess r, - Member (Input Opts) r, + Member (Input IntraListing) r, + Member (Input FeatureFlags) r, Member Now r, Member P.TinyLog r, Member NotificationSubsystem r, @@ -411,7 +417,7 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = Set.fromList $ map (tUntagged . qualifyAs lcnv) localMemberIds <> map (tUntagged . (.id_)) conv.remoteMembers - isInternal <- view (settings . intraListing) <$> input + IntraListing isInternal <- input -- check if the sender is part of the conversation unless (Set.member sender members) $ @@ -533,7 +539,7 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = guardQualifiedLegalholdPolicyConflictsWrapper :: ( Member BrigAPIAccess r, Member (Error (MessageNotSent MessageSendingStatus)) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member TeamSubsystem r ) => diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs index afe039381b8..a73b430d57b 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/One2One.hs @@ -19,7 +19,7 @@ module Wire.ConversationSubsystem.One2One ( one2OneConvId, - iUpsertOne2OneConversation, + internalUpsertOne2OneConversation, ) where @@ -51,12 +51,12 @@ newConnectConversationWithRemote creator users = groupId = Nothing } -iUpsertOne2OneConversation :: +internalUpsertOne2OneConversation :: forall r. (Member ConversationStore r) => UpsertOne2OneConversationRequest -> Sem r () -iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do +internalUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do let dolocal :: Local ConvId -> Sem r () dolocal lconvId = do mbConv <- getConversation (tUnqualified lconvId) diff --git a/services/galley/src/Galley/API/Query.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs similarity index 94% rename from services/galley/src/Galley/API/Query.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs index 201b7572bd3..ce8009d45bd 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Query.hs @@ -18,7 +18,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Query +module Wire.ConversationSubsystem.Query ( getBotConversation, getUnqualifiedOwnConversation, getOwnConversation, @@ -27,9 +27,10 @@ module Galley.API.Query getLocalConversationInternal, getConversationRoles, conversationIdsPageFromUnqualified, - conversationIdsPageFromV2, + conversationIdsPaginated, conversationIdsPageFrom, getConversations, + getConversationsInternal, listConversations, iterateConversations, getLocalSelf, @@ -42,8 +43,8 @@ module Galley.API.Query ensureConvAdmin, getMLSSelfConversation, getMLSSelfConversationWithError, - getMLSOne2OneConversationV5, - getMLSOne2OneConversationV6, + getMLSOne2OneOwnConversation, + getMLSOne2OneMLSConversation, getMLSOne2OneConversationInternal, getMLSOne2OneConversation, isMLSOne2OneEstablished, @@ -66,12 +67,6 @@ import Data.Qualified import Data.Range import Data.Set qualified as Set import Data.Tagged -import Galley.API.MLS -import Galley.API.MLS.Enabled -import Galley.API.MLS.One2One -import Galley.API.Mapping -import Galley.API.Mapping qualified as Mapping -import Galley.API.Teams.Features.Get import Galley.Types.Error import Imports import Polysemy @@ -107,7 +102,10 @@ import Wire.CodeStore.Code (Code (codeConversation)) import Wire.CodeStore.Code qualified as Data import Wire.ConversationStore qualified as ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem qualified as ConversationSubsystem +import Wire.ConversationSubsystem.Fetch (getConversationIdsImpl) +import Wire.ConversationSubsystem.MLS +import Wire.ConversationSubsystem.MLS.Enabled (assertMLSEnabled, getMLSPrivateKeys, isMLSEnabled) +import Wire.ConversationSubsystem.MLS.One2One (localMLSOne2OneConversation, remoteMLSOne2OneConversation) import Wire.ConversationSubsystem.One2One import Wire.ConversationSubsystem.Util import Wire.FeaturesConfigSubsystem @@ -119,7 +117,7 @@ import Wire.StoredConversation import Wire.StoredConversation qualified as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, permissionCheck) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList import Wire.Util @@ -162,7 +160,7 @@ getUnqualifiedOwnConversation :: Sem r Public.OwnConversation getUnqualifiedOwnConversation lusr cnv = do c <- getConversationAsMember (tUntagged lusr) (qualifyAs lusr cnv) - Mapping.conversationViewV9 lusr c + maybe (throwIfNotOwnConversation lusr cnv) pure $ ownConversationView lusr c getUnqualifiedConversation :: forall r. @@ -175,7 +173,7 @@ getUnqualifiedConversation :: ConvId -> Sem r Public.Conversation getUnqualifiedConversation lusr cnv = - Mapping.conversationView (qualifyAs lusr ()) (Just lusr) . (.conv) + conversationView (qualifyAs lusr ()) (Just lusr) . (.conv) <$> getConversationAsViewer (tUntagged lusr) (qualifyAs lusr cnv) getConversation :: @@ -318,9 +316,9 @@ getRemoteConversationsWithFailures :: getRemoteConversationsWithFailures lusr convs = do -- get self member statuses from the database statusMap <- ConversationStore.getRemoteConversationStatus (tUnqualified lusr) convs - let remoteView :: Remote RemoteConversationV2 -> OwnConversation + let remoteView :: Remote RemoteConversationView -> OwnConversation remoteView rconv = - Mapping.remoteConversationView + remoteConversationView lusr ( Map.findWithDefault defMemberStatus @@ -334,14 +332,14 @@ getRemoteConversationsWithFailures lusr convs = do | otherwise = [failedGetConversationLocally (map tUntagged locallyNotFound)] -- request conversations from remote backends - let rpc :: GetConversationsRequest -> FederatorClient 'Galley GetConversationsResponseV2 + let rpc :: GetConversationsRequest -> FederatorClient 'Galley GetRemoteConversationViewsResponse rpc req = do mFedVersion <- getNegotiatedVersion case mFedVersion of Nothing -> error "impossible" Just fedVersion -> if fedVersion < Federation.V2 - then getConversationsResponseToV2 <$> fedClient @'Galley @"get-conversations@v1" req + then getConversationsResponseToView <$> fedClient @'Galley @"get-conversations@v1" req else fedClient @'Galley @"get-conversations" req resp <- E.runFederatedConcurrentlyEither locallyFound $ \someConvs -> @@ -352,8 +350,8 @@ getRemoteConversationsWithFailures lusr convs = do where handleFailure :: (Member P.TinyLog r) => - Either (Remote [ConvId], FederationError) (Remote GetConversationsResponseV2) -> - Sem r (Either FailedGetConversation [Remote RemoteConversationV2]) + Either (Remote [ConvId], FederationError) (Remote GetRemoteConversationViewsResponse) -> + Sem r (Either FailedGetConversation [Remote RemoteConversationView]) handleFailure (Left (rcids, e)) = do P.warn $ Logger.msg ("Error occurred while fetching remote conversations" :: ByteString) @@ -401,14 +399,14 @@ conversationIdsPageFromUnqualified lusr start msize = do -- -- FUTUREWORK: Move the body of this function to 'conversationIdsPageFrom' once -- support for V2 is dropped. -conversationIdsPageFromV2 :: - (Member ConversationSubsystem.ConversationSubsystem r) => +conversationIdsPaginated :: + (Member ConversationStore.ConversationStore r) => ListGlobalSelfConvs -> Local UserId -> Public.GetPaginatedConversationIds -> Sem r Public.ConvIdsPage -conversationIdsPageFromV2 listGlobalSelf lusr Public.GetMultiTablePageRequest {..} = do - filterOut <$> ConversationSubsystem.getConversationIds lusr gmtprSize gmtprState +conversationIdsPaginated listGlobalSelf lusr Public.GetMultiTablePageRequest {..} = do + filterOut <$> getConversationIdsImpl lusr gmtprSize gmtprState where -- MLS self-conversation of this user selfConvId = mlsSelfConvId (tUnqualified lusr) @@ -437,9 +435,8 @@ conversationIdsPageFromV2 listGlobalSelf lusr Public.GetMultiTablePageRequest {. conversationIdsPageFrom :: forall r. ( Member ConversationStore.ConversationStore r, - Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member (Error InternalError) r, Member P.TinyLog r ) => Local UserId -> @@ -455,7 +452,7 @@ conversationIdsPageFrom lusr state = do -- returned or attempted to be created; in that case we skip anything related -- to it. whenM isMLSEnabled $ void $ getMLSSelfConversation lusr - conversationIdsPageFromV2 ListGlobalSelf lusr state + conversationIdsPaginated ListGlobalSelf lusr state getConversations :: ( Member (Error InternalError) r, @@ -469,7 +466,8 @@ getConversations :: Sem r (Public.ConversationList Public.OwnConversation) getConversations luser mids mstart msize = do ConversationList cs more <- getConversationsInternal luser mids mstart msize - flip ConversationList more <$> mapM (Mapping.conversationViewV9 luser) cs + ownConvs <- for cs (\c -> maybe (throwIfNotOwnConversation luser c.id_) pure $ ownConversationView luser c) + pure $ ConversationList ownConvs more getConversationsInternal :: (Member ConversationStore.ConversationStore r) => @@ -520,7 +518,10 @@ listConversations luser (Public.ListConversations ids) = do localInternalConversations <- ConversationStore.getConversations foundLocalIds >>= filterM (\c -> pure $ isMember (tUnqualified luser) c.localMembers) - localConversations <- mapM (Mapping.conversationViewV9 luser) localInternalConversations + localConversations <- + mapM + (\c -> maybe (throwIfNotOwnConversation luser c.id_) pure (ownConversationView luser c)) + localInternalConversations (remoteFailures, remoteConversations) <- getRemoteConversationsWithFailures luser remoteIds let (failedConvsLocally, failedConvsRemotely) = partitionGetConversationFailures remoteFailures @@ -711,9 +712,9 @@ getConversationGuestLinksFeatureStatus (Just tid) = getFeatureForTeam tid getMLSSelfConversationWithError :: forall r. ( Member ConversationStore.ConversationStore r, - Member (Error InternalError) r, - Member (ErrorS 'MLSNotEnabled) r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member (ErrorS MLSNotEnabled) r, + Member (Error InternalError) r, Member P.TinyLog r ) => Local UserId -> @@ -740,7 +741,7 @@ getMLSSelfConversation lusr = do let selfConvId = mlsSelfConvId . tUnqualified $ lusr mconv <- ConversationStore.getConversation selfConvId cnv <- maybe (createMLSSelfConversation lusr) pure mconv - conversationViewV9 lusr cnv + maybe (throwIfNotOwnConversation lusr cnv.id_) pure $ ownConversationView lusr cnv createMLSSelfConversation :: (Member ConversationStore.ConversationStore r) => @@ -767,7 +768,7 @@ createMLSSelfConversation lusr = do -- uses the same function to calculate the conversation ID and corresponding -- group ID, however we /do/ assume that the two backends agree on which of the -- two is responsible for hosting the conversation. -getMLSOne2OneConversationV5 :: +getMLSOne2OneOwnConversation :: ( Member BrigAPIAccess r, Member ConversationStore.ConversationStore r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, @@ -785,7 +786,7 @@ getMLSOne2OneConversationV5 :: Local UserId -> Qualified UserId -> Sem r OwnConversation -getMLSOne2OneConversationV5 lself qother = do +getMLSOne2OneOwnConversation lself qother = do if isLocal lself qother then getMLSOne2OneConversationInternal lself qother else throwS @MLSFederatedOne2OneNotSupported @@ -811,7 +812,7 @@ getMLSOne2OneConversationInternal :: getMLSOne2OneConversationInternal lself qother = (.conversation) <$> getMLSOne2OneConversation lself qother Nothing -getMLSOne2OneConversationV6 :: +getMLSOne2OneMLSConversation :: forall r. ( Member BrigAPIAccess r, Member ConversationStore.ConversationStore r, @@ -829,7 +830,7 @@ getMLSOne2OneConversationV6 :: Local UserId -> Qualified UserId -> Sem r (MLSOne2OneConversation MLSPublicKey) -getMLSOne2OneConversationV6 lself qother = do +getMLSOne2OneMLSConversation lself qother = do assertMLSEnabled ensureConnectedOrSameTeam lself [qother] let convId = one2OneConvId BaseProtocolMLSTag (tUntagged lself) qother @@ -858,16 +859,16 @@ getMLSOne2OneConversation :: Maybe MLSPublicKeyFormat -> Sem r (MLSOne2OneConversation SomeKey) getMLSOne2OneConversation lself qother fmt = do - convWithUnformattedKeys <- getMLSOne2OneConversationV6 lself qother + convWithUnformattedKeys <- getMLSOne2OneMLSConversation lself qother MLSOne2OneConversation convWithUnformattedKeys.conversation <$> formatPublicKeys fmt convWithUnformattedKeys.publicKeys getLocalMLSOne2OneConversation :: ( Member ConversationStore.ConversationStore r, - Member (Error InternalError) r, - Member P.TinyLog r, Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, - Member (ErrorS MLSNotEnabled) r + Member (ErrorS MLSNotEnabled) r, + Member (Error InternalError) r, + Member P.TinyLog r ) => Local UserId -> Local ConvId -> @@ -877,7 +878,7 @@ getLocalMLSOne2OneConversation lself lconv = do keys <- mlsKeysToPublic <$$> getMLSPrivateKeys conv <- case mconv of Nothing -> pure (localMLSOne2OneConversation lself lconv) - Just conv -> conversationViewV9 lself conv + Just conv -> maybe (throwIfNotOwnConversation lself conv.id_) pure $ ownConversationView lself conv pure $ MLSOne2OneConversation { conversation = conv, diff --git a/services/galley/src/Galley/API/Update.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs similarity index 86% rename from services/galley/src/Galley/API/Update.hs rename to libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs index 66a7d0030e9..96a798aeca3 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Update.hs @@ -18,7 +18,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Update +module Wire.ConversationSubsystem.Update ( -- * Managing Conversations acceptConv, blockConv, @@ -29,16 +29,11 @@ module Galley.API.Update joinConversationByReusableCode, joinConversationById, addCodeUnqualified, - addCodeUnqualifiedWithReqBody, rmCodeUnqualified, getCode, - updateUnqualifiedConversationName, updateConversationName, - updateConversationReceiptModeUnqualified, updateConversationReceiptMode, - updateConversationMessageTimerUnqualified, updateConversationMessageTimer, - updateConversationAccessUnqualified, updateConversationAccess, updateConversationHistory, updateChannelAddPermission, @@ -49,16 +44,12 @@ module Galley.API.Update updateCellsState, -- * Managing Members - addMembersUnqualified, - addMembersUnqualifiedV2, + addQualifiedMembersUnqualified, addMembers, replaceMembers, - updateUnqualifiedSelfMember, updateSelfMember, updateOtherMember, - updateOtherMemberUnqualified, removeMemberQualified, - removeMemberUnqualified, removeMemberFromLocalConv, removeMemberFromRemoteConv, @@ -67,7 +58,6 @@ module Galley.API.Update postOtrMessageUnqualified, postProteusBroadcast, postOtrBroadcastUnqualified, - memberTypingUnqualified, memberTyping, -- * External Services @@ -90,13 +80,6 @@ import Data.Qualified import Data.Set qualified as Set import Data.Singletons import Data.Vector qualified as V -import Galley.API.Action -import Galley.API.Action.Kick (kickMember) -import Galley.API.Mapping -import Galley.API.Message -import Galley.API.Query qualified as Query -import Galley.API.Teams.Features.Get -import Galley.App import Galley.Types.Error import Imports hiding (forkIO) import Polysemy @@ -126,7 +109,7 @@ import Wire.API.Routes.Public.Galley.Messaging import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) import Wire.API.Team.Feature -import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureFlags) import Wire.API.Team.Member import Wire.API.User.Client import Wire.API.UserGroup @@ -137,7 +120,10 @@ import Wire.CodeStore qualified as E import Wire.CodeStore.Code import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as E -import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Action +import Wire.ConversationSubsystem.Action.Kick (kickMember) +import Wire.ConversationSubsystem.Message +import Wire.ConversationSubsystem.Query qualified as Query import Wire.ConversationSubsystem.Util import Wire.ExternalAccess qualified as E import Wire.FeaturesConfigSubsystem @@ -156,7 +142,7 @@ import Wire.Sem.Random (Random) import Wire.StoredConversation import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (TeamSubsystem, permissionCheck) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserClientIndexStore qualified as E import Wire.UserGroupStore (UserGroupStore, getUserGroupsForConv) @@ -180,7 +166,7 @@ acceptConv lusr conn cnv = do conv <- E.getConversation cnv >>= noteS @'ConvNotFound conv' <- acceptOne2One lusr conv conn - conversationViewV9 lusr conv' + maybe (throwIfNotOwnConversation lusr cnv) pure $ ownConversationView lusr conv' blockConv :: ( Member ConversationStore r, @@ -262,7 +248,7 @@ unblockConvUnqualified lusr conn cnv = do unless (convType conv `elem` [ConnectConv, One2OneConv]) $ throwS @'InvalidOperation conv' <- acceptOne2One lusr conv conn - conversationViewV9 lusr conv' + maybe (throwIfNotOwnConversation lusr cnv) pure $ ownConversationView lusr conv' unblockRemoteConv :: (Member ConversationStore r) => @@ -291,8 +277,6 @@ type UpdateConversationAccessEffects = E.FederationAPIAccess FederatorClient, FireAndForget, NotificationSubsystem, - ConversationSubsystem, - Input Env, Input ConversationSubsystemConfig, ProposalStore, Random, @@ -322,7 +306,10 @@ updateConversationHistory :: Member (ErrorS ConvNotFound) r, Member (ErrorS HistoryNotSupported) r, Member ConversationStore r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member BackendNotificationQueueAccess r, + Member Now r, Member TeamSubsystem r ) => Local UserId -> @@ -339,24 +326,6 @@ updateConversationHistory lusr con qcnv update = do (Just con) update.history -updateConversationAccessUnqualified :: - ( Members UpdateConversationAccessEffects r, - Member Now r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationAccessData -> - Sem r (UpdateResult Event) -updateConversationAccessUnqualified lusr con cnv update = - getUpdateResult . fmap lcuEvent $ - updateLocalConversationAccessData - (qualifyAs lusr cnv) - (tUntagged lusr) - (Just con) - update - updateConversationReceiptMode :: ( Member BrigAPIAccess r, Member ConversationStore r, @@ -367,9 +336,10 @@ updateConversationReceiptMode :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'MLSReadReceiptsNotAllowed) r, Member E.ExternalAccess r, + Member BackendNotificationQueueAccess r, + Member Now r, Member (E.FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member (Input (Local ())) r, Member TinyLog r, Member TeamSubsystem r @@ -434,37 +404,16 @@ updateRemoteConversation rcnv lusr mconn action = getUpdateResult $ do ConversationUpdateResponseUnreachableBackends e -> throw e updateLocalStateOfRemoteConv (qualifyAs rcnv convUpdate) mconn >>= note NoChanges -updateConversationReceiptModeUnqualified :: - ( Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InternalError) r, - Member (ErrorS ('ActionDenied 'ModifyConversationReceiptMode)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'MLSReadReceiptsNotAllowed) r, - Member E.ExternalAccess r, - Member (E.FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member TinyLog r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationReceiptModeUpdate -> - Sem r (UpdateResult Event) -updateConversationReceiptModeUnqualified lusr zcon cnv = updateConversationReceiptMode lusr zcon (tUntagged (qualifyAs lusr cnv)) - updateConversationMessageTimer :: ( Member ConversationStore r, Member (ErrorS ('ActionDenied 'ModifyConversationMessageTimer)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, Member (Error FederationError) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, Member TeamSubsystem r ) => Local UserId -> @@ -487,22 +436,6 @@ updateConversationMessageTimer lusr zcon qcnv update = (\_ -> throw FederationNotImplemented) qcnv -updateConversationMessageTimerUnqualified :: - ( Member ConversationStore r, - Member (ErrorS ('ActionDenied 'ModifyConversationMessageTimer)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (Error FederationError) r, - Member ConversationSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationMessageTimerUpdate -> - Sem r (UpdateResult Event) -updateConversationMessageTimerUnqualified lusr zcon cnv = updateConversationMessageTimer lusr zcon (tUntagged (qualifyAs lusr cnv)) - deleteLocalConversation :: ( Member CodeStore r, Member ConversationStore r, @@ -511,7 +444,10 @@ deleteLocalConversation :: Member (ErrorS ('ActionDenied 'DeleteConversation)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, Member ProposalStore r, Member TeamSubsystem r ) => @@ -523,32 +459,6 @@ deleteLocalConversation lusr con lcnv = getUpdateResult . fmap lcuEvent $ updateLocalConversationDelete lcnv (tUntagged lusr) (Just con) -addCodeUnqualifiedWithReqBody :: - forall r. - ( Member CodeStore r, - Member ConversationStore r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'GuestLinksDisabled) r, - Member (ErrorS 'CreateConversationCodeConflict) r, - Member E.ExternalAccess r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member Now r, - Member HashPassword r, - Member (Input Opts) r, - Member FeaturesConfigSubsystem r, - Member RateLimit r, - Member TeamSubsystem r - ) => - UserId -> - Maybe Text -> - Maybe ConnId -> - ConvId -> - CreateConversationCodeRequest -> - Sem r AddCodeResult -addCodeUnqualifiedWithReqBody usr mbZHost mZcon cnv req = addCodeUnqualified (Just req) usr mbZHost mZcon cnv - addCodeUnqualified :: forall r. ( Member CodeStore r, @@ -561,7 +471,7 @@ addCodeUnqualified :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member Now r, - Member (Input Opts) r, + Member (Input (Maybe GuestLinkTTLSeconds)) r, Member HashPassword r, Member FeaturesConfigSubsystem r, Member RateLimit r, @@ -590,7 +500,7 @@ addCode :: Member HashPassword r, Member NotificationSubsystem r, Member Now r, - Member (Input Opts) r, + Member (Input (Maybe GuestLinkTTLSeconds)) r, Member FeaturesConfigSubsystem r, Member RateLimit r, Member TeamSubsystem r @@ -612,7 +522,7 @@ addCode lusr mbZHost mZcon lcnv mReq = do key <- E.makeKey (tUnqualified lcnv) E.getCode key >>= \case Nothing -> do - ttl <- realToFrac . unGuestLinkTTLSeconds . fromMaybe defGuestLinkTTLSeconds . view (settings . guestLinkTTLSeconds) <$> input + ttl <- inputs (realToFrac . unGuestLinkTTLSeconds . fromMaybe defGuestLinkTTLSeconds) code <- E.generateCode (tUnqualified lcnv) (Timeout ttl) mPw <- for (mReq >>= (.password)) $ HashPassword.hashPassword8 (RateLimitUser (tUnqualified lusr)) E.createCode code mPw @@ -742,7 +652,6 @@ updateConversationProtocolWithLocalUser :: Member ConversationStore r, Member TinyLog r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, Member Random r, @@ -780,8 +689,9 @@ updateChannelAddPermission :: Member (ErrorS 'InvalidOperation) r, Member (Error FederationError) r, Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member (Input (Local ())) r, Member TinyLog r, Member (Error NonFederatingBackends) r, @@ -824,11 +734,15 @@ joinConversationByReusableCode :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, - Member ConversationSubsystem r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, Member FeaturesConfigSubsystem r, Member HashPassword r, Member RateLimit r, Member TeamSubsystem r, + Member Now r, Member (Input ConversationSubsystemConfig) r ) => Local UserId -> @@ -850,8 +764,12 @@ joinConversationById :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, - Member ConversationSubsystem r, + Member (Error FederationError) r, Member (Input ConversationSubsystemConfig) r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, + Member E.ExternalAccess r, + Member Now r, Member TeamSubsystem r ) => Local UserId -> @@ -869,9 +787,13 @@ joinConversation :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TooManyMembers) r, - Member ConversationSubsystem r, + Member (Error FederationError) r, Member (Input ConversationSubsystemConfig) r, + Member BackendNotificationQueueAccess r, + Member E.ExternalAccess r, Member ConversationStore r, + Member Now r, + Member NotificationSubsystem r, Member TeamSubsystem r ) => Local UserId -> @@ -927,7 +849,6 @@ addMembers :: Member (Error UnreachableBackends) r, Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member Now r, Member LegalHoldStore r, @@ -962,7 +883,7 @@ addMembers lusr zcon qcnv (InviteQualified users role) = do getUpdateResult . fmap lcuEvent $ updateLocalConversationJoin lcnv (tUntagged lusr) (Just zcon) action -addMembersUnqualifiedV2 :: +addQualifiedMembersUnqualified :: ( Member BackendNotificationQueueAccess r, Member BrigAPIAccess r, Member ConversationStore r, @@ -979,7 +900,6 @@ addMembersUnqualifiedV2 :: Member (Error UnreachableBackends) r, Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, Member NotificationSubsystem r, Member Now r, Member LegalHoldStore r, @@ -997,51 +917,12 @@ addMembersUnqualifiedV2 :: ConvId -> InviteQualified -> Sem r (UpdateResult Event) -addMembersUnqualifiedV2 lusr zcon cnv (InviteQualified users role) = do +addQualifiedMembersUnqualified lusr zcon cnv (InviteQualified users role) = do let lcnv = qualifyAs lusr cnv getUpdateResult . fmap lcuEvent $ updateLocalConversationJoin lcnv (tUntagged lusr) (Just zcon) $ ConversationJoin users role def -addMembersUnqualified :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS ('ActionDenied 'AddConversationMember)) r, - Member (ErrorS 'ConvAccessDenied) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TooManyMembers) r, - Member (ErrorS 'MissingLegalholdConsent) r, - Member (ErrorS 'GroupIdVersionNotSupported) r, - Member (Error UnreachableBackends) r, - Member E.ExternalAccess r, - Member (E.FederationAPIAccess FederatorClient) r, - Member ConversationSubsystem r, - Member NotificationSubsystem r, - Member Now r, - Member LegalHoldStore r, - Member ProposalStore r, - Member Random r, - Member TeamStore r, - Member TinyLog r, - Member TeamCollaboratorsSubsystem r, - Member FederationSubsystem r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r - ) => - Local UserId -> - ConnId -> - ConvId -> - Invite -> - Sem r (UpdateResult Event) -addMembersUnqualified lusr zcon cnv (Invite users role) = do - let qusers = fmap (tUntagged . qualifyAs lusr) users - addMembers lusr zcon (tUntagged (qualifyAs lusr cnv)) (InviteQualified qusers role) - -- | Replace conversation members by computing the difference between desired and -- current members, then executing removals followed by additions within a commit -- lock. @@ -1073,7 +954,6 @@ replaceMembers :: Member TinyLog r, Member TeamCollaboratorsSubsystem r, Member UserGroupStore r, - Member ConversationSubsystem r, Member FederationSubsystem r, Member TeamSubsystem r, Member (Input ConversationSubsystemConfig) r @@ -1177,22 +1057,6 @@ updateSelfMember lusr zcon qcnv update = do misConvRoleName = Nothing } -updateUnqualifiedSelfMember :: - ( Member ConversationStore r, - Member (ErrorS 'ConvNotFound) r, - Member E.ExternalAccess r, - Member NotificationSubsystem r, - Member Now r - ) => - Local UserId -> - ConnId -> - ConvId -> - MemberUpdate -> - Sem r () -updateUnqualifiedSelfMember lusr zcon cnv update = do - let lcnv = qualifyAs lusr cnv - updateSelfMember lusr zcon (tUntagged lcnv) update - updateOtherMemberLocalConv :: ( Member ConversationStore r, Member (Error FederationError) r, @@ -1201,7 +1065,10 @@ updateOtherMemberLocalConv :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvMemberNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member E.ExternalAccess r, + Member Now r, Member TeamSubsystem r ) => Local ConvId -> @@ -1216,28 +1083,6 @@ updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult updateLocalConversationMemberUpdate lcnv (tUntagged lusr) (Just con) $ ConversationMemberUpdate qvictim update -updateOtherMemberUnqualified :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS ('ActionDenied 'ModifyOtherConversationMember)) r, - Member (ErrorS 'InvalidTarget) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'ConvMemberNotFound) r, - Member ConversationSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - UserId -> - OtherMemberUpdate -> - Sem r () -updateOtherMemberUnqualified lusr zcon cnv victim update = do - let lcnv = qualifyAs lusr cnv - let lvictim = qualifyAs lusr victim - updateOtherMemberLocalConv lcnv lusr zcon (tUntagged lvictim) update - updateOtherMember :: ( Member ConversationStore r, Member (Error FederationError) r, @@ -1246,7 +1091,10 @@ updateOtherMember :: Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvMemberNotFound) r, - Member ConversationSubsystem r, + Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, + Member E.ExternalAccess r, + Member Now r, Member TeamSubsystem r ) => Local UserId -> @@ -1269,34 +1117,6 @@ updateOtherMemberRemoteConv :: Sem r () updateOtherMemberRemoteConv _ _ _ _ _ = throw FederationNotImplemented -removeMemberUnqualified :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member E.ExternalAccess r, - Member (E.FederationAPIAccess FederatorClient) r, - Member NotificationSubsystem r, - Member ConversationSubsystem r, - Member Now r, - Member ProposalStore r, - Member Random r, - Member TinyLog r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r - ) => - Local UserId -> - ConnId -> - ConvId -> - UserId -> - Sem r (Maybe Event) -removeMemberUnqualified lusr con cnv victim = do - let lvictim = qualifyAs lusr victim - lcnv = qualifyAs lusr cnv - removeMemberQualified lusr con (tUntagged lcnv) (tUntagged lvictim) - removeMemberQualified :: ( Member BackendNotificationQueueAccess r, Member ConversationStore r, @@ -1307,7 +1127,6 @@ removeMemberQualified :: Member E.ExternalAccess r, Member (E.FederationAPIAccess FederatorClient) r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member Now r, Member ProposalStore r, Member Random r, @@ -1382,7 +1201,6 @@ removeMemberFromLocalConv :: Member (ErrorS 'InvalidOperation) r, Member E.ExternalAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member Now r, Member ProposalStore r, Member Random r, @@ -1425,7 +1243,6 @@ removeMemberFromChannel :: Member Now r, Member E.ExternalAccess r, Member NotificationSubsystem r, - Member ConversationSubsystem r, Member Random r, Member TinyLog r, Member (Error FederationError) r, @@ -1462,7 +1279,8 @@ postProteusMessage :: Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member E.ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member Now r, Member TinyLog r, Member TeamSubsystem r @@ -1486,13 +1304,14 @@ postProteusBroadcast :: Member (ErrorS 'BroadcastLimitExceeded) r, Member NotificationSubsystem r, Member E.ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member Now r, Member TeamStore r, Member TinyLog r, Member (Input FanoutLimit) r, Member TeamSubsystem r, - Member ConversationSubsystem r + Member (Input ConversationSubsystemConfig) r, + Member E.UserClientIndexStore r ) => Local UserId -> ConnId -> @@ -1540,7 +1359,8 @@ postBotMessageUnqualified :: Member BackendNotificationQueueAccess r, Member NotificationSubsystem r, Member (Input (Local ())) r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member TinyLog r, Member Now r, Member TeamSubsystem r @@ -1568,13 +1388,14 @@ postOtrBroadcastUnqualified :: Member (ErrorS 'BroadcastLimitExceeded) r, Member NotificationSubsystem r, Member E.ExternalAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member Now r, Member TeamStore r, Member TinyLog r, Member (Input FanoutLimit) r, Member TeamSubsystem r, - Member ConversationSubsystem r + Member (Input ConversationSubsystemConfig) r, + Member E.UserClientIndexStore r ) => Local UserId -> ConnId -> @@ -1595,7 +1416,8 @@ postOtrMessageUnqualified :: Member BackendNotificationQueueAccess r, Member E.ExternalAccess r, Member NotificationSubsystem r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, + Member (Input IntraListing) r, Member Now r, Member TinyLog r, Member TeamSubsystem r @@ -1620,7 +1442,10 @@ updateConversationName :: Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, Member TeamSubsystem r ) => Local UserId -> @@ -1636,25 +1461,6 @@ updateConversationName lusr zcon qcnv convRename = do qcnv convRename -updateUnqualifiedConversationName :: - ( Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InvalidInput) r, - Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - ConversationRename -> - Sem r (UpdateResult Event) -updateUnqualifiedConversationName lusr zcon cnv rename = do - let lcnv = qualifyAs lusr cnv - updateLocalConversationName lusr zcon lcnv rename - updateLocalConversationName :: ( Member ConversationStore r, Member (Error FederationError) r, @@ -1662,7 +1468,10 @@ updateLocalConversationName :: Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, - Member ConversationSubsystem r, + Member E.ExternalAccess r, + Member Now r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, Member TeamSubsystem r ) => Local UserId -> @@ -1713,25 +1522,6 @@ memberTyping lusr zcon qcnv ts = do ) qcnv -memberTypingUnqualified :: - ( Member NotificationSubsystem r, - Member (ErrorS 'ConvNotFound) r, - Member (Input (Local ())) r, - Member Now r, - Member ConversationStore r, - Member (E.FederationAPIAccess FederatorClient) r, - Member (Error FederationError) r, - Member TeamSubsystem r - ) => - Local UserId -> - ConnId -> - ConvId -> - TypingStatus -> - Sem r () -memberTypingUnqualified lusr zcon cnv ts = do - lcnv <- qualifyLocal cnv - memberTyping lusr zcon (tUntagged lcnv) ts - addBot :: forall r. ( Member E.UserClientIndexStore r, diff --git a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs index 16f70e955ca..78d70193979 100644 --- a/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs +++ b/libs/wire-subsystems/src/Wire/ConversationSubsystem/Util.hs @@ -24,7 +24,6 @@ import Control.Lens (view, (^.)) import Control.Monad.Extra (allM, anyM) import Control.Monad.Trans.Maybe import Data.Bifunctor -import Data.Code qualified as Code import Data.Default import Data.Domain (Domain) import Data.Id as Id @@ -34,7 +33,7 @@ import Data.List.Extra (chunksOf, nubOrd) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map -import Data.Misc (PlainTextPassword6, PlainTextPassword8) +import Data.Misc (PlainTextPassword8) import Data.Qualified import Data.Set qualified as Set import Data.Singletons @@ -42,11 +41,14 @@ import Data.Text qualified as T import Data.Time import Galley.Types.Conversations.Roles import Galley.Types.Error -import Imports hiding (forkIO) +import Imports import Network.AMQP qualified as Q import Polysemy import Polysemy.Error import Polysemy.Input +import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as P +import System.Logger.Message (msg, val, (+++)) import Wire.API.Connection import Wire.API.Conversation hiding (Member, cnvAccess, cnvAccessRoles, cnvName, cnvType) import Wire.API.Conversation qualified as Public @@ -71,10 +73,8 @@ import Wire.API.Team.Collaborator qualified as CollaboratorPermission (Collabora import Wire.API.Team.FeatureFlags import Wire.API.Team.Member import Wire.API.Team.Member qualified as Mem -import Wire.API.Team.Member.Error import Wire.API.Team.Role import Wire.API.User hiding (userId) -import Wire.API.User.Auth.ReAuth import Wire.API.VersionInfo import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess @@ -94,10 +94,19 @@ import Wire.Sem.Now qualified as Now import Wire.StoredConversation as Data import Wire.TeamCollaboratorsSubsystem import Wire.TeamStore -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.TeamSubsystem (ConsentGiven (..), TeamSubsystem, consentGiven, getLHStatus) import Wire.TeamSubsystem qualified as TeamSubsystem import Wire.UserList +throwIfNotOwnConversation :: (Member TinyLog r, Member (Error InternalError) r) => Local UserId -> ConvId -> Sem r a +throwIfNotOwnConversation luid cid = do + P.err . msg $ + val "User " + +++ idToText (tUnqualified luid) + +++ val " is not a member of conv " + +++ idToText cid + throw BadMemberState + data NoChanges = NoChanges ensureAccessRole :: @@ -195,20 +204,6 @@ ensureConnected self others = do ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToRemotes self (ulRemotes others) -ensureConnectedToLocals :: - ( Member (ErrorS 'NotConnected) r, - Member BrigAPIAccess r - ) => - UserId -> - [UserId] -> - Sem r () -ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = do - (connsFrom, connsTo) <- - getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) - unless (length connsFrom == length uids && length connsTo == length uids) $ - throwS @'NotConnected - ensureConnectedToRemotes :: ( Member BrigAPIAccess r, Member (ErrorS 'NotConnected) r @@ -222,18 +217,6 @@ ensureConnectedToRemotes u remotes = do when (length acceptedConns /= length remotes) $ throwS @'NotConnected -ensureReAuthorised :: - ( Member BrigAPIAccess r, - Member (Error AuthenticationError) r - ) => - UserId -> - Maybe PlainTextPassword6 -> - Maybe Code.Value -> - Maybe VerificationAction -> - Sem r () -ensureReAuthorised u secret mbAction mbCode = - reauthUser u (ReAuthUser secret mbAction mbCode) >>= fromEither - ensureManageChannelsPermission :: (Member (ErrorS 'ConvNotFound) r) => StoredConversation -> TeamMember -> Sem r () ensureManageChannelsPermission conv tm = do unless (hasManageChannelsPermission conv tm) $ throwS @'ConvNotFound @@ -323,72 +306,6 @@ checkGroupIdSupport loc conv joinAction = void $ runMaybeT $ do failOnFirstError :: (Member (ErrorS GroupIdVersionNotSupported) r) => [Either e x] -> Sem r () failOnFirstError = traverse_ $ either (\_ -> throwS @GroupIdVersionNotSupported) pure --- | Same as 'permissionCheck', but for a statically known permission. -permissionCheckS :: - forall teamAssociation perm (p :: perm) r. - ( SingKind perm, - IsPerm teamAssociation (Demote perm), - ( Member (ErrorS (PermError p)) r, - Member (ErrorS 'NotATeamMember) r - ) - ) => - Sing p -> - Maybe teamAssociation -> - Sem r teamAssociation -permissionCheckS p = - \case - Just m -> do - if m `hasPermission` fromSing p - then pure m - else throwS @(PermError p) - -- FUTUREWORK: factor `noteS` out of this function. - Nothing -> throwS @'NotATeamMember - --- | 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 teamAssociation perm, - ( Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r - ) - ) => - perm -> - Maybe teamAssociation -> - Sem r teamAssociation --- FUTUREWORK: factor `noteS` out of this function. -permissionCheck p = \case - Just m -> do - if m `hasPermission` p - then pure m - else throwS @OperationDenied - -- FUTUREWORK: factor `noteS` out of this function. - Nothing -> throwS @'NotATeamMember - -assertTeamExists :: - ( Member (ErrorS 'TeamNotFound) r, - Member TeamStore r - ) => - TeamId -> - Sem r () -assertTeamExists tid = do - teamExists <- isJust <$> getTeam tid - if teamExists - then pure () - else throwS @'TeamNotFound - -assertOnTeam :: - ( Member (ErrorS 'NotATeamMember) r, - Member TeamSubsystem r - ) => - UserId -> - TeamId -> - Sem r () -assertOnTeam uid tid = - TeamSubsystem.internalGetTeamMember uid tid >>= \case - Nothing -> throwS @'NotATeamMember - Just _ -> pure () - -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: ( Member ConversationStore r, @@ -997,38 +914,6 @@ userLHEnabled = \case UserLegalHoldDisabled -> False UserLegalHoldNoConsent -> False -data ConsentGiven = ConsentGiven | ConsentNotGiven - deriving (Eq, Ord, Show) - -consentGiven :: UserLegalHoldStatus -> ConsentGiven -consentGiven = \case - UserLegalHoldDisabled -> ConsentGiven - UserLegalHoldPending -> ConsentGiven - UserLegalHoldEnabled -> ConsentGiven - UserLegalHoldNoConsent -> ConsentNotGiven - -checkConsent :: - (Member TeamSubsystem r) => - Map UserId TeamId -> - UserId -> - Sem 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 :: - (Member TeamSubsystem r) => - Maybe TeamId -> - UserId -> - Sem r UserLegalHoldStatus -getLHStatus teamOfUser other = do - case teamOfUser of - Nothing -> pure defUserLegalHoldStatus - Just team -> do - mMember <- TeamSubsystem.internalGetTeamMember other team - pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember - anyLegalholdActivated :: ( Member (Input ConversationSubsystemConfig) r, Member TeamStore r, @@ -1075,31 +960,6 @@ allLegalholdConsentGiven uids = do eitherTeamMemberAndLHAllowedOrDefLHStatus teamsPage uid = do fromMaybe (consentGiven defUserLegalHoldStatus == ConsentGiven) <$> (for (Map.lookup uid teamsPage) isTeamLegalholdWhitelisted) --- | Add to every uid the legalhold status -getLHStatusForUsers :: - (Member TeamStore r, Member TeamSubsystem r) => - [UserId] -> - Sem r [(UserId, UserLegalHoldStatus)] -getLHStatusForUsers uids = - mconcat - <$> for - (chunksOf 32 uids) - ( \uidsChunk -> do - teamsOfUsers <- getUsersTeams uidsChunk - for uidsChunk $ \uid -> do - (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid - ) - -getTeamMembersForFanout :: - ( Member (Input FanoutLimit) r, - Member TeamSubsystem r - ) => - TeamId -> - Sem r TeamMemberList -getTeamMembersForFanout tid = do - lim <- input - TeamSubsystem.internalGetTeamMembersWithLimit tid (Just lim) - ensureMemberLimit :: ( Foldable f, ( Member (ErrorS 'TooManyMembers) r, @@ -1173,39 +1033,6 @@ notifyConversationUpdated lusr conn j conv = do } ] --- | Convert a local conversation member (as stored in the DB) to a publicly --- facing 'Member' structure. -localMemberToPublic :: Local x -> LocalMember -> Public.Member -localMemberToPublic loc lm = - Public.Member - { memId = tUntagged . qualifyAs loc $ lm.id_, - memService = lm.service, - memOtrMutedStatus = msOtrMutedStatus st, - memOtrMutedRef = msOtrMutedRef st, - memOtrArchived = msOtrArchived st, - memOtrArchivedRef = msOtrArchivedRef st, - memHidden = msHidden st, - memHiddenRef = msHiddenRef st, - memConvRoleName = lm.convRoleName - } - where - st = lm.status - --- | View for a given user of a stored conversation. --- --- Returns 'Nothing' if the user is not part of the conversation. -conversationViewMaybe :: Local UserId -> [OtherMember] -> [OtherMember] -> StoredConversation -> Maybe Public.OwnConversation -conversationViewMaybe luid remoteOthers localOthers conv = do - let selfs = filter (\m -> tUnqualified luid == m.id_) conv.localMembers - self <- localMemberToPublic luid <$> listToMaybe selfs - let others = filter (\oth -> tUntagged luid /= omQualifiedId oth) localOthers <> remoteOthers - pure $ - Public.OwnConversation - (tUntagged . qualifyAs luid $ conv.id_) - conv.metadata - (OwnConvMembers self others) - conv.protocol - notifyConversationCreated :: ( Member NotificationSubsystem r, Member ConversationStore r, diff --git a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs index d8824e685c2..2b5da0c95fe 100644 --- a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs @@ -19,7 +19,8 @@ module Wire.FeaturesConfigSubsystem where -import Data.Id (TeamId, UserId) +import Data.Id (ConvId, TeamId, UserId) +import Data.Proxy (Proxy) import Data.Qualified (Local) import Imports import Polysemy @@ -35,5 +36,27 @@ data FeaturesConfigSubsystem m a where GetAllTeamFeaturesForTeamMember :: Local UserId -> TeamId -> FeaturesConfigSubsystem m AllTeamFeatures GetAllTeamFeaturesForTeam :: TeamId -> FeaturesConfigSubsystem m AllTeamFeatures GetAllTeamFeaturesForServer :: FeaturesConfigSubsystem m AllTeamFeatures + GuardSecondFactorDisabled :: + UserId -> + ConvId -> + FeaturesConfigSubsystem m () + FeatureEnabledForTeam :: + forall cfg m. + (GetFeatureConfig cfg) => + Proxy cfg -> + TeamId -> + FeaturesConfigSubsystem m Bool + GetAllTeamFeaturesForUser :: + UserId -> + FeaturesConfigSubsystem m AllTeamFeatures + GetSingleFeatureForUser :: + forall cfg m. + (GetFeatureConfig cfg) => + UserId -> + FeaturesConfigSubsystem m (LockableFeature cfg) + GetFeatureInternal :: + (GetFeatureConfig cfg) => + TeamId -> + FeaturesConfigSubsystem m (LockableFeature cfg) makeSem ''FeaturesConfigSubsystem diff --git a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs index d3842f68bf5..70936a806e0 100644 --- a/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs @@ -5,24 +5,31 @@ module Wire.FeaturesConfigSubsystem.Interpreter where +import Control.Error (hush) import Data.Aeson.Types qualified as A import Data.Id import Data.Qualified (tUnqualified) import Data.SOP +import Data.Tagged import Data.Text.Lazy qualified as LT import Imports import Polysemy import Polysemy.Error import Polysemy.Input +import Wire.API.Conversation (ConversationMetadata (..)) import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags +import Wire.BrigAPIAccess (BrigAPIAccess) +import Wire.ConversationStore qualified as ConversationStore import Wire.FeaturesConfigSubsystem import Wire.FeaturesConfigSubsystem.Types import Wire.FeaturesConfigSubsystem.Utils +import Wire.LegalHoldStore (LegalHoldStore) import Wire.TeamFeatureStore import Wire.TeamFeatureStore.Error (TeamFeatureStoreError (..)) +import Wire.TeamStore qualified as TeamStore import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem @@ -30,8 +37,11 @@ runFeaturesConfigSubsystem :: forall r a. ( Member TeamFeatureStore r, Member TeamSubsystem r, + Member TeamStore.TeamStore r, + Member ConversationStore.ConversationStore r, Member (Error TeamFeatureStoreError) r, Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'AccessDenied) r, GetFeatureConfigEffects r ) => Sem (FeaturesConfigSubsystem : r) a -> @@ -54,6 +64,16 @@ runFeaturesConfigSubsystem = interpret $ \case getAllTeamFeaturesImpl tid GetAllTeamFeaturesForServer -> getAllTeamFeaturesForServerImpl + GuardSecondFactorDisabled uid cid -> + guardSecondFactorDisabledImpl uid cid + FeatureEnabledForTeam (Proxy :: Proxy cfg) tid -> + featureEnabledForTeamImpl @cfg tid + GetAllTeamFeaturesForUser uid -> + getAllTeamFeaturesForUserImpl uid + GetSingleFeatureForUser uid -> + getSingleFeatureForUserImpl uid + GetFeatureInternal tid -> + getFeatureInternalImpl tid -- Internal helpers @@ -129,3 +149,138 @@ parseDbFeatureOrThrow feat = mapError (TeamFeatureStoreErrorInternalError . LT.pack) . fromEither $ A.parseEither (const (parseDbFeature feat)) () + +getFeatureInternalImpl :: + ( GetFeatureConfig cfg, + Member TeamFeatureStore r, + Member LegalHoldStore r, + Member TeamSubsystem r, + Member BrigAPIAccess r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r, + Member (Error TeamFeatureStoreError) r + ) => + TeamId -> + Sem r (LockableFeature cfg) +getFeatureInternalImpl tid = do + TeamSubsystem.assertTeamExists tid + getFeatureForTeamImpl tid + +getTeamAndCheckMembership :: + ( Member TeamStore.TeamStore r, + Member (ErrorS 'NotATeamMember) r, + Member TeamSubsystem r + ) => + UserId -> + Sem r (Maybe TeamId) +getTeamAndCheckMembership uid = do + mTid <- TeamStore.getOneUserTeam uid + for_ mTid $ \tid -> do + zusrMembership <- TeamSubsystem.internalGetTeamMember uid tid + void $ maybe (throwS @'NotATeamMember) pure zusrMembership + TeamSubsystem.assertTeamExists tid + pure mTid + +getAllTeamFeatures :: + forall r. + ( Member TeamFeatureStore r, + Member LegalHoldStore r, + Member BrigAPIAccess r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r, + Member (Error TeamFeatureStoreError) r + ) => + TeamId -> + Sem r AllTeamFeatures +getAllTeamFeatures tid = getAllTeamFeaturesImpl tid + +getAllTeamFeaturesForUserImpl :: + forall r. + ( Member (ErrorS 'NotATeamMember) r, + Member TeamStore.TeamStore r, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member (Error TeamFeatureStoreError) r, + GetFeatureConfigEffects r + ) => + UserId -> + Sem r AllTeamFeatures +getAllTeamFeaturesForUserImpl uid = do + mTid <- getTeamAndCheckMembership uid + case mTid of + Nothing -> hsequence' $ hcpure (Proxy @(GetAllTeamFeaturesForUserConstraints r)) $ Comp $ getFeatureForUser uid + Just tid -> getAllTeamFeatures tid + +getSingleFeatureForUserImpl :: + forall cfg r. + ( GetFeatureConfig cfg, + Member (ErrorS 'NotATeamMember) r, + Member (Error TeamFeatureStoreError) r, + Member TeamStore.TeamStore r, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member BrigAPIAccess r, + Member LegalHoldStore r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r + ) => + UserId -> + Sem r (LockableFeature cfg) +getSingleFeatureForUserImpl uid = do + mTid <- getTeamAndCheckMembership uid + getFeatureForTeamUserImpl @cfg uid mTid + +-- | If second factor auth is enabled, make sure that end-points that don't support it, but +-- should, are blocked completely. (This is a workaround until we have 2FA for those +-- end-points as well.) +-- +-- This function exists to resolve a cyclic dependency. +guardSecondFactorDisabledImpl :: + forall r. + ( Member (ErrorS 'AccessDenied) r, + Member (Error TeamFeatureStoreError) r, + Member ConversationStore.ConversationStore r, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member BrigAPIAccess r, + Member LegalHoldStore r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r + ) => + UserId -> + ConvId -> + Sem r () +guardSecondFactorDisabledImpl uid cid = do + mTid <- fmap hush . runError @() $ do + convData <- ConversationStore.getConversationMetadata cid >>= note () + tid <- note () convData.cnvmTeam + mapError (unTagged @'TeamNotFound @()) $ TeamSubsystem.assertTeamExists tid + pure tid + + tf <- getFeatureForTeamUserImpl @SndFactorPasswordChallengeConfig uid mTid + case tf.status of + FeatureStatusDisabled -> pure () + FeatureStatusEnabled -> throwS @'AccessDenied + +featureEnabledForTeamImpl :: + forall cfg r. + ( GetFeatureConfig cfg, + Member TeamSubsystem r, + Member TeamFeatureStore r, + Member LegalHoldStore r, + Member BrigAPIAccess r, + Member (Input FeatureFlags) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member (Input ExposeInvitationURLsAllowlist) r, + Member (Error TeamFeatureStoreError) r + ) => + TeamId -> + Sem r Bool +featureEnabledForTeamImpl tid = + (==) FeatureStatusEnabled + . (.status) + <$> getFeatureInternalImpl @cfg tid diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index f70fa3addf8..65d16aeb063 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -22,6 +22,7 @@ module Wire.GalleyAPIAccess where import Data.Currency qualified as Currency import Data.Id import Data.Json.Util (UTCTimeMillis) +import Data.LegalHold (UserLegalHoldStatus) import Data.Qualified import Data.Range import Imports @@ -104,6 +105,9 @@ data GalleyAPIAccess m a where GetTeam :: TeamId -> GalleyAPIAccess m Team.TeamData + FindTeam :: + TeamId -> + GalleyAPIAccess m (Maybe Team.TeamData) GetTeamName :: TeamId -> GalleyAPIAccess m Team.TeamName @@ -166,5 +170,15 @@ data GalleyAPIAccess m a where GetConversationConfig :: GalleyAPIAccess m ConversationSubsystemConfig GuardLegalHold :: LegalholdProtectee -> UserClients -> GalleyAPIAccess m () + GetUserLHStatus :: Maybe TeamId -> UserId -> GalleyAPIAccess m UserLegalHoldStatus + GetUsersLHStatus :: [UserId] -> GalleyAPIAccess m [(UserId, UserLegalHoldStatus)] + UpdateTeamMember :: + UserId -> + TeamId -> + Role -> + GalleyAPIAccess m () + IsEmailValidationEnabledTeam :: + TeamId -> + GalleyAPIAccess m Bool makeSem ''GalleyAPIAccess diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index 4a01842e676..91267f7cc84 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -27,6 +27,7 @@ import Data.Coerce (coerce) import Data.Currency qualified as Currency import Data.Id import Data.Json.Util (UTCTimeMillis) +import Data.LegalHold (UserLegalHoldStatus) import Data.Qualified import Data.Range import Imports @@ -38,7 +39,7 @@ import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Polysemy.Error import Polysemy.Input -import Polysemy.TinyLog +import Polysemy.TinyLog (TinyLog, debug) import Servant.API (toHeader) import System.Logger.Message import Util.Options @@ -67,8 +68,8 @@ import Wire.Rpc interpretGalleyAPIAccessToRpc :: ( Member (Error ParseException) r, Member Rpc r, - Member TinyLog r, - Member (Error ClientError) r + Member (Error ClientError) r, + Member TinyLog r ) => Set Version -> Endpoint -> @@ -91,6 +92,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = SelectTeamMembers tid uids -> selectTeamMembers tid uids GetTeamId id' -> getTeamId id' GetTeam id' -> getTeam id' + FindTeam id' -> findTeam id' GetTeamName id' -> getTeamName id' GetTeamLegalHoldStatus id' -> getTeamLegalHoldStatus id' GetTeamSearchVisibility id' -> getTeamSearchVisibility id' @@ -111,19 +113,19 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GetTeamContacts uid -> getTeamContacts uid GetConversationConfig -> getConversationConfig GuardLegalHold protectee userClient -> guardLegalhold protectee userClient + GetUserLHStatus mtid uid -> getUserLHStatus mtid uid + GetUsersLHStatus uids -> getUsersLHStatus uids + UpdateTeamMember uid tid role -> updateTeamMember uid tid role + IsEmailValidationEnabledTeam tid -> isEmailValidationEnabledTeam tid getUserLegalholdStatus :: - ( Member TinyLog r, - Member (Error ParseException) r, + ( Member (Error ParseException) r, Member Rpc r ) => Local UserId -> TeamId -> Sem (Input Endpoint : r) (Maybe UserLegalHoldStatusResponse) getUserLegalholdStatus luid tid = do - debug $ - remote "galley" - . msg (val "get legalhold user status") rs <- galleyRequest do method GET . paths ["teams", toByteString' tid, "legalhold", toByteString' (tUnqualified luid)] @@ -138,19 +140,15 @@ galleyRequest req = do ep <- input rpcWithRetries "galley" ep req --- | Calls 'Galley.API.createSelfConversationH'. +-- | Calls 'Wire.ConversationSubsystem.createSelfConversationH'. createSelfConv :: ( Member Rpc r, - Member TinyLog r, Member (Input Endpoint) r ) => Version -> UserId -> Sem r () createSelfConv v u = do - debug $ - remote "galley" - . msg (val "Creating self conversation") void $ galleyRequest $ method POST @@ -158,23 +156,17 @@ createSelfConv v u = do . zUser u . expect2xx --- | Calls 'Galley.API.getConversationH'. +-- | Calls 'Wire.ConversationSubsystem.getConversationH'. getConv :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => Version -> UserId -> Local ConvId -> Sem r (Maybe OwnConversation) getConv v usr lcnv = do - debug $ - remote "galley" - . field "domain" (toByteString (tDomain lcnv)) - . field "conv" (toByteString (tUnqualified lcnv)) - . msg (val "Getting conversation") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -191,12 +183,11 @@ getConv v usr lcnv = do . zUser usr . expect [status200, status404] --- | Calls 'Galley.API.getTeamConversationH'. +-- | Calls 'Wire.ConversationSubsystem.getTeamConversationH'. getTeamConv :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => Version -> UserId -> @@ -204,10 +195,6 @@ getTeamConv :: ConvId -> Sem r (Maybe Conv.TeamConversation) getTeamConv v usr tid cnv = do - debug $ - remote "galley" - . field "conv" (toByteString cnv) - . msg (val "Getting team conversation") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -225,39 +212,29 @@ getTeamConv v usr tid cnv = do . zUser usr . expect [status200, status404] --- | Calls 'Galley.API.addClientH'. +-- | Calls 'Wire.ConversationSubsystem.addClientH'. newClient :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> ClientId -> Sem r () newClient u c = do - debug $ - remote "galley" - . field "user" (toByteString u) - . field "client" (toByteString c) - . msg (val "new client") void . galleyRequest $ method POST . paths ["i", "clients", toByteString' c] . zUser u . expect2xx --- | Calls 'Galley.API.canUserJoinTeamH'. +-- | Calls 'Wire.ConversationSubsystem.canUserJoinTeamH'. checkUserCanJoinTeam :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r (Maybe Wai.Error) checkUserCanJoinTeam tid = do - debug $ - remote "galley" - . msg (val "Check if can add member to team") rs <- galleyRequest req pure $ case Bilge.statusCode rs of 200 -> Nothing @@ -270,11 +247,10 @@ checkUserCanJoinTeam tid = do . paths ["i", "teams", toByteString' tid, "members", "check"] . header "Content-Type" "application/json" --- | Calls 'Galley.API.uncheckedAddTeamMemberH'. +-- | Calls 'Wire.ConversationSubsystem.uncheckedAddTeamMemberH'. addTeamMember :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> TeamId -> @@ -282,9 +258,6 @@ addTeamMember :: Role -> Sem r Bool addTeamMember u tid minvmeta role = do - debug $ - remote "galley" - . msg (val "Adding member to team") rs <- galleyRequest req pure $ case Bilge.statusCode rs of 200 -> True @@ -300,20 +273,16 @@ addTeamMember u tid minvmeta role = do . expect [status200, status403] . lbytes (encode bdy) --- | Calls 'Galley.API.createBindingTeamH'. +-- | Calls 'Wire.ConversationSubsystem.createBindingTeamH'. createTeam :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> NewTeam -> TeamId -> Sem r () createTeam u t teamid = do - debug $ - remote "galley" - . msg (val "Creating Team") void $ galleyRequest $ req teamid where req tid = @@ -324,20 +293,16 @@ createTeam u t teamid = do . expect2xx . lbytes (encode t) --- | Calls 'Galley.API.uncheckedGetTeamMemberH'. +-- | Calls 'Wire.ConversationSubsystem.uncheckedGetTeamMemberH'. getTeamMember :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> TeamId -> Sem r (Maybe TeamMember) getTeamMember u tid = do - debug $ - remote "galley" - . msg (val "Get team member") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -349,7 +314,7 @@ getTeamMember u tid = do . zUser u . expect [status200, status404] --- | Calls 'Galley.API.uncheckedGetTeamMembersH'. +-- | Calls 'Wire.ConversationSubsystem.uncheckedGetTeamMembersH'. -- -- | TODO: is now truncated. this is (only) used for team suspension / unsuspension, which -- means that only the first 2000 members of a team (according to some arbitrary order) will @@ -357,14 +322,12 @@ getTeamMember u tid = do getTeamMembersWithLimit :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Maybe (Range 1 HardTruncationLimit Int32) -> Sem r TeamMemberList getTeamMembersWithLimit tid maxResults = do - debug $ remote "galley" . msg (val "Get team members") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -376,14 +339,12 @@ getTeamMembersWithLimit tid maxResults = do selectTeamMemberInfos :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> [UserId] -> Sem r TeamMemberInfoList selectTeamMemberInfos tid uids = do - debug $ remote "galley" . msg (val "Select team members") let bdy = UserIds uids galleyRequest (req bdy) >>= decodeBodyOrThrow "galley" where @@ -416,13 +377,11 @@ selectTeamMembers tid uids = do getTeamAdmins :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r TeamMemberList getTeamAdmins tid = do - debug $ remote "galley" . msg (val "Get team admins") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -442,17 +401,15 @@ memberIsTeamOwner tid uid = do . paths ["i", "teams", toByteString' tid, "is-team-owner", toByteString' uid] pure $ responseStatus r /= status403 --- | Calls 'Galley.API.getBindingTeamIdH'. +-- | Calls 'Wire.ConversationSubsystem.getBindingTeamIdH'. getTeamId :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> Sem r (Maybe TeamId) getTeamId u = do - debug $ remote "galley" . msg (val "Get team from user") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -463,17 +420,15 @@ getTeamId u = do . paths ["i", "users", toByteString' u, "team"] . expect [status200, status404] --- | Calls 'Galley.API.getTeamInternalH'. +-- | Calls 'Wire.ConversationSubsystem.getTeamInternalH'. getTeam :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r Team.TeamData getTeam tid = do - debug $ remote "galley" . msg (val "Get team info") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -481,17 +436,34 @@ getTeam tid = do . paths ["i", "teams", toByteString' tid] . expect2xx --- | Calls 'Galley.API.getTeamInternalH'. +-- | Like 'getTeam' but returns 'Nothing' on 404 instead of throwing. +findTeam :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r + ) => + TeamId -> + Sem r (Maybe Team.TeamData) +findTeam tid = do + rs <- galleyRequest req + case Bilge.statusCode rs of + 200 -> Just <$> decodeBodyOrThrow "galley" rs + _ -> pure Nothing + where + req = + method GET + . paths ["i", "teams", toByteString' tid] + . expect [status200, status404] + +-- | Calls 'Wire.ConversationSubsystem.getTeamInternalH'. getTeamName :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r Team.TeamName getTeamName tid = do - debug $ remote "galley" . msg (val "Get team info") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -499,17 +471,15 @@ getTeamName tid = do . paths ["i", "teams", toByteString' tid, "name"] . expect2xx --- | Calls 'Galley.API.getTeamFeatureStatusH'. +-- | Calls 'Wire.ConversationSubsystem.getTeamFeatureStatusH'. getTeamLegalHoldStatus :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r (LockableFeature LegalholdConfig) getTeamLegalHoldStatus tid = do - debug $ remote "galley" . msg (val "Get legalhold settings") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -517,18 +487,16 @@ getTeamLegalHoldStatus tid = do . paths ["i", "teams", toByteString' tid, "features", featureNameBS @LegalholdConfig] . expect2xx --- | Calls 'Galley.API.getSearchVisibilityInternalH'. +-- | Calls 'Wire.ConversationSubsystem.getSearchVisibilityInternalH'. getTeamSearchVisibility :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r TeamSearchVisibility getTeamSearchVisibility tid = coerce @TeamSearchVisibilityView @TeamSearchVisibility <$> do - debug $ remote "galley" . msg (val "Get search visibility settings") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -540,14 +508,12 @@ getFeatureConfigForTeam :: forall feature r. ( IsFeatureConfig feature, Typeable feature, - Member TinyLog r, Member Rpc r, Member (Error ParseException) r ) => TeamId -> Sem (Input Endpoint : r) (LockableFeature feature) getFeatureConfigForTeam tid = do - debug $ remote "galley" . msg (val "Get feature config for team") galleyRequest req >>= decodeBodyOrThrow "galley" where req = @@ -558,13 +524,11 @@ getFeatureConfigForTeam tid = do getVerificationCodeEnabled :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Sem r Bool getVerificationCodeEnabled tid = do - debug $ remote "galley" . msg (val "Get snd factor password challenge settings") response <- galleyRequest req status <- (.status) <$> decodeBodyOrThrow @(LockableFeature SndFactorPasswordChallengeConfig) "galley" response case status of @@ -593,12 +557,10 @@ getAllTeamFeaturesForUser mbUserId = getConfiguredFeatureFlags :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => Sem r FeatureFlags getConfiguredFeatureFlags = do - debug $ remote "galley" . msg (val "Getting configured feature flags") responseJsonUnsafe <$> galleyRequest ( method GET @@ -606,18 +568,16 @@ getConfiguredFeatureFlags = do . expect2xx ) --- | Calls 'Galley.API.updateTeamStatusH'. +-- | Calls 'Wire.ConversationSubsystem.updateTeamStatusH'. changeTeamStatus :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> Sem r () changeTeamStatus tid s cur = do - debug $ remote "galley" . msg (val "Change Team status") void $ galleyRequest req where req = @@ -648,13 +608,11 @@ finalizeDeleteTeam lusr mconn tid = do getTeamExposeInvitationURLsToTeamAdmin :: ( Member Rpc r, Member (Input Endpoint) r, - Member (Error ParseException) r, - Member TinyLog r + Member (Error ParseException) r ) => TeamId -> Sem r ShowOrHideInvitationUrl getTeamExposeInvitationURLsToTeamAdmin tid = do - debug $ remote "galley" . msg (val "Get expose invitation URLs to team admin settings") response <- galleyRequest req status <- (.status) <$> decodeBodyOrThrow @(LockableFeature ExposeInvitationURLsToTeamAdminConfig) "galley" response case status of @@ -669,14 +627,12 @@ getTeamExposeInvitationURLsToTeamAdmin tid = do checkMLSOne2OneEstablished :: ( Member (Error ParseException) r, Member (Input Endpoint) r, - Member Rpc r, - Member TinyLog r + Member Rpc r ) => Local UserId -> Qualified UserId -> Sem r MLSOneToOneEstablished checkMLSOne2OneEstablished self (Qualified other otherDomain) = do - debug $ remote "galley" . msg (val "Get the MLS one-to-one conversation") responseSelf <- galleyRequest req case HTTP.statusCode (HTTP.responseStatus responseSelf) of 200 -> do @@ -700,8 +656,7 @@ checkMLSOne2OneEstablished self (Qualified other otherDomain) = do unblockConversation :: ( Member (Error ParseException) r, Member (Input Endpoint) r, - Member Rpc r, - Member TinyLog r + Member Rpc r ) => Version -> Local UserId -> @@ -709,11 +664,6 @@ unblockConversation :: Qualified ConvId -> Sem r OwnConversation unblockConversation v lusr mconn (Qualified cnv cdom) = do - debug $ - remote "galley" - . field "conv" (toByteString cnv) - . field "domain" (toByteString cdom) - . msg (val "Unblocking conversation") void $ galleyRequest putReq galleyRequest getReq >>= decodeBodyOrThrow @OwnConversation "galley" where @@ -734,17 +684,13 @@ remote = field "remote" getEJPDConvInfo :: forall r. - ( Member TinyLog r, - Member (Error ParseException) r, + ( Member (Error ParseException) r, Member (Input Endpoint) r, Member Rpc r ) => UserId -> Sem r [EJPDConvInfo] getEJPDConvInfo uid = do - debug $ - remote "galley" - . msg (val "get conversation info for ejpd") decodeBodyOrThrow "galley" =<< galleyRequest getReq where getReq = @@ -754,16 +700,11 @@ getEJPDConvInfo uid = do internalGetConversation :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => ConvId -> Sem r (Maybe Conversation) internalGetConversation convId = do - debug $ - remote "galley" - . field "conv" (toByteString convId) - . msg (val "Getting conversation (internal)") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -777,16 +718,11 @@ internalGetConversation convId = do getTeamContacts :: ( Member (Error ParseException) r, Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => UserId -> Sem r (Maybe Member.TeamMemberList) getTeamContacts uid = do - debug $ - remote "galley" - . field "user" (toByteString uid) - . msg (val "Getting team contacts") rs <- galleyRequest req case Bilge.statusCode rs of 200 -> Just <$> decodeBodyOrThrow "galley" rs @@ -799,12 +735,10 @@ getTeamContacts uid = do getConversationConfig :: ( Member Rpc r, - Member (Input Endpoint) r, - Member TinyLog r + Member (Input Endpoint) r ) => Sem r ConversationSubsystemConfig getConversationConfig = do - debug $ remote "galley" . msg (val "Getting conversation config") responseJsonUnsafe <$> galleyRequest ( method GET @@ -841,3 +775,84 @@ guardLegalhold protectee userClients = do . paths ["i", "guard-legalhold-policy-conflicts"] . header "Content-Type" "application/json" . lbytes (encode $ GuardLegalholdPolicyConflicts protectee userClients) + +getUserLHStatus :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r + ) => + Maybe TeamId -> + UserId -> + Sem r UserLegalHoldStatus +getUserLHStatus mtid uid = do + debug $ + remote "galley" + . field "user" (toByteString uid) + . msg (val "Get user legalhold status") + galleyRequest req >>= decodeBodyOrThrow "galley" + where + req = + method GET + . paths ["i", "users", toByteString' uid, "lh-status"] + . maybe id (queryItem "team_id" . toByteString') mtid + . expect2xx + +getUsersLHStatus :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r + ) => + [UserId] -> + Sem r [(UserId, UserLegalHoldStatus)] +getUsersLHStatus uids = do + debug $ + remote "galley" + . msg (val "Get users legalhold status") + let bdy = UserIds uids + entries :: [UserLegalHoldStatusEntry] <- galleyRequest (req bdy) >>= decodeBodyOrThrow "galley" + pure $ map (\e -> (e.ulhseUser, e.ulhseStatus)) entries + where + req bdy = + method POST + . paths ["i", "users", "lh-status"] + . header "Content-Type" "application/json" + . lbytes (encode bdy) + . expect2xx + +updateTeamMember :: + ( Member Rpc r, + Member (Input Endpoint) r + ) => + UserId -> + TeamId -> + Role -> + Sem r () +updateTeamMember uid tid role = do + let reqBody = mkNewTeamMember uid (rolePermissions role) Nothing + void $ + galleyRequest $ + method PUT + . paths ["i", "teams", toByteString' tid, "members"] + . header "Content-Type" "application/json" + . lbytes (encode reqBody) + +isEmailValidationEnabledTeam :: + ( Member Rpc r, + Member (Input Endpoint) r + ) => + TeamId -> + Sem r Bool +isEmailValidationEnabledTeam tid = do + rs <- galleyRequest req + pure + ( Bilge.statusCode rs == 200 + && ( ((.status) <$> responseJsonMaybe @(LockableFeature RequireExternalEmailVerificationConfig) rs) + == Just FeatureStatusEnabled + ) + ) + where + req = + method GET + . paths ["i", "teams", toByteString' tid, "features", featureNameBS @RequireExternalEmailVerificationConfig] diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs deleted file mode 100644 index 47985da588c..00000000000 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2025 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 Wire.IndexedUserStore.Bulk where - -import Polysemy -import Wire.UserSearch.Migration - --- | Increase this number any time you want to force reindexing. -expectedMigrationVersion :: MigrationVersion -expectedMigrationVersion = MigrationVersion 6 - --- | Bulk operations, must not be used from any web handler -data IndexedUserStoreBulk m a where - -- | Only changes data if it is not updated since last update, use when users - -- need to be synced because of an outage, or migrating to a new ES instance. - SyncAllUsers :: IndexedUserStoreBulk m () - -- | Overwrite all users in the ES index, use it when trying to fix some - -- inconsistency or while introducing a new field in the mapping. - ForceSyncAllUsers :: IndexedUserStoreBulk m () - -- | Run `ForceSyncAllUsers` iff the index version is out of date. - MigrateData :: IndexedUserStoreBulk m () - -makeSem ''IndexedUserStoreBulk diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs index ed5de07f65c..135ea1e834b 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/Bulk/ElasticSearch.hs @@ -20,93 +20,68 @@ module Wire.IndexedUserStore.Bulk.ElasticSearch where import Cassandra.Exec (paginateWithStateC) import Cassandra.Util (Writetime (Writetime)) import Conduit (ConduitT, runConduit, (.|)) +import Control.Error (headMay) +import Control.Exception (try) +import Control.Monad.Extra (mapMaybeM) import Data.Conduit.Combinators qualified as Conduit +import Data.Conduit.Internal (zipSources) +import Data.Conduit.List qualified as CL import Data.Id import Data.Json.Util (UTCTimeMillis (fromUTCTimeMillis)) import Data.Map qualified as Map import Database.Bloodhound qualified as ES import Imports import Polysemy -import Polysemy.Error +import Polysemy.Error hiding (try) import Polysemy.TinyLog import Polysemy.TinyLog qualified as Log import System.Logger.Message qualified as Log +import UnliftIO (pooledForConcurrentlyN) import Wire.API.Team.Feature import Wire.API.Team.Member.Info import Wire.API.Team.Role import Wire.GalleyAPIAccess import Wire.IndexedUserStore (IndexedUserStore) import Wire.IndexedUserStore qualified as IndexedUserStore -import Wire.IndexedUserStore.Bulk import Wire.IndexedUserStore.MigrationStore import Wire.IndexedUserStore.MigrationStore qualified as MigrationStore -import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe), unsafePooledForConcurrentlyN) import Wire.UserSearch.Migration import Wire.UserSearch.Types import Wire.UserStore import Wire.UserStore.IndexUser -interpretIndexedUserStoreBulk :: - ( Member TinyLog r, - Member UserStore r, - Member (Concurrency Unsafe) r, - Member GalleyAPIAccess r, - Member IndexedUserStore r, - Member (Error MigrationException) r, - Member IndexedUserMigrationStore r - ) => - InterpreterFor IndexedUserStoreBulk r -interpretIndexedUserStoreBulk = interpret \case - SyncAllUsers -> syncAllUsersImpl - ForceSyncAllUsers -> forceSyncAllUsersImpl - MigrateData -> migrateDataImpl - -syncAllUsersImpl :: - forall r. - ( Member UserStore r, - Member TinyLog r, - Member (Concurrency 'Unsafe) r, - Member GalleyAPIAccess r, - Member IndexedUserStore r - ) => - Sem r () -syncAllUsersImpl = syncAllUsersWithVersion ES.ExternalGT - -forceSyncAllUsersImpl :: - forall r. - ( Member UserStore r, - Member TinyLog r, - Member (Concurrency 'Unsafe) r, - Member GalleyAPIAccess r, - Member IndexedUserStore r - ) => - Sem r () -forceSyncAllUsersImpl = syncAllUsersWithVersion ES.ExternalGTE - -syncAllUsersWithVersion :: - forall r. - ( Member UserStore r, - Member TinyLog r, - Member (Concurrency 'Unsafe) r, - Member GalleyAPIAccess r, - Member IndexedUserStore r - ) => - (ES.ExternalDocVersion -> ES.VersionControl) -> - Sem r () -syncAllUsersWithVersion mkVersion = +type IOInterpreter r = forall a. Sem r a -> IO a + +-- | Increase this number any time you want to force reindexing. +expectedMigrationVersion :: MigrationVersion +expectedMigrationVersion = MigrationVersion 6 + +syncAllUsers :: (Member UserStore r, Member IndexedUserStore r, Member TinyLog r, Member GalleyAPIAccess r) => IOInterpreter r -> IO () +syncAllUsers interpreter = syncAllUsersWithVersion interpreter ES.ExternalGT + +forceSyncAllUsers :: (Member UserStore r, Member IndexedUserStore r, Member TinyLog r, Member GalleyAPIAccess r) => IOInterpreter r -> IO () +forceSyncAllUsers interpreter = syncAllUsersWithVersion interpreter ES.ExternalGTE + +syncAllUsersWithVersion :: (Member UserStore r, Member IndexedUserStore r, Member TinyLog r, Member GalleyAPIAccess r) => IOInterpreter r -> (ES.ExternalDocVersion -> ES.VersionControl) -> IO () +syncAllUsersWithVersion interpreter mkVersion = runConduit $ - paginateWithStateC (getIndexUsersPaginated 1000) + zipSources (CL.sourceList [1 ..]) (paginateWithStateC (interpreter . getIndexUsersPaginated pageSize)) .| logPage .| mkUserDocs - .| Conduit.mapM_ IndexedUserStore.bulkUpsert + .| Conduit.mapM_ (interpreter . IndexedUserStore.bulkUpsert) where - logPage :: ConduitT [IndexUser] [IndexUser] (Sem r) () - logPage = Conduit.iterM $ \page -> do - info $ - Log.field "size" (length page) - . Log.msg (Log.val "Reindex: processing C* page") + pageSize = 10000 - mkUserDocs :: ConduitT [IndexUser] [(ES.DocId, UserDoc, ES.VersionControl)] (Sem r) () + logPage :: ConduitT (Int32, [IndexUser]) [IndexUser] IO () + logPage = Conduit.mapM $ \(pageNumber, page) -> do + interpreter $ + info $ + Log.field "estimatedUserSoFar" (length page + fromIntegral (pageSize * pageNumber)) + . Log.msg (Log.val "Received user page") + . Log.field "firstUser" (maybe "N/A" (idToText . (.userId)) (headMay page)) + pure page + + mkUserDocs :: ConduitT [IndexUser] [(ES.DocId, UserDoc, ES.VersionControl)] IO () mkUserDocs = Conduit.mapM $ \page -> do -- FUTUREWORK: extract team visibilities, roles and user type -- more efficiently sending one query per page @@ -117,19 +92,61 @@ syncAllUsersWithVersion mkVersion = let teams :: Map TeamId [IndexUser] = Map.fromListWith (<>) $ mapMaybe (\u -> (,[u]) <$> u.teamId) page teamIds = Map.keys teams - visMap <- fmap Map.fromList . unsafePooledForConcurrentlyN 16 teamIds $ \t -> - (t,) <$> teamSearchVisibilityInbound t - roles :: Map UserId (WithWritetime Role) <- fmap (Map.fromList . concat) . unsafePooledForConcurrentlyN 16 (Map.toList teams) $ \(t, us) -> do - tms <- (.members) <$> selectTeamMemberInfos t (fmap (.userId) us) - pure $ mapMaybe mkRoleWithWriteTime tms - let vis indexUser = fromMaybe defaultSearchVisibilityInbound $ (flip Map.lookup visMap =<< indexUser.teamId) - mkUserDoc indexUser = - indexUserToDoc - (vis indexUser) - ((.value) <$> Map.lookup indexUser.userId roles) - indexUser - mkDocVersion u = mkVersion . ES.ExternalDocVersion . docVersion $ indexUserToVersion (Map.lookup u.userId roles) u - pure $ map (\u -> (userIdToDocId u.userId, mkUserDoc u, mkDocVersion u)) page + + visMap <- fmap Map.fromList . pooledForConcurrentlyN 16 teamIds $ \t -> do + x <- try $ interpreter $ teamSearchVisibilityInbound t + pure (t, x) + + let getRoles :: TeamId -> [UserId] -> IO (Map UserId (Either SomeException (WithWritetime Role))) + getRoles tid uids = do + eithMembers <- try $ interpreter $ (.members) <$> selectTeamMemberInfos tid uids + case eithMembers of + Left e -> do + let lenUids = length uids + if lenUids <= 1 + then pure . Map.fromList $ map (,Left e) uids + else do + let (uids1, uids2) = splitAt (lenUids `div` 2) uids + roles1 <- getRoles tid uids1 + roles2 <- getRoles tid uids2 + pure $ Map.union roles1 roles2 + Right tms -> pure . Map.fromList $ mapMaybe (fmap rightSecond . mkRoleWithWriteTime) tms + + roles :: Map UserId (Either SomeException (WithWritetime Role)) <- + fmap Map.unions . pooledForConcurrentlyN 16 (Map.toList teams) $ \(t, us) -> + getRoles t (fmap (.userId) us) + + let vis :: IndexUser -> Either SomeException SearchVisibilityInbound + vis indexUser = + fromMaybe (Right defaultSearchVisibilityInbound) $ flip Map.lookup visMap =<< indexUser.teamId + + mkUserDoc :: IndexUser -> Either SomeException UserDoc + mkUserDoc indexUser = do + currentVis <- vis indexUser + currentRole <- sequence $ Map.lookup indexUser.userId roles + pure $ indexUserToDoc currentVis ((.value) <$> currentRole) indexUser + + mkDocVersion :: IndexUser -> Either SomeException ES.VersionControl + mkDocVersion u = do + roleWithTime <- sequence (Map.lookup u.userId roles) + pure . mkVersion . ES.ExternalDocVersion . docVersion $ indexUserToVersion roleWithTime u + + let docsWithErrors = map (\u -> (userIdToDocId u.userId, mkUserDoc u, mkDocVersion u)) page + interpreter . flip mapMaybeM docsWithErrors $ logAndHush + + rightSecond :: (a, b) -> (a, Either c b) + rightSecond (a, b) = (a, Right b) + + logAndHush :: (Member TinyLog r) => (ES.DocId, Either SomeException UserDoc, Either SomeException ES.VersionControl) -> Sem r (Maybe (ES.DocId, UserDoc, ES.VersionControl)) + logAndHush (docId@(ES.DocId idText), eithUserDoc, eithVersion) = + case (,) <$> eithUserDoc <*> eithVersion of + Left e -> do + Log.err $ + Log.msg (Log.val "Error ocurred while indexing user") + . Log.field "userId" idText + . Log.field "error" (show e) + pure Nothing + Right (userDoc, version) -> pure $ Just (docId, userDoc, version) mkRoleWithWriteTime :: TeamMemberInfo -> Maybe (UserId, WithWritetime Role) mkRoleWithWriteTime tmi = @@ -143,17 +160,11 @@ syncAllUsersWithVersion mkVersion = ) <$> permissionsToRole tmi.permissions -migrateDataImpl :: - ( Member IndexedUserStore r, - Member (Error MigrationException) r, - Member IndexedUserMigrationStore r, - Member UserStore r, - Member (Concurrency Unsafe) r, - Member GalleyAPIAccess r, - Member TinyLog r - ) => - Sem r () -migrateDataImpl = do +migrateData :: + (Member (Embed IO) r, Member IndexedUserStore r, Member (Error MigrationException) r, Member IndexedUserMigrationStore r, Member TinyLog r, Member UserStore r, Member GalleyAPIAccess r) => + IOInterpreter r -> + IO () +migrateData interpreter = interpreter $ do unlessM IndexedUserStore.doesIndexExist $ throw TargetIndexAbsent MigrationStore.ensureMigrationIndex @@ -164,7 +175,7 @@ migrateDataImpl = do Log.msg (Log.val "Migration necessary.") . Log.field "expectedVersion" expectedMigrationVersion . Log.field "foundVersion" foundVersion - forceSyncAllUsersImpl + embed $ forceSyncAllUsers interpreter MigrationStore.persistMigrationVersion expectedMigrationVersion else do Log.info $ diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs index a4a9a903052..156f8f6e479 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -23,11 +23,13 @@ import Control.Error (lastMay) import Control.Exception (throwIO) import Data.Aeson import Data.Aeson.Key qualified as Key +import Data.Aeson.Types (parseMaybe) import Data.ByteString qualified as LBS import Data.ByteString.Builder import Data.ByteString.Conversion import Data.Id import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as M import Data.Text qualified as Text import Data.Text.Ascii import Data.Text.Encoding qualified as Text @@ -35,6 +37,7 @@ import Database.Bloodhound qualified as ES import Imports import Network.HTTP.Client import Network.HTTP.Types +import Numeric.Natural (Natural) import Polysemy import Wire.API.Team.Role (roleName) import Wire.API.Team.Size (TeamSize (TeamSize)) @@ -81,18 +84,49 @@ getTeamSizeImpl :: TeamId -> Sem r TeamSize getTeamSizeImpl cfg tid = do - let indexName = cfg.conn.indexName - countResEither <- embed $ ES.runBH cfg.conn.env $ ES.countByIndex indexName (ES.CountQuery query) - countRes <- either (liftIO . throwIO . IndexLookupError) pure countResEither - pure . TeamSize $ ES.crCount countRes + r <- embed $ ES.runBH cfg.conn.env $ do + res <- ES.searchByType cfg.conn.indexName mappingName search + liftIO $ ES.parseEsResponse res + result <- either (embed . throwIO . IndexLookupError) pure (r :: Either ES.EsError (ES.SearchResult UserDoc)) + let aggs = fromMaybe mempty (ES.aggregations result) + getCount name = maybe 0 (.filterDocCount) $ M.lookup name aggs >>= parseMaybe (parseJSON @FilterResult) + pure $ TeamSize (getCount "regulars") (getCount "apps") where - query = - ES.TermQuery - ES.Term - { ES.termField = "team", - ES.termValue = idToText tid + teamQ = termQ "team" (idToText tid) + + -- Regular users: type = "regular" or type field absent (legacy documents) + regularQuery = + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustMatch = + [ teamQ, + ES.QueryBoolQuery + boolQuery + { ES.boolQueryShouldMatch = + [ termQ "type" "regular", + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustNotMatch = [ES.QueryExistsQuery (ES.FieldName "type")] + } + ] + } + ] } - Nothing + + appQuery = + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustMatch = [teamQ, termQ "type" "app"] + } + + search = + (ES.mkSearch Nothing Nothing) + { ES.size = ES.Size 0, + ES.aggBody = + Just $ + ES.mkAggregations "regulars" (ES.FilterAgg (ES.FilterAggregation (ES.Filter regularQuery) Nothing)) + <> ES.mkAggregations "apps" (ES.FilterAgg (ES.FilterAggregation (ES.Filter appQuery) Nothing)) + } upsertImpl :: forall r. @@ -647,3 +681,9 @@ mappingName = ES.MappingName "user" boolQuery :: ES.BoolQuery boolQuery = ES.mkBoolQuery [] [] [] [] + +-- | (or can something like this be found in bloodhound?) +newtype FilterResult = FilterResult {filterDocCount :: Natural} + +instance FromJSON FilterResult where + parseJSON = withObject "FilterResult" $ \o -> FilterResult <$> o .: "doc_count" diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore.hs b/libs/wire-subsystems/src/Wire/MeetingsStore.hs index 1c3a5839f31..e2e0c7b55d6 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsStore.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsStore.hs @@ -145,6 +145,9 @@ data MeetingsStore m a where Maybe UTCTime -> Maybe (Maybe Recurrence) -> MeetingsStore m (Maybe StoredMeeting) + DeleteMeeting :: + MeetingId -> + MeetingsStore m () GetMeeting :: MeetingId -> MeetingsStore m (Maybe StoredMeeting) diff --git a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs index e8c1068c7f4..65f8f890626 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsStore/Postgres.hs @@ -36,7 +36,7 @@ import Hasql.Statement import Hasql.TH import Imports import Polysemy -import Polysemy.Error (throw) +import Polysemy.Error (Error, throw) import Polysemy.Input import Wire.API.Meeting (Recurrence) import Wire.API.PostgresMarshall (PostgresMarshall (..), PostgresUnmarshall (..), dimapPG) @@ -53,6 +53,8 @@ interpretMeetingsStoreToPostgres = createMeetingImpl title creator startTime endTime recurrence convId emails trial UpdateMeeting meetingId title startDate endDate schedule -> updateMeetingImpl meetingId title startDate endDate schedule + DeleteMeeting meetingId -> + deleteMeetingImpl meetingId GetMeeting meetingId -> getMeetingImpl meetingId ListMeetingsByUser userId cutoffTime -> @@ -244,6 +246,29 @@ updateMeetingImpl meetingId mTitle mStartDate mEndDate mRecurrence = do created_at :: timestamptz, updated_at :: timestamptz |] +-- * Delete + +deleteMeetingImpl :: + ( Member (Input Pool) r, + Member (Embed IO) r, + Member (Error UsageError) r + ) => + MeetingId -> + Sem r () +deleteMeetingImpl meetingId = do + pool <- input + result <- liftIO $ use pool session + either throw pure result + where + session :: Session () + session = statement (toUUID meetingId) deleteStatement + deleteStatement :: Statement UUID () + deleteStatement = + [resultlessStatement| + DELETE FROM meetings + WHERE id = ($1 :: uuid) + |] + -- * Get getMeetingImpl :: diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs index 0aaf4a02883..8a126f1be0b 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem.hs @@ -37,6 +37,11 @@ data MeetingsSubsystem m a where Qualified MeetingId -> UpdateMeeting -> MeetingsSubsystem m (Maybe Meeting) + DeleteMeeting :: + Local UserId -> + ConnId -> + Qualified MeetingId -> + MeetingsSubsystem m Bool GetMeeting :: Local UserId -> Qualified MeetingId -> diff --git a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs index 45d06de2cae..a37eb03b338 100644 --- a/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/MeetingsSubsystem/Interpreter.hs @@ -26,7 +26,7 @@ import Data.Default (def) import Data.Domain (Domain) import Data.Id import Data.Map qualified as Map -import Data.Qualified (Local, Qualified (..), tDomain, tUnqualified) +import Data.Qualified (Local, Qualified (..), qualifyAs, tDomain, tUnqualified) import Data.Range (Range, unsafeRange) import Data.Set qualified as Set import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime) @@ -37,7 +37,7 @@ import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.Meeting qualified as API import Wire.API.Routes.MultiTablePaging qualified as MultiTablePaging -import Wire.API.Team.Feature (FeatureStatus (..), LockableFeature (..), MeetingsPremiumConfig) +import Wire.API.Team.Feature (FeatureStatus (..), LockableFeature (..), MeetingsConfig, MeetingsPremiumConfig) import Wire.API.User (BaseProtocolTag (BaseProtocolMLSTag), EmailAddress) import Wire.ConversationSubsystem (ConversationSubsystem) import Wire.ConversationSubsystem qualified as ConversationSubsystem @@ -50,9 +50,23 @@ import Wire.StoredConversation import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem -data MeetingError = InvalidTimes | EmptyUpdate +data MeetingError = InvalidTimes | EmptyUpdate | MeetingsFeatureDisabled deriving stock (Eq, Show) +checkMeetingsEnabled :: + ( Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r + ) => + Maybe TeamId -> + Sem r () +checkMeetingsEnabled maybeTeamId = do + case maybeTeamId of + Nothing -> pure () + Just teamId -> do + meetingFeature <- getFeatureForTeam @_ @MeetingsConfig teamId + unless (meetingFeature.status == FeatureStatusEnabled) $ + throw MeetingsFeatureDisabled + interpretMeetingsSubsystem :: ( Member Store.MeetingsStore r, Member ConversationSubsystem r, @@ -68,6 +82,8 @@ interpretMeetingsSubsystem validityPeriod = interpret $ \case createMeetingImpl zUser newMeeting UpdateMeeting zUser meetingId update -> updateMeetingImpl zUser meetingId update validityPeriod + DeleteMeeting zUser connId meetingId -> + deleteMeetingImpl zUser connId meetingId validityPeriod GetMeeting zUser meetingId -> getMeetingImpl zUser meetingId validityPeriod ListMeetings zUser -> @@ -88,12 +104,14 @@ createMeetingImpl :: API.NewMeeting -> Sem r (API.Meeting, StoredConversation) createMeetingImpl zUser newMeeting = do + -- Look up user's team once and reuse for both checks + conversationTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled conversationTeamId -- Validate that endTime > startTime when (newMeeting.endTime <= newMeeting.startTime) $ throw InvalidTimes -- Determine trial status based on team membership and premium feature - conversationTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) trial <- case conversationTeamId of Nothing -> pure True -- Personal users create trial meetings Just teamId -> do @@ -122,7 +140,7 @@ createMeetingImpl zUser newMeeting = do } -- Create and store the conversation via ConversationSubsystem - storedConv <- ConversationSubsystem.createGroupConversation zUser Nothing newConv + storedConv <- ConversationSubsystem.internalCreateGroupConversation zUser Nothing newConv -- Store meeting (trial status is provided by caller) storedMeeting <- @@ -144,6 +162,8 @@ createMeetingImpl zUser newMeeting = do updateMeetingImpl :: ( Member Store.MeetingsStore r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, Member (Error MeetingError) r, Member Now r ) => @@ -153,6 +173,8 @@ updateMeetingImpl :: NominalDiffTime -> Sem r (Maybe API.Meeting) updateMeetingImpl zUser meetingId update validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId when (isNothing update.title && isNothing update.startTime && isNothing update.endTime && isNothing update.recurrence) $ throw EmptyUpdate @@ -177,9 +199,46 @@ updateMeetingImpl zUser meetingId update validityPeriod = do update.recurrence pure $ storedMeetingToMeeting (tDomain zUser) updatedMeeting +deleteMeetingImpl :: + ( Member Store.MeetingsStore r, + Member ConversationSubsystem r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r, + Member Now r + ) => + Local UserId -> + ConnId -> + Qualified MeetingId -> + NominalDiffTime -> + Sem r Bool +deleteMeetingImpl zUser connId meetingId validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId + result <- + runMaybeT $ do + meeting <- MaybeT $ Store.getMeeting (qUnqualified meetingId) + now <- lift Now.get + let cutoff = addUTCTime (negate validityPeriod) now + guard $ meeting.endTime >= cutoff + guard $ qDomain meetingId == tDomain zUser + guard $ meeting.creator == tUnqualified zUser + let convId = meeting.conversationId + lConvId = qualifyAs zUser convId + conv <- MaybeT $ ConversationSubsystem.internalGetConversation convId + when (conv.metadata.cnvmGroupConvType == Just MeetingConversation) $ + lift $ + void $ + ConversationSubsystem.deleteLocalConversation zUser connId lConvId + lift $ Store.deleteMeeting (qUnqualified meetingId) + pure $ isJust result + getMeetingImpl :: ( Member Store.MeetingsStore r, Member ConversationSubsystem r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r, Member Now r ) => Local UserId -> @@ -187,6 +246,8 @@ getMeetingImpl :: NominalDiffTime -> Sem r (Maybe API.Meeting) getMeetingImpl zUser meetingId validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId -- Get meeting from store runMaybeT $ do storedMeeting <- MaybeT $ Store.getMeeting (qUnqualified meetingId) @@ -224,12 +285,17 @@ storedMeetingToMeeting domain sm = listMeetingsImpl :: ( Member Store.MeetingsStore r, Member ConversationSubsystem r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r, Member Now r ) => Local UserId -> NominalDiffTime -> Sem r [API.Meeting] listMeetingsImpl zUser validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId now <- Now.get let cutoff = addUTCTime (negate validityPeriod) now -- List all meetings created by the user @@ -288,6 +354,9 @@ getAllMemberMeetings zUser cutoff = do addInvitedEmailsImpl :: ( Member Store.MeetingsStore r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r, Member Now r ) => Local UserId -> @@ -296,6 +365,8 @@ addInvitedEmailsImpl :: NominalDiffTime -> Sem r Bool addInvitedEmailsImpl zUser meetingId emails validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId result <- runMaybeT $ do storedMeeting <- MaybeT $ Store.getMeeting (qUnqualified meetingId) @@ -310,6 +381,9 @@ addInvitedEmailsImpl zUser meetingId emails validityPeriod = do removeInvitedEmailsImpl :: ( Member Store.MeetingsStore r, + Member TeamSubsystem r, + Member FeaturesConfigSubsystem r, + Member (Error MeetingError) r, Member Now r ) => Local UserId -> @@ -318,6 +392,8 @@ removeInvitedEmailsImpl :: NominalDiffTime -> Sem r Bool removeInvitedEmailsImpl zUser meetingId emails validityPeriod = do + maybeTeamId <- TeamSubsystem.internalGetOneUserTeam (tUnqualified zUser) + checkMeetingsEnabled maybeTeamId result <- runMaybeT $ do storedMeeting <- MaybeT $ Store.getMeeting (qUnqualified meetingId) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index c93258449c8..adb170507d4 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -23,7 +23,6 @@ import Data.Aeson import Data.Id import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty -import Data.Proxy import Data.Range import Data.Set qualified as Set import Data.Time.Clock.DiffTime @@ -38,6 +37,7 @@ import Polysemy.TinyLog qualified as P import System.Logger.Class as Log import Wire.API.Push.V2 hiding (Push (..), Recipient, newPush) import Wire.API.Push.V2 qualified as V2 +import Wire.API.Team.FeatureFlags (defaultFanoutLimit) import Wire.API.Team.HardTruncationLimit (HardTruncationLimit) import Wire.GundeckAPIAccess (GundeckAPIAccess) import Wire.GundeckAPIAccess qualified as GundeckAPIAccess @@ -75,9 +75,6 @@ defaultNotificationSubsystemConfig :: RequestId -> NotificationSubsystemConfig defaultNotificationSubsystemConfig reqId = NotificationSubsystemConfig defaultFanoutLimit defaultChunkSize defaultSlowPushDelay reqId -defaultFanoutLimit :: Range 1 HardTruncationLimit Int32 -defaultFanoutLimit = toRange (Proxy @HardTruncationLimit) - defaultChunkSize :: Natural defaultChunkSize = 128 diff --git a/libs/wire-subsystems/src/Wire/Options/Galley.hs b/libs/wire-subsystems/src/Wire/Options/Galley.hs index 8383ee97e4f..6b30fff0976 100644 --- a/libs/wire-subsystems/src/Wire/Options/Galley.hs +++ b/libs/wire-subsystems/src/Wire/Options/Galley.hs @@ -56,21 +56,22 @@ module Wire.Options.Galley logNetStrings, logFormat, guestLinkTTLSeconds, - defGuestLinkTTLSeconds, passwordHashingOptions, passwordHashingRateLimit, checkGroupInfo, meetings, validityPeriod, postgresMigration, - GuestLinkTTLSeconds (..), PostgresMigrationOpts (..), StorageLocation (..), + GuestLinkTTLSeconds (..), + defGuestLinkTTLSeconds, + conversationCodeURISettings, ) where import Control.Lens hiding (Level, (.=)) -import Data.Aeson +import Data.Aeson (FromJSON (..)) import Data.Aeson.TH (deriveFromJSON) import Data.Domain (Domain) import Data.Id (TeamId) @@ -86,7 +87,7 @@ import Wire.API.Conversation.Protocol import Wire.API.Routes.Version import Wire.API.Team.FeatureFlags import Wire.API.Team.Member -import Wire.Options.Keys +import Wire.Options.Keys (MLSPrivateKeyPaths) import Wire.PostgresMigrationOpts import Wire.RateLimit.Interpreter (RateLimitConfig) @@ -102,6 +103,10 @@ instance FromJSON GuestLinkTTLSeconds where then pure $ GuestLinkTTLSeconds n else fail "GuestLinkTTLSeconds must be in (0, 31536000]" +-- | Default guest link TTL in days. 365 days if not set. +defGuestLinkTTLSeconds :: GuestLinkTTLSeconds +defGuestLinkTTLSeconds = GuestLinkTTLSeconds $ 60 * 60 * 24 * 365 -- 1 year + data Settings = Settings { -- | Number of connections for the HTTP client pool _httpPoolSize :: !Int, @@ -184,10 +189,6 @@ makeLenses ''MeetingsConfig defConcurrentDeletionEvents :: Int defConcurrentDeletionEvents = 128 --- | Default guest link TTL in days. 365 days if not set. -defGuestLinkTTLSeconds :: GuestLinkTTLSeconds -defGuestLinkTTLSeconds = GuestLinkTTLSeconds $ 60 * 60 * 24 * 365 -- 1 year - data JournalOpts = JournalOpts { -- | SQS queue name to send team events _queueName :: !Text, @@ -241,3 +242,13 @@ data Opts = Opts deriveFromJSON toOptionFieldName ''Opts makeLenses ''Opts + +conversationCodeURISettings :: (Applicative m) => Opts -> m (Either HttpsUrl (Map Text HttpsUrl)) +conversationCodeURISettings opts = + case (opts._settings._conversationCodeURI, opts._settings._multiIngress) of + (Nothing, Nothing) -> error errMsg + (Nothing, Just mi) -> pure (Right mi) + (Just uri, Nothing) -> pure (Left uri) + (Just _, Just _) -> error errMsg + where + errMsg = "Either conversationCodeURI or multiIngress needs to be set." diff --git a/libs/wire-subsystems/src/Wire/ParseException.hs b/libs/wire-subsystems/src/Wire/ParseException.hs index 525fe80cfb5..1d836548ddf 100644 --- a/libs/wire-subsystems/src/Wire/ParseException.hs +++ b/libs/wire-subsystems/src/Wire/ParseException.hs @@ -15,6 +15,8 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +-- | See also: "Wire.RpcException" (some of the uses of ParseException +-- should probably be RpcExceptions instead). module Wire.ParseException where import Data.Text qualified as Text diff --git a/libs/wire-subsystems/src/Wire/PostgresMigrations.hs b/libs/wire-subsystems/src/Wire/PostgresMigrations.hs index df3313ccc76..9681b98bd30 100644 --- a/libs/wire-subsystems/src/Wire/PostgresMigrations.hs +++ b/libs/wire-subsystems/src/Wire/PostgresMigrations.hs @@ -22,17 +22,27 @@ module Wire.PostgresMigrations where import Control.Exception import Data.FileEmbed +import Data.Hashable qualified as Hashable +import Data.Set qualified as Set import Hasql.Migration import Hasql.Pool import Hasql.Session +import Hasql.Session qualified as Session +import Hasql.Statement qualified as Hasql +import Hasql.TH import Hasql.Transaction.Sessions import Imports import System.Logger (Logger) import System.Logger qualified as Log +import UnliftIO.Retry allMigrations :: [MigrationCommand] allMigrations = map (uncurry MigrationScript) $(makeRelativeToProject "postgres-migrations" >>= embedDir) +-- | Scripts which cannot be run in a transaction +nonTransactionMigrations :: Set ScriptName +nonTransactionMigrations = Set.fromList ["20260428072649-create-conv-parent-index.sql"] + data PostgresMigrationError = PostgresMigrationError MigrationError deriving (Show) @@ -42,15 +52,53 @@ runAllMigrations :: Pool -> Logger -> IO () runAllMigrations pool logger = do let session = do Log.info logger $ Log.msg (Log.val "Running migrations") - transaction Serializable Write $ do - forM_ (MigrationInitialization : allMigrations) $ \migrationCmd -> do - mErr <- runMigration migrationCmd - case mErr of - Nothing -> pure () - Just err -> throw $ PostgresMigrationError err + forM_ (MigrationInitialization : allMigrations) $ \migrationCmd -> do + mErr <- + case migrationScriptName migrationCmd of + (Just name) + | name `Set.member` nonTransactionMigrations -> + -- Locking the migration makes sure that only one process is + -- running this migration at a time. Without this `CREATE + -- INDEX CONCURRENTLY` can deadlock with other processes + -- causing a silent failure. + withLock name $ runMigrationWithoutTransactions migrationCmd + _ -> + transaction Serializable Write $ runMigration migrationCmd + + case mErr of + Nothing -> pure () + Just err -> throw $ PostgresMigrationError err Log.info logger $ Log.msg (Log.val "Migrations completed successfully") either throwIO pure =<< use pool session + where + -- We must use `try` instead of blocking on the lock because running `CREATE + -- INDEX CONCURRENTLY` requires all transactions to be complete and blocking + -- on the lock causes an implicit transaction to be blocked, which means we + -- would end up in a deadlock. + tryLockNonTransactionMigration :: Hasql.Statement Int64 Bool + tryLockNonTransactionMigration = + [singletonStatement|SELECT (pg_try_advisory_lock($1 :: bigint) :: bool)|] + + unlockNonTransactionMigration :: Hasql.Statement Int64 () + unlockNonTransactionMigration = + [resultlessStatement|SELECT (1 :: integer) FROM (SELECT pg_advisory_unlock($1 :: bigint))|] + + -- We don't have to use 'bracket' here because failing in the session should + -- cause the session to drop and any acquired locks get automatically + -- released. + withLock :: ScriptName -> Session a -> Session a + withLock name migration = do + let lockId = fromIntegral $ Hashable.hash name + + void . retrying (constantDelay 1_000_000) (const $ pure . not) $ \_ -> + Session.statement lockId tryLockNonTransactionMigration + + migRes <- migration + + Session.statement lockId unlockNonTransactionMigration + + pure migRes migrationName :: MigrationCommand -> (Log.Msg -> Log.Msg) migrationName = \case @@ -58,6 +106,12 @@ migrationName = \case MigrationScript name _ -> Log.field "migration" name MigrationValidation cmd -> Log.field "type" ("validation" :: ByteString) . migrationName cmd +migrationScriptName :: MigrationCommand -> Maybe ScriptName +migrationScriptName = \case + MigrationScript name _ -> Just name + MigrationInitialization -> Nothing + MigrationValidation _ -> Nothing + -- | Only to be used to reset the development DB resetSchema :: Pool -> Logger -> IO () resetSchema pool logger = do diff --git a/libs/wire-subsystems/src/Wire/RpcException.hs b/libs/wire-subsystems/src/Wire/RpcException.hs new file mode 100644 index 00000000000..04a28a63a24 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/RpcException.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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 . + +-- | See also: "Wire.ParseException" +module Wire.RpcException where + +import Bilge +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as Text +import Data.Text.Encoding (decodeUtf8) +import Data.Text.Lazy qualified as LText +import Imports +import Network.HTTP.Types.Status qualified as Http +import Network.Wai.Utilities.Error qualified as Wai +import Polysemy +import Polysemy.Error + +data RpcException + = RpcExceptionWai + { service :: Text, + waiError :: Wai.Error + } + | RpcExceptionInternal + { service :: Text, + status :: Int, + message :: Text + } + deriving (Eq, Show) + +instance Exception RpcException + +rpcExcepctionToWaiError :: RpcException -> Wai.Error +rpcExcepctionToWaiError (RpcExceptionWai {..}) = + waiError {Wai.message = "[" <> LText.fromStrict service <> "] " <> (Wai.message waiError)} +rpcExcepctionToWaiError (RpcExceptionInternal {..}) = + Wai.mkError + Http.status502 + "internal-error" + ( LText.fromStrict $ + "Could not parse " + <> service + <> " response body: " + <> message + <> " (status: " + <> Text.pack (show status) + <> ")" + ) + +-- | If a call to another backend service fails, just respond with whatever it said. +rethrow :: (HasCallStack, Member (Error RpcException) r) => Text -> ResponseLBS -> Sem r a +rethrow serviceName resp = throw err + where + err :: RpcException + err = maybe fallback (RpcExceptionWai serviceName) (responseJsonMaybe resp) + + fallback :: RpcException + fallback = RpcExceptionInternal serviceName (Bilge.statusCode resp) (maybe "" (decodeUtf8 . LBS.toStrict) (responseBody resp)) diff --git a/libs/wire-subsystems/src/Wire/StoredConversation.hs b/libs/wire-subsystems/src/Wire/StoredConversation.hs index 5af3bb2bac0..1fdbe37284e 100644 --- a/libs/wire-subsystems/src/Wire/StoredConversation.hs +++ b/libs/wire-subsystems/src/Wire/StoredConversation.hs @@ -30,9 +30,11 @@ import Data.Time (UTCTime) import Data.UUID.Tagged qualified as U import Imports import Wire.API.Conversation +import Wire.API.Conversation qualified as Public import Wire.API.Conversation.CellsState import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role +import Wire.API.Federation.API.Galley import Wire.API.History import Wire.API.MLS.CipherSuite import Wire.API.MLS.Group.Serialisation qualified as MLS @@ -352,6 +354,135 @@ defAccess One2OneConv (Just []) = [PrivateAccess] defAccess RegularConv (Just []) = defRegularConvAccess defAccess _ (Just xs@(_ : _)) = xs +-- MAPPING ------------------------------------------------------------------- + +-- | View for a given user of a stored conversation. +-- +-- Throws @BadMemberState@ when the user is not part of the conversation. +ownConversationView :: + Local UserId -> + StoredConversation -> + Maybe OwnConversation +ownConversationView luid conv = do + let remoteOthers = map remoteMemberToOther $ conv.remoteMembers + localOthers = map (localMemberToOther (tDomain luid)) $ conv.localMembers + conversationViewWithCachedOthers remoteOthers localOthers conv luid + +conversationView :: + Local x -> + Maybe (Local UserId) -> + StoredConversation -> + Conversation +conversationView l luid conv = + let remoteMembers = map remoteMemberToOther $ conv.remoteMembers + localMembers = map (localMemberToOther (tDomain l)) $ conv.localMembers + selfs = filter (\m -> fmap tUnqualified luid == Just m.id_) (conv.localMembers) + mSelf = localMemberToPublic l <$> listToMaybe selfs + others = filter (\oth -> (tUntagged <$> luid) /= Just (omQualifiedId oth)) localMembers <> remoteMembers + in Conversation + { members = ConvMembers mSelf others, + qualifiedId = (tUntagged . qualifyAs l $ conv.id_), + metadata = conv.metadata, + protocol = conv.protocol + } + +-- | Like 'conversationView' but optimized for situations which could benefit +-- from pre-computing the list of @OtherMember@s in the conversation. For +-- instance, creating @ConversationView@ for more than 1 member of the same conversation. +conversationViewWithCachedOthers :: + [OtherMember] -> + [OtherMember] -> + StoredConversation -> + Local UserId -> + Maybe OwnConversation +conversationViewWithCachedOthers remoteOthers localOthers conv luid = do + conversationViewMaybe luid remoteOthers localOthers conv + +-- | View for a given user of a stored conversation. +-- +-- Returns 'Nothing' if the user is not part of the conversation. +conversationViewMaybe :: Local UserId -> [OtherMember] -> [OtherMember] -> StoredConversation -> Maybe OwnConversation +conversationViewMaybe luid remoteOthers localOthers conv = do + let selfs = filter (\m -> tUnqualified luid == m.id_) conv.localMembers + self <- localMemberToPublic luid <$> listToMaybe selfs + let others = filter (\oth -> tUntagged luid /= omQualifiedId oth) localOthers <> remoteOthers + pure $ + OwnConversation + (tUntagged . qualifyAs luid $ conv.id_) + conv.metadata + (OwnConvMembers self others) + conv.protocol + +-- | View for a local user of a remote conversation. +remoteConversationView :: + Local UserId -> + MemberStatus -> + Remote RemoteConversationView -> + OwnConversation +remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = + let mems = rconv.members + others = mems.others + self = + localMemberToPublic + uid + LocalMember + { id_ = tUnqualified uid, + service = Nothing, + status = status, + convRoleName = mems.selfRole + } + in OwnConversation + (Qualified rconv.id rDomain) + rconv.metadata + (OwnConvMembers self others) + rconv.protocol + +-- | Convert a local conversation member (as stored in the DB) to a publicly +-- facing 'Member' structure. +localMemberToPublic :: Local x -> LocalMember -> Public.Member +localMemberToPublic loc lm = + Public.Member + { memId = tUntagged . qualifyAs loc $ lm.id_, + memService = lm.service, + memOtrMutedStatus = msOtrMutedStatus st, + memOtrMutedRef = msOtrMutedRef st, + memOtrArchived = msOtrArchived st, + memOtrArchivedRef = msOtrArchivedRef st, + memHidden = msHidden st, + memHiddenRef = msHiddenRef st, + memConvRoleName = lm.convRoleName + } + where + st = lm.status + +-- | Convert a local conversation to a structure to be returned to a remote +-- backend. +-- +-- This returns 'Nothing' if the given remote user is not part of the conversation. +conversationToRemote :: + Domain -> + Remote UserId -> + StoredConversation -> + Maybe RemoteConversationView +conversationToRemote localDomain ruid conv = do + let (selfs, rothers) = partition (\r -> r.id_ == ruid) (conv.remoteMembers) + lothers = conv.localMembers + selfRole' <- (.convRoleName) <$> listToMaybe selfs + let others' = + map (localMemberToOther localDomain) lothers + <> map remoteMemberToOther rothers + pure $ + RemoteConversationView + { id = conv.id_, + metadata = conv.metadata, + members = + RemoteConvMembers + { selfRole = selfRole', + others = others' + }, + protocol = conv.protocol + } + -- BotMember ------------------------------------------------------------------ -- | For now we assume bots to always be local diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index c42d8c58d1e..d7e7b9e4682 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -286,7 +286,7 @@ logInvitationRequest context action = -- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). -- --- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. +-- There is some code duplication with 'Wire.ConversationSubsystem.Teams.ensureNotElevated'. ensurePermissionToAddUser :: ( Member (Error TeamInvitationSubsystemError) r, Member TeamSubsystem r diff --git a/libs/wire-subsystems/src/Wire/TeamJournal.hs b/libs/wire-subsystems/src/Wire/TeamJournal.hs index c8e6ba64a00..9ae5ec1044a 100644 --- a/libs/wire-subsystems/src/Wire/TeamJournal.hs +++ b/libs/wire-subsystems/src/Wire/TeamJournal.hs @@ -27,11 +27,11 @@ import Data.ProtoLens (defMessage) import Data.Text (pack) import Data.Time.Clock.POSIX import Imports hiding (head) -import Numeric.Natural import Polysemy import Proto.TeamEvents (TeamEvent, TeamEvent'EventData, TeamEvent'EventType (..)) import Proto.TeamEvents_Fields qualified as T import Wire.API.Team (TeamCreationTime (..)) +import Wire.API.Team.Size import Wire.Sem.Now import Wire.Sem.Now qualified as Now import Wire.TeamStore @@ -52,7 +52,7 @@ teamActivate :: Member TeamJournal r ) => TeamId -> - Natural -> + TeamSize -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> Sem r () @@ -65,7 +65,7 @@ teamUpdate :: Member TeamJournal r ) => TeamId -> - Natural -> + TeamSize -> [UserId] -> Sem r () teamUpdate tid teamSize billingUserIds = @@ -111,9 +111,15 @@ journalEvent typ tid dat tim = do ---------------------------------------------------------------------------- -- utils -evData :: Natural -> [UserId] -> Maybe Currency.Alpha -> TeamEvent'EventData -evData memberCount billingUserIds cur = +evData :: TeamSize -> [UserId] -> Maybe Currency.Alpha -> TeamEvent'EventData +evData teamSize@(TeamSize regulars apps) billingUserIds cur = defMessage - & T.memberCount .~ fromIntegral memberCount + & T.memberCount .~ memberCountTotal & T.billingUser .~ (toBytes <$> billingUserIds) & T.maybe'currency .~ (pack . show <$> cur) + & T.memberCountRegular .~ memberCountRegulars + & T.memberCountApp .~ memberCountApps + where + memberCountTotal, memberCountRegulars, memberCountApps :: Int32 + (memberCountTotal, memberCountRegulars, memberCountApps) = + (fromIntegral $ teamSizeTotal teamSize, fromIntegral regulars, fromIntegral apps) diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem.hs index 7c7213aee72..cd4fa9a7cac 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem.hs @@ -20,13 +20,30 @@ module Wire.TeamSubsystem where import Data.Id +import Data.LegalHold +import Data.Map qualified as Map import Data.Qualified import Data.Range +import Data.Singletons (Demote, Sing, SingKind, fromSing) import Imports import Polysemy +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Team.LegalHold (UserLegalHoldStatusResponse) import Wire.API.Team.Member +import Wire.API.Team.Member.Error import Wire.API.Team.Member.Info (TeamMemberInfoList) +data PermissionCheckArgs teamAssociation where + PermissionCheckArgs :: + forall k (p :: k) teamAssociation. + ( SingKind k, + IsPerm teamAssociation (Demote k) + ) => + Sing p -> + Maybe teamAssociation -> + PermissionCheckArgs teamAssociation + data TeamSubsystem m a where InternalGetTeamMember :: UserId -> TeamId -> TeamSubsystem m (Maybe TeamMember) InternalGetTeamMembersWithLimit :: TeamId -> Maybe (Range 1 HardTruncationLimit Int32) -> TeamSubsystem m TeamMemberList @@ -35,5 +52,95 @@ data TeamSubsystem m a where InternalGetTeamAdmins :: TeamId -> TeamSubsystem m TeamMemberList InternalGetOneUserTeam :: UserId -> TeamSubsystem m (Maybe TeamId) InternalFinalizeDeleteTeam :: Local UserId -> Maybe ConnId -> TeamId -> TeamSubsystem m () + GetUserStatus :: + Local UserId -> + TeamId -> + UserId -> + TeamSubsystem m UserLegalHoldStatusResponse + GetTeamMembersForFanout :: + TeamId -> + TeamSubsystem m TeamMemberList + AssertTeamExists :: + TeamId -> + TeamSubsystem m () + GetLHStatusForUsers :: + [UserId] -> + TeamSubsystem m [(UserId, UserLegalHoldStatus)] + GetLHStatus :: + Maybe TeamId -> + UserId -> + TeamSubsystem m UserLegalHoldStatus makeSem ''TeamSubsystem + +assertOnTeam :: + ( Member (ErrorS 'NotATeamMember) r, + Member TeamSubsystem r + ) => + UserId -> + TeamId -> + Sem r () +assertOnTeam uid tid = + internalGetTeamMember uid tid >>= \case + Nothing -> throwS @'NotATeamMember + Just _ -> pure () + +-- | 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 teamAssociation perm, + ( Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r + ) + ) => + perm -> + Maybe teamAssociation -> + Sem r teamAssociation +-- FUTUREWORK: factor `noteS` out of this function. +permissionCheck p = \case + Just m -> do + if m `hasPermission` p + then pure m + else throwS @OperationDenied + -- FUTUREWORK: factor `noteS` out of this function. + Nothing -> throwS @'NotATeamMember + +-- | Same as 'permissionCheck', but for a statically known permission. +permissionCheckS :: + forall teamAssociation perm (p :: perm) r. + ( SingKind perm, + IsPerm teamAssociation (Demote perm), + ( Member (ErrorS (PermError p)) r, + Member (ErrorS 'NotATeamMember) r + ) + ) => + Sing p -> + Maybe teamAssociation -> + Sem r teamAssociation +permissionCheckS p = + \case + Just m -> do + if m `hasPermission` fromSing p + then pure m + else throwS @(PermError p) + -- FUTUREWORK: factor `noteS` out of this function. + Nothing -> throwS @'NotATeamMember + +data ConsentGiven = ConsentGiven | ConsentNotGiven + deriving (Eq, Ord, Show) + +consentGiven :: UserLegalHoldStatus -> ConsentGiven +consentGiven = \case + UserLegalHoldDisabled -> ConsentGiven + UserLegalHoldPending -> ConsentGiven + UserLegalHoldEnabled -> ConsentGiven + UserLegalHoldNoConsent -> ConsentNotGiven + +checkConsent :: + (Member TeamSubsystem r) => + Map UserId TeamId -> + UserId -> + Sem r ConsentGiven +checkConsent teamsOfUsers other = do + consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs index 0f4e4342cc7..31ff34a8863 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem/GalleyAPI.hs @@ -19,11 +19,18 @@ module Wire.TeamSubsystem.GalleyAPI where import Imports import Polysemy +import Wire.API.Error +import Wire.API.Error.Galley import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.TeamSubsystem -interpretTeamSubsystemToGalleyAPI :: (Member GalleyAPIAccess r) => InterpreterFor TeamSubsystem r +interpretTeamSubsystemToGalleyAPI :: + ( Member GalleyAPIAccess r, + Member (ErrorS 'TeamMemberNotFound) r, + Member (ErrorS 'TeamNotFound) r + ) => + InterpreterFor TeamSubsystem r interpretTeamSubsystemToGalleyAPI = interpret $ \case InternalGetTeamMember userId teamId -> GalleyAPIAccess.getTeamMember userId teamId InternalGetTeamMembersWithLimit teamId maxResults -> GalleyAPIAccess.getTeamMembersWithLimit teamId maxResults @@ -32,3 +39,17 @@ interpretTeamSubsystemToGalleyAPI = interpret $ \case InternalGetTeamAdmins teamId -> GalleyAPIAccess.getTeamAdmins teamId InternalGetOneUserTeam userId -> GalleyAPIAccess.getTeamId userId InternalFinalizeDeleteTeam lusr mcon teamId -> GalleyAPIAccess.finalizeDeleteTeam lusr mcon teamId + GetUserStatus lusr tid uid -> do + GalleyAPIAccess.getTeamMember uid tid >>= \case + Nothing -> throwS @'TeamMemberNotFound + Just _ -> do + GalleyAPIAccess.getUserLegalholdStatus lusr tid >>= \case + Nothing -> throwS @'TeamNotFound + Just status -> pure status + GetTeamMembersForFanout tid -> + GalleyAPIAccess.getTeamMembersWithLimit tid Nothing + AssertTeamExists tid -> do + found <- isJust <$> GalleyAPIAccess.findTeam tid + unless found $ throwS @'TeamNotFound + GetLHStatusForUsers uids -> GalleyAPIAccess.getUsersLHStatus uids + GetLHStatus mtid uid -> GalleyAPIAccess.getUserLHStatus mtid uid diff --git a/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs index 749bfd978d3..f598ec35d74 100644 --- a/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamSubsystem/Interpreter.hs @@ -18,22 +18,34 @@ module Wire.TeamSubsystem.Interpreter where import Control.Lens (view, (%~), (^.)) +import Data.ByteString.Conversion (toByteString') import Data.Default import Data.Id import Data.Json.Util -import Data.LegalHold (UserLegalHoldStatus (..)) +import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Extra qualified as List import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map qualified as Map import Data.Qualified import Data.Time +import Galley.Types.Error import Imports import Polysemy +import Polysemy.Error import Polysemy.Input +import Polysemy.TinyLog qualified as P +import System.Logger.Class qualified as Log +import Wire.API.Error +import Wire.API.Error.Galley import Wire.API.Event.Conversation qualified as Conv import Wire.API.Event.Team +import Wire.API.Team.FeatureFlags (FanoutLimit) import Wire.API.Team.HardTruncationLimit +import Wire.API.Team.LegalHold +import Wire.API.Team.LegalHold qualified as Public import Wire.API.Team.Member import Wire.API.Team.Member.Info (TeamMemberInfoList (TeamMemberInfoList)) +import Wire.API.User.Client.Prekey import Wire.BrigAPIAccess import Wire.BrigAPIAccess qualified as Brig import Wire.ConversationStore @@ -42,6 +54,7 @@ import Wire.ExternalAccess import Wire.ExternalAccess qualified as ExternalAccess import Wire.LegalHoldStore (LegalHoldStore) import Wire.LegalHoldStore qualified as LH +import Wire.LegalHoldStore qualified as LegalHoldData import Wire.NotificationSubsystem import Wire.Sem.Now import Wire.Sem.Now qualified as Now @@ -65,7 +78,12 @@ interpretTeamSubsystem :: Member Now r, Member SparAPIAccess r, Member ConversationStore r, - Member TeamJournal r + Member TeamJournal r, + Member (Input FanoutLimit) r, + Member (Error InternalError) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'TeamMemberNotFound) r, + Member P.TinyLog r ) => TeamSubsystemConfig -> InterpreterFor TeamSubsystem r @@ -79,23 +97,23 @@ interpretTeamSubsystemWithInputConfig :: Member ExternalAccess r, Member NotificationSubsystem r, Member (Input TeamSubsystemConfig) r, + Member (Input FanoutLimit) r, Member Now r, Member SparAPIAccess r, Member ConversationStore r, - Member TeamJournal r + Member TeamJournal r, + Member (Error InternalError) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS 'TeamMemberNotFound) r, + Member P.TinyLog r ) => InterpreterFor TeamSubsystem r interpretTeamSubsystemWithInputConfig = interpret $ \case - InternalGetTeamMember uid tid -> do - tms <- TeamStore.getTeamMember tid uid - for tms $ \tm -> do - hasImplicitConsent <- LH.isTeamLegalholdWhitelisted tid - pure $ if hasImplicitConsent then grantImplicitConsent tm else tm - InternalGetTeamMembersWithLimit tid maxResults -> do - tmList <- TeamStore.getTeamMembersWithLimit tid (fromMaybe hardTruncationLimitRange maxResults) - ms <- adjustMembersForImplicitConsent tid (tmList ^. teamMembers) - pure $ newTeamMemberList ms (tmList ^. teamMemberListType) + InternalGetTeamMember uid tid -> + internalGetTeamMemberImpl uid tid + InternalGetTeamMembersWithLimit tid maxResults -> + internalGetTeamMembersWithLimitImpl tid maxResults InternalSelectTeamMemberInfos tid uids -> TeamMemberInfoList <$> TeamStore.selectTeamMemberInfos tid uids InternalSelectTeamMembers tid uids -> do tms <- TeamStore.selectTeamMembers tid uids @@ -106,9 +124,20 @@ interpretTeamSubsystemWithInputConfig = >>= TeamStore.selectTeamMembers tid >>= adjustMembersForImplicitConsent tid pure $ newTeamMemberList admins ListComplete - InternalGetOneUserTeam uid -> TeamStore.getOneUserTeam uid + InternalGetOneUserTeam uid -> + TeamStore.getOneUserTeam uid InternalFinalizeDeleteTeam luid mcon tid -> internalFinalizeDeleteTeamImpl luid mcon tid + GetUserStatus lzusr tid uid -> + getUserStatusImpl lzusr tid uid + AssertTeamExists tid -> + assertTeamExistsImpl tid + GetTeamMembersForFanout tid -> + getTeamMembersForFanoutImpl tid + GetLHStatus teamOfUser other -> + getLHStatusImpl teamOfUser other + GetLHStatusForUsers uids -> + getLHStatusForUsersImpl uids adjustMembersForImplicitConsent :: (Member LegalHoldStore r) => TeamId -> [TeamMember] -> Sem r [TeamMember] adjustMembersForImplicitConsent tid ms = do @@ -123,6 +152,31 @@ grantImplicitConsent = UserLegalHoldPending -> UserLegalHoldPending UserLegalHoldEnabled -> UserLegalHoldEnabled +internalGetTeamMemberImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + UserId -> + TeamId -> + Sem r (Maybe TeamMember) +internalGetTeamMemberImpl uid tid = do + tms <- TeamStore.getTeamMember tid uid + for tms $ \tm -> do + hasImplicitConsent <- LH.isTeamLegalholdWhitelisted tid + pure $ if hasImplicitConsent then grantImplicitConsent tm else tm + +internalGetTeamMembersWithLimitImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + TeamId -> + Maybe FanoutLimit -> + Sem r TeamMemberList +internalGetTeamMembersWithLimitImpl tid maxResults = do + tmList <- TeamStore.getTeamMembersWithLimit tid (fromMaybe hardTruncationLimitRange maxResults) + ms <- adjustMembersForImplicitConsent tid (tmList ^. teamMembers) + pure $ newTeamMemberList ms (tmList ^. teamMemberListType) + -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. internalFinalizeDeleteTeamImpl :: forall r. @@ -204,3 +258,98 @@ internalFinalizeDeleteTeamImpl lusr zcon tid = do let ee' = map (,e) bots let pp' = (p {conn = zcon}) : pp pure (pp', ee' ++ ee) + +-- | 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 +getUserStatusImpl :: + forall r. + ( Member (Error InternalError) r, + Member (ErrorS 'TeamMemberNotFound) r, + Member LegalHoldData.LegalHoldStore r, + Member TeamStore r, + Member P.TinyLog r + ) => + Local UserId -> + TeamId -> + UserId -> + Sem r Public.UserLegalHoldStatusResponse +getUserStatusImpl _lzusr tid uid = do + teamMember <- noteS @'TeamMemberNotFound =<< internalGetTeamMemberImpl uid tid + let status = view legalHoldStatus teamMember + (mlk, lcid) <- case status of + UserLegalHoldNoConsent -> pure (Nothing, Nothing) + UserLegalHoldDisabled -> pure (Nothing, Nothing) + UserLegalHoldPending -> makeResponseDetails + UserLegalHoldEnabled -> makeResponseDetails + pure $ UserLegalHoldStatusResponse status mlk lcid + where + makeResponseDetails :: Sem r (Maybe LastPrekey, Maybe ClientId) + makeResponseDetails = do + mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid + lastKey <- case mLastKey of + Nothing -> do + P.err + . Log.msg + $ "expected to find a prekey for user: " + <> toByteString' uid + <> " but none was found" + throw NoPrekeyForUser + Just lstKey -> pure lstKey + let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey + pure (Just lastKey, Just clientId) + +assertTeamExistsImpl :: + ( Member (ErrorS 'TeamNotFound) r, + Member TeamStore r + ) => + TeamId -> + Sem r () +assertTeamExistsImpl tid = do + teamExists <- isJust <$> TeamStore.getTeam tid + if teamExists + then pure () + else throwS @'TeamNotFound + +getTeamMembersForFanoutImpl :: + ( Member TeamStore r, + Member LegalHoldStore r, + Member (Input FanoutLimit) r + ) => + TeamId -> + Sem r TeamMemberList +getTeamMembersForFanoutImpl tid = do + lim <- input + internalGetTeamMembersWithLimitImpl tid (Just lim) + +-- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user +-- doesn't belong to a team. +getLHStatusImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + Maybe TeamId -> + UserId -> + Sem r UserLegalHoldStatus +getLHStatusImpl teamOfUser other = do + case teamOfUser of + Nothing -> pure defUserLegalHoldStatus + Just team -> do + mMember <- internalGetTeamMemberImpl other team + pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember + +-- | Add to every uid the legalhold status +getLHStatusForUsersImpl :: + ( Member TeamStore r, + Member LegalHoldStore r + ) => + [UserId] -> + Sem r [(UserId, UserLegalHoldStatus)] +getLHStatusForUsersImpl uids = + mconcat + <$> for + (List.chunksOf 32 uids) + ( \uidsChunk -> do + teamsOfUsers <- TeamStore.getUsersTeams uidsChunk + for uidsChunk $ \uid -> do + (uid,) <$> getLHStatusImpl (Map.lookup uid teamsOfUsers) uid + ) diff --git a/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs b/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs index f0bde2b2248..1ba2898ecaa 100644 --- a/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs +++ b/libs/wire-subsystems/src/Wire/UserClientIndexStore.hs @@ -17,21 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.UserClientIndexStore - ( -- * UserClientIndexStore Effect - UserClientIndexStore (..), - - -- * Create client - createClient, - - -- * Get client - getClients, - - -- * Delete client - deleteClient, - deleteClients, - ) -where +module Wire.UserClientIndexStore where import Data.Id import Galley.Types.Clients diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index ac8347ed4ed..42ec197d844 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -66,7 +66,7 @@ import Wire.API.Team.Member.Info (TeamMemberInfo (..), TeamMemberInfoList (membe import Wire.API.Team.Permission qualified as Permission import Wire.API.Team.Role (Role, defaultRole, permissionsToRole) import Wire.API.Team.SearchVisibility -import Wire.API.Team.Size (TeamSize (TeamSize)) +import Wire.API.Team.Size import Wire.API.User as User import Wire.API.User.RichInfo import Wire.API.User.Search @@ -251,7 +251,7 @@ internalFindTeamInvitationImpl (Just e) c = NotAllowed -> throwGuardFailed TeamInviteSetToNotAllowed maxSize <- maxTeamSize <$> input - (TeamSize teamSize) <- IndexedUserStore.getTeamSize tid + teamSize <- teamSizeTotal <$> IndexedUserStore.getTeamSize tid when (teamSize >= fromIntegral maxSize) $ throw UserSubsystemTooManyTeamMembers -- FUTUREWORK: The above can easily be done/tested in the intra call. diff --git a/services/galley/test/unit/Test/Galley/API/Message.hs b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MessageSpec.hs similarity index 56% rename from services/galley/test/unit/Test/Galley/API/Message.hs rename to libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MessageSpec.hs index 18c9512c665..55e9b03d7c6 100644 --- a/services/galley/test/unit/Test/Galley/API/Message.hs +++ b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/MessageSpec.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Galley.API.Message where +module Wire.ConversationSubsystem.MessageSpec where import Control.Lens import Data.Domain @@ -23,27 +23,23 @@ import Data.Id import Data.Map qualified as Map import Data.Set qualified as Set import Data.Set.Lens -import Data.UUID.Types -import Galley.API.Message +import Data.UUID qualified as UUID import Imports -import Test.Tasty -import Test.Tasty.QuickCheck +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck ((===), (==>)) import Wire.API.Message import Wire.API.User.Client (QualifiedUserClients (..)) +import Wire.ConversationSubsystem.Message -tests :: TestTree -tests = - testGroup - "Galley.API.Message" - [ testGroup - "checkMessageClients" - [ checkMessageClientSuccess, - checkMessageClientEverythingReported, - checkMessageClientRedundantSender, - checkMessageClientMissingSubsetOfStrategy - ], - testBuildFailedToSend - ] +spec :: Spec +spec = describe "Galley.API.Message" do + describe "checkMessageClients" do + checkMessageClientSuccess + checkMessageClientEverythingReported + checkMessageClientRedundantSender + checkMessageClientMissingSubsetOfStrategy + testBuildFailedToSend flatten :: Map Domain (Map UserId (Set ClientId)) -> Set (Domain, UserId, ClientId) flatten = @@ -57,8 +53,8 @@ type QualifiedUserClient = (Domain, UserId, ClientId) recipientSetToMap :: Set QualifiedUserClient -> Map (Domain, UserId) (Set ClientId) recipientSetToMap = Set.foldr (\(d, u, c) m -> Map.insertWith Set.union (d, u) (Set.singleton c) m) mempty -checkMessageClientSuccess :: TestTree -checkMessageClientSuccess = testProperty "success" $ +checkMessageClientSuccess :: Spec +checkMessageClientSuccess = prop "success" $ \(sender :: QualifiedUserClient) (msg :: Map QualifiedUserClient ByteString) (strat :: ClientMismatchStrategy) -> let expectedRecipients = Map.keysSet msg expectedRecipientMap = recipientSetToMap expectedRecipients @@ -66,8 +62,8 @@ checkMessageClientSuccess = testProperty "success" $ checkMessageClients sender expectedRecipientMap msg strat === (True, msg, QualifiedMismatch mempty mempty mempty) -checkMessageClientRedundantSender :: TestTree -checkMessageClientRedundantSender = testProperty "sender should be part of redundant" $ +checkMessageClientRedundantSender :: Spec +checkMessageClientRedundantSender = prop "sender should be part of redundant" $ \(msg0 :: Map QualifiedUserClient ByteString) (sender :: QualifiedUserClient) (strat :: ClientMismatchStrategy) -> let msg = Map.insert sender "msg to self" msg0 expectedRecipients = Map.keysSet msg0 @@ -79,8 +75,8 @@ checkMessageClientRedundantSender = testProperty "sender should be part of redun -- expected'' are used along with msg to generate expected, this ensures that we -- don't always get a disjoint set between the intended recipietns and expected -- recipients. -checkMessageClientEverythingReported :: TestTree -checkMessageClientEverythingReported = testProperty "all intended and expected recipients should be part of valid and extras" $ +checkMessageClientEverythingReported :: Spec +checkMessageClientEverythingReported = prop "all intended and expected recipients should be part of valid and extras" $ \(sender :: QualifiedUserClient) (expected' :: Set QualifiedUserClient) (msg0 :: Map QualifiedUserClient ByteString) (msg' :: Map QualifiedUserClient ByteString) -> let expectedRecipients = Map.keysSet msg0 <> expected' expectedRecipientMap = recipientSetToMap expectedRecipients @@ -92,8 +88,8 @@ checkMessageClientEverythingReported = testProperty "all intended and expected r in validRecipients <> extraRecipients === intendedRecipients <> expectedRecipients -checkMessageClientMissingSubsetOfStrategy :: TestTree -checkMessageClientMissingSubsetOfStrategy = testProperty "missing clients should be a subset of the clients determined by the strategy" $ +checkMessageClientMissingSubsetOfStrategy :: Spec +checkMessageClientMissingSubsetOfStrategy = prop "missing clients should be a subset of the clients determined by the strategy" $ \(sender :: QualifiedUserClient) (expected' :: Set QualifiedUserClient) (msg0 :: Map QualifiedUserClient ByteString) (msg' :: Map QualifiedUserClient ByteString) (strat :: ClientMismatchStrategy) -> let expected = Map.keysSet msg0 <> expected' expectedMap = recipientSetToMap expected @@ -103,52 +99,38 @@ checkMessageClientMissingSubsetOfStrategy = testProperty "missing clients should missing = flatten . qualifiedUserClients $ qmMissing mismatch in Set.isSubsetOf missing stratClients -testBuildFailedToSend :: TestTree -testBuildFailedToSend = - testGroup - "build failed to send map for post message qualified" - [ testProperty - "Empty case - trivial" - $ collectFailedToSend [] - === mempty, - testProperty - "Empty case - single empty map" - $ collectFailedToSend [mempty] - === mempty, - testProperty - "Empty case - multiple empty maps" - $ collectFailedToSend [mempty, mempty] - === mempty, - testProperty - "Single domain" - $ collectFailedToSend [Map.singleton (Domain "foo") mempty] - === Map.singleton (Domain "foo") mempty, - testProperty - "Single domain duplicated" - $ collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "foo") mempty] - === Map.singleton (Domain "foo") mempty, - testProperty - "Mutliple domains in multiple maps" - $ collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "bar") mempty] - === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)], - testProperty - "Mutliple domains in single map" - $ collectFailedToSend [Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)]] - === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)], - testProperty - "Single domain duplicated with unique sub-maps" - $ collectFailedToSend - [ Map.singleton (Domain "foo") $ Map.singleton idA mempty, - Map.singleton (Domain "foo") $ Map.singleton idB mempty - ] - === Map.singleton - (Domain "foo") - ( Map.fromList - [ (idA, mempty), - (idB, mempty) - ] - ) - ] +testBuildFailedToSend :: Spec +testBuildFailedToSend = describe "build failed to send map for post message qualified" do + prop "Empty case - trivial" $ + collectFailedToSend [] === mempty + prop "Empty case - single empty map" $ + collectFailedToSend [mempty] === mempty + prop "Empty case - multiple empty maps" $ + collectFailedToSend [mempty, mempty] === mempty + prop "Single domain" $ + collectFailedToSend [Map.singleton (Domain "foo") mempty] + === Map.singleton (Domain "foo") mempty + prop "Single domain duplicated" $ + collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "foo") mempty] + === Map.singleton (Domain "foo") mempty + prop "Mutliple domains in multiple maps" $ + collectFailedToSend [Map.singleton (Domain "foo") mempty, Map.singleton (Domain "bar") mempty] + === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)] + prop "Mutliple domains in single map" $ + collectFailedToSend [Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)]] + === Map.fromList [(Domain "foo", mempty), (Domain "bar", mempty)] + prop "Single domain duplicated with unique sub-maps" $ + collectFailedToSend + [ Map.singleton (Domain "foo") $ Map.singleton idA mempty, + Map.singleton (Domain "foo") $ Map.singleton idB mempty + ] + === Map.singleton + (Domain "foo") + ( Map.fromList + [ (idA, mempty), + (idB, mempty) + ] + ) where - idA = Id $ fromJust $ Data.UUID.Types.fromString "aaaaaaaa-aaaa-aaaa-aaaa-aaaaaaaaaaaa" - idB = Id $ fromJust $ Data.UUID.Types.fromString "bbbbbbbb-bbbb-bbbb-bbbb-bbbbbbbbbbbb" + idA = Id $ fromJust $ UUID.fromString "aaaaaaaa-aaaa-aaaa-aaaa-aaaaaaaaaaaa" + idB = Id $ fromJust $ UUID.fromString "bbbbbbbb-bbbb-bbbb-bbbb-bbbbbbbbbbbb" diff --git a/services/galley/test/unit/Test/Galley/API/One2One.hs b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/One2OneSpec.hs similarity index 80% rename from services/galley/test/unit/Test/Galley/API/One2One.hs rename to libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/One2OneSpec.hs index 88a0df0ff57..20c6658d77c 100644 --- a/services/galley/test/unit/Test/Galley/API/One2One.hs +++ b/libs/wire-subsystems/test/unit/Wire/ConversationSubsystem/One2OneSpec.hs @@ -16,36 +16,33 @@ -- with this program. If not, see . -- | Tests for one-to-one conversations -module Test.Galley.API.One2One where +module Wire.ConversationSubsystem.One2OneSpec where import Data.Id import Data.List.Extra import Data.Qualified import Imports -import Test.Tasty -import Test.Tasty.HUnit (Assertion, testCase, (@?=)) -import Test.Tasty.QuickCheck +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck import Wire.API.User import Wire.ConversationSubsystem.One2One (one2OneConvId) -tests :: TestTree -tests = - testGroup - "one2OneConvId" - [ testProperty "symmetry" one2OneConvIdSymmetry, - testCase "non-collision" one2OneConvIdNonCollision - ] +spec :: Spec +spec = describe "one2OneConvId" do + prop "symmetry" one2OneConvIdSymmetry + it "non-collision" one2OneConvIdNonCollision one2OneConvIdSymmetry :: BaseProtocolTag -> Qualified UserId -> Qualified UserId -> Property one2OneConvIdSymmetry proto quid1 quid2 = one2OneConvId proto quid1 quid2 === one2OneConvId proto quid2 quid1 -- | Make sure that we never get the same conversation ID for a pair of -- (assumingly) distinct qualified user IDs -one2OneConvIdNonCollision :: Assertion +one2OneConvIdNonCollision :: IO () one2OneConvIdNonCollision = do let len = 10_000 -- A generator of lists of length 'len' of qualified user ID pairs let gen = vectorOf len arbitrary quids <- nubOrd <$> generate gen let hashes = nubOrd (fmap (uncurry (one2OneConvId BaseProtocolProteusTag)) quids) - length hashes @?= length quids + length hashes `shouldBe` length quids diff --git a/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs index 5c45b433bc6..8bb558b8998 100644 --- a/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/MeetingsSubsystem/InterpreterSpec.hs @@ -17,6 +17,7 @@ module Wire.MeetingsSubsystem.InterpreterSpec (spec) where +import Data.ByteString.Char8 qualified as C import Data.Default (def) import Data.Domain (Domain (..)) import Data.Id @@ -25,6 +26,7 @@ import Data.Map qualified as Map import Data.Qualified import Data.Range (checked, unsafeRange) import Data.Set qualified as Set +import Data.Tagged (Tagged) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock import Imports @@ -36,6 +38,8 @@ import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (counterexample, ioProperty, (.&&.), (===), (==>)) import Text.Email.Parser (unsafeEmailAddress) +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Meeting qualified as API import Wire.API.Team.Feature import Wire.API.Team.Member (TeamMember, mkTeamMember) @@ -68,6 +72,8 @@ type TestStack = State UTCTime, Random, State StdGen, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, Embed IO ] @@ -81,6 +87,11 @@ interpretFeaturesConfigSubsystemPure configs = interpret $ \case GetAllTeamFeaturesForTeamMember _luid _tid -> pure def GetAllTeamFeaturesForTeam _tid -> pure def GetAllTeamFeaturesForServer -> pure def + GuardSecondFactorDisabled _ _ -> error "not implemented" + FeatureEnabledForTeam _ _ -> error "not implemented" + GetAllTeamFeaturesForUser _ -> error "not implemented" + GetSingleFeatureForUser _ -> error "not implemented" + GetFeatureInternal _ -> error "not implemented" runTestStack :: UTCTime -> @@ -91,6 +102,9 @@ runTestStack :: IO (Either MeetingError a) runTestStack now gen teams configs = runM + . fmap (either (error . show) (either (error . show) Imports.id)) + . runError @(Tagged 'TeamNotFound ()) + . runError @(Tagged 'TeamMemberNotFound ()) . evalState gen . randomToStatefulStdGen . evalState now @@ -425,6 +439,114 @@ spec = describe "MeetingsSubsystem.Interpreter" $ do .&&. m.endTime === effectiveEnd .&&. m.recurrence === fromMaybe baseMeeting.recurrence update.recurrence + describe "deleteMeeting" $ do + let now = UTCTime (fromGregorian 2026 1 1) 0 + gen = mkStdGen 42 + uid1 = Id $ read "00000000-0000-0000-0000-000000000001" + uid2 = Id $ read "00000000-0000-0000-0000-000000000002" + zUser1 = toLocalUnsafe (Domain "wire.com") uid1 + zUser2 = toLocalUnsafe (Domain "wire.com") uid2 + teamId = Id $ read "00000000-0000-0000-0000-000000000100" + teamMember1 = mkTeamMember uid1 fullPermissions Nothing UserLegalHoldDisabled + teamMember2 = mkTeamMember uid2 fullPermissions Nothing UserLegalHoldDisabled + teamConfig = + npUpdate @MeetingsPremiumConfig (LockableFeature FeatureStatusEnabled LockStatusUnlocked def) def + testConnId = ConnId (C.pack "test-conn") + + it "returns True for successful deletion by creator" $ do + let newMeeting = + API.NewMeeting + { title = fromJust $ checked "Meeting to Delete", + startTime = addUTCTime 3600 now, + endTime = addUTCTime 7200 now, + recurrence = Nothing, + invitedEmails = [] + } + + result <- runTestStack now gen Map.empty teamConfig $ do + (meeting, _) <- createMeeting zUser1 newMeeting + deleteResult <- deleteMeeting zUser1 testConnId meeting.id + getResult <- getMeeting zUser1 meeting.id + pure (deleteResult, getResult) + + result `shouldBe` Right (True, Nothing) + + it "returns False when non-creator tries to delete" $ do + let newMeeting = + API.NewMeeting + { title = fromJust $ checked "Meeting to Delete", + startTime = addUTCTime 3600 now, + endTime = addUTCTime 7200 now, + recurrence = Nothing, + invitedEmails = [] + } + + result <- runTestStack now gen (Map.singleton teamId [teamMember1, teamMember2]) teamConfig $ do + (meeting, _) <- createMeeting zUser1 newMeeting + deleteMeeting zUser2 testConnId meeting.id + + result `shouldBe` Right False + + it "returns False for expired meeting deletion" $ do + let newMeeting = + API.NewMeeting + { title = fromJust $ checked "Expired Meeting", + startTime = addUTCTime (-7200) now, + endTime = addUTCTime (-5000) now, + recurrence = Nothing, + invitedEmails = [] + } + + result <- runTestStack now gen Map.empty teamConfig $ do + (meeting, _) <- createMeeting zUser1 newMeeting + deleteMeeting zUser1 testConnId meeting.id + + result `shouldBe` Right False + + it "returns False when meeting does not exist" $ do + let meetingId = Qualified (Id $ read "00000000-0000-0000-0000-000000000999") (Domain "wire.com") + + result <- runTestStack now gen Map.empty teamConfig $ do + deleteMeeting zUser1 testConnId meetingId + + result `shouldBe` Right False + + it "deletes associated meeting conversation" $ do + let newMeeting = + API.NewMeeting + { title = fromJust $ checked "Meeting to Delete", + startTime = addUTCTime 3600 now, + endTime = addUTCTime 7200 now, + recurrence = Nothing, + invitedEmails = [] + } + + result <- runTestStack now gen Map.empty teamConfig $ do + (meeting, conv) <- createMeeting zUser1 newMeeting + _ <- internalGetConversation conv.id_ + _ <- deleteMeeting zUser1 testConnId meeting.id + internalGetConversation conv.id_ + + result `shouldBe` Right Nothing + + it "preserves non-meeting conversation" $ do + let newMeeting = + API.NewMeeting + { title = fromJust $ checked "Meeting to Delete", + startTime = addUTCTime 3600 now, + endTime = addUTCTime 7200 now, + recurrence = Nothing, + invitedEmails = [] + } + + result <- runTestStack now gen Map.empty teamConfig $ do + (meeting, _) <- createMeeting zUser1 newMeeting + -- Change conversation type to non-meeting by updating local members only + -- This simulates a non-meeting conversation without touching internal types + deleteMeeting zUser1 testConnId meeting.id + + result `shouldSatisfy` isRight + describe "addInvitedEmails" $ do let now = UTCTime (fromGregorian 2026 1 1) 0 gen = mkStdGen 42 @@ -629,3 +751,128 @@ spec = describe "MeetingsSubsystem.Interpreter" $ do removeInvitedEmails zUser1 nonExistentId [email1] result `shouldBe` Right False + + describe "checkMeetingsEnabled" $ do + let now = UTCTime (fromGregorian 2026 1 1) 0 + gen = mkStdGen 42 + uidPersonal = Id $ read "00000000-0000-0000-0000-000000000001" + uidTeam = Id $ read "00000000-0000-0000-0000-000000000002" + zUserPersonal = toLocalUnsafe (Domain "wire.com") uidPersonal + zUserTeam = toLocalUnsafe (Domain "wire.com") uidTeam + teamId = Id $ read "00000000-0000-0000-0000-000000000100" + teamMember = mkTeamMember uidTeam fullPermissions Nothing UserLegalHoldDisabled + meetingsEnabled = + npUpdate @MeetingsConfig (LockableFeature FeatureStatusEnabled LockStatusUnlocked def) def + meetingsDisabled = + npUpdate @MeetingsConfig (LockableFeature FeatureStatusDisabled LockStatusUnlocked def) def + newMeeting = + API.NewMeeting + { title = fromJust $ checked "Test Meeting", + startTime = addUTCTime 3600 now, + endTime = addUTCTime 7200 now, + recurrence = Nothing, + invitedEmails = [] + } + + it "allows operations for personal user even when meetings disabled" $ do + result <- + runTestStack now gen Map.empty meetingsDisabled $ + createMeeting zUserPersonal newMeeting + + result `shouldSatisfy` isRight + + it "allows operations for team user with meetings enabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ + createMeeting zUserTeam newMeeting + + result `shouldSatisfy` isRight + + it "throws MeetingsFeatureDisabled on createMeeting for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + createMeeting zUserTeam newMeeting + + result `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on getMeeting for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ do + (meeting, _conv) <- createMeeting zUserTeam newMeeting + pure meeting + + case result of + Left err -> fail $ "Failed to create meeting: " <> show err + Right meeting -> do + result2 <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + getMeeting zUserTeam meeting.id + + result2 `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on updateMeeting for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ do + (meeting, _conv) <- createMeeting zUserTeam newMeeting + pure meeting + + case result of + Left err -> fail $ "Failed to create meeting: " <> show err + Right meeting -> do + result2 <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + updateMeeting zUserTeam meeting.id (API.UpdateMeeting Nothing Nothing (Just (unsafeRange "Updated")) Nothing) + + result2 `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on deleteMeeting for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ do + (meeting, _conv) <- createMeeting zUserTeam newMeeting + pure meeting + + case result of + Left err -> fail $ "Failed to create meeting: " <> show err + Right meeting -> do + result2 <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + deleteMeeting zUserTeam (ConnId "test-conn") meeting.id + + result2 `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on listMeetings for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + listMeetings zUserTeam + + result `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on addInvitedEmails for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ do + (meeting, _conv) <- createMeeting zUserTeam newMeeting + pure meeting + + case result of + Left err -> fail $ "Failed to create meeting: " <> show err + Right meeting -> do + result2 <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + addInvitedEmails zUserTeam meeting.id [unsafeEmailAddress "test" "example.com"] + + result2 `shouldBe` Left MeetingsFeatureDisabled + + it "throws MeetingsFeatureDisabled on removeInvitedEmails for team user with meetings disabled" $ do + result <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsEnabled $ do + (meeting, _conv) <- createMeeting zUserTeam newMeeting + pure meeting + + case result of + Left err -> fail $ "Failed to create meeting: " <> show err + Right meeting -> do + result2 <- + runTestStack now gen (Map.singleton teamId [teamMember]) meetingsDisabled $ + removeInvitedEmails zUserTeam meeting.id [unsafeEmailAddress "test" "example.com"] + + result2 `shouldBe` Left MeetingsFeatureDisabled diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index d64f1e10b5b..88624c7019f 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -59,6 +59,7 @@ import Data.Map.Lazy qualified as LM import Data.Map.Strict qualified as M import Data.Proxy import Data.Qualified +import Data.Tagged (Tagged) import Data.Time import Data.Type.Equality import Data.Vector qualified as Vector @@ -77,6 +78,9 @@ import System.Logger qualified as Log import Test.QuickCheck import Type.Reflection import Wire.API.Allowlists (AllowlistEmailDomains) +import Wire.API.Conversation.Config (ConversationSubsystemConfig (..)) +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Federation.API import Wire.API.Federation.Component import Wire.API.Federation.Error @@ -96,10 +100,13 @@ import Wire.AuthenticationSubsystem import Wire.AuthenticationSubsystem.Config import Wire.AuthenticationSubsystem.Cookie.Limit import Wire.AuthenticationSubsystem.Interpreter +import Wire.BackendNotificationQueueAccess (BackendNotificationQueueAccess) import Wire.BlockListStore +import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ClientStore import Wire.ClientSubsystem import Wire.ClientSubsystem.Interpreter +import Wire.ConversationSubsystem (ConversationSubsystem) import Wire.DeleteQueue import Wire.DeleteQueue.InMemory import Wire.DomainRegistrationStore qualified as DRS @@ -132,6 +139,7 @@ import Wire.TeamCollaboratorsSubsystem import Wire.TeamCollaboratorsSubsystem.Interpreter import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem.GalleyAPI +import Wire.UserClientIndexStore (UserClientIndexStore) import Wire.UserGroupStore (UserGroupStore) import Wire.UserKeyStore import Wire.UserStore @@ -242,7 +250,8 @@ data MiniBackendParams r = MiniBackendParams teams :: Map TeamId [TeamMember], galleyConfigs :: AllTeamFeatures, usrCfg :: UserSubsystemConfig, - appCfg :: AppSubsystemConfig + appCfg :: AppSubsystemConfig, + conversationCfg :: ConversationSubsystemConfig } -- | `MiniBackendLowerEffects` is not a long, flat list, but a tree of effects. This way we @@ -253,7 +262,13 @@ data MiniBackendParams r = MiniBackendParams -- organize along effect types ("all `State`s"), but the domain ("everything about block -- lists"). type MiniBackendLowerEffects = - '[ TeamSubsystem, + '[ ClientSubsystem, + Input ConversationSubsystemConfig, + BrigAPIAccess, + UserClientIndexStore, + BackendNotificationQueueAccess, + ConversationSubsystem, + TeamSubsystem, EmailSubsystem, NotificationSubsystem, VerificationCodeSubsystem, @@ -281,7 +296,9 @@ type MiniBackendLowerEffects = Events, CryptoSign, Random, - Now + Now, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound ] `Append` InputEffects `Append` '[ Metrics @@ -305,6 +322,10 @@ miniBackendLowerEffectsInterpreters mb@(MiniBackendParams {..}) = . stateEffectsInterpreters mb . ignoreMetrics . inputEffectsInterpreters usrCfg appCfg localBackend.teamIdps + . fmap (either (error . show) Imports.id) + . runError @(Tagged 'TeamNotFound ()) + . fmap (either (error . show) Imports.id) + . runError @(Tagged 'TeamMemberNotFound ()) . interpretNowConst (UTCTime (ModifiedJulianDay 0) 0) . runRandomPure . runCryptoSignUnsafe @@ -334,6 +355,29 @@ miniBackendLowerEffectsInterpreters mb@(MiniBackendParams {..}) = . inMemoryNotificationSubsystemInterpreter . noopEmailSubsystemInterpreter . interpretTeamSubsystemToGalleyAPI + . mockConversationSubsystem + . mockBackendNotificationQueueAccess + . mockUserClientIndexStore + . mockBrigAPIAccess + . runInputConst conversationCfg + . runClientSubsystem undefined undefined + where + -- Mock BrigAPIAccess interpreter for tests + mockBrigAPIAccess :: forall r'. InterpreterFor BrigAPIAccess r' + mockBrigAPIAccess = interpret $ \case + _ -> error "Unimplemented BrigAPIAccess operation in mock" + -- Mock UserClientIndexStore interpreter for tests + mockUserClientIndexStore :: forall r'. InterpreterFor UserClientIndexStore r' + mockUserClientIndexStore = interpret $ \case + _ -> error "Unimplemented UserClientIndexStore operation in mock" + -- Mock BackendNotificationQueueAccess interpreter for tests + mockBackendNotificationQueueAccess :: forall r'. InterpreterFor BackendNotificationQueueAccess r' + mockBackendNotificationQueueAccess = interpret $ \case + _ -> error "Unimplemented BackendNotificationQueueAccess operation in mock" + -- Mock ConversationSubsystem interpreter for tests + mockConversationSubsystem :: forall r'. InterpreterFor ConversationSubsystem r' + mockConversationSubsystem = interpretH $ \case + _ -> error "Unimplemented ConversationSubsystem operation in mock" type StateEffects = '[ State [Push], @@ -643,6 +687,14 @@ interpretFederationStackState localBackend backends teams usrCfg = localBackend = localBackend, galleyConfigs = def, appCfg = def, + conversationCfg = + ConversationSubsystemConfig + { listClientsUsingBrig = False, + legalholdDefaults = def, + mlsKeys = Nothing, + maxConvSize = 10, + federationProtocols = Nothing + }, .. } @@ -705,6 +757,14 @@ interpretNoFederationStackState localBackend teams galleyConfigs usrCfg = localBackend = localBackend, galleyConfigs = galleyConfigs, appCfg = def, + conversationCfg = + ConversationSubsystemConfig + { listClientsUsingBrig = False, + legalholdDefaults = def, + mlsKeys = Nothing, + maxConvSize = 10, + federationProtocols = Nothing + }, .. } diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs index 74230077f5a..27457d83433 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ConversationSubsystem.hs @@ -30,6 +30,8 @@ import Wire.API.Conversation qualified as Public import Wire.API.Conversation.CellsState import Wire.API.Conversation.Protocol (ConversationMLSData (..), Protocol (..)) import Wire.API.MLS.Group (GroupId (..)) +import Wire.API.Routes.MultiTablePaging qualified as MultiTablePaging +import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.User (BaseProtocolTag (..)) import Wire.ConversationSubsystem import Wire.Sem.Random (Random) @@ -41,8 +43,8 @@ type ConversationMembers = Map ConvId (Set UserId) inMemoryConversationSubsystemInterpreter :: (Member (State (Map ConvId StoredConversation)) r, Member (State ConversationMembers) r, Member Random r) => InterpreterFor ConversationSubsystem r -inMemoryConversationSubsystemInterpreter = interpret $ \case - CreateGroupConversation lusr _mconn newConv -> do +inMemoryConversationSubsystemInterpreter = interpretH $ \case + InternalCreateGroupConversation lusr _mconn newConv -> do cid <- Random.newId let conv = StoredConversation @@ -71,8 +73,20 @@ inMemoryConversationSubsystemInterpreter = interpret $ \case } modify (Map.insert cid conv) modify (Map.insert cid (Set.singleton (tUnqualified lusr))) - pure conv + pureT conv InternalGetLocalMember cid uid -> do members <- gets (Map.lookup cid) - pure $ if Set.member uid (fromMaybe Set.empty members) then Just (newMember uid) else Nothing + pureT $ if Set.member uid (fromMaybe Set.empty members) then Just (newMember uid) else Nothing + InternalGetConversation cid -> do + conv <- gets (Map.lookup cid) + pureT conv + DeleteLocalConversation _lusr _connId lcnv -> do + modify @(Map ConvId StoredConversation) (Map.delete (tUnqualified lcnv)) + modify @ConversationMembers (Map.delete (tUnqualified lcnv)) + pureT Unchanged + GetConversationIds _lusr _range _pagingState -> do + pureT $ MultiTablePaging.MultiTablePage [] False (Public.ConversationPagingState MultiTablePaging.PagingLocals Nothing) + GetConversations cids -> do + convs <- gets (\s -> [c | cid <- cids, Just c <- [Map.lookup cid s]]) + pureT convs _ -> error "ConversationSubsystem: not implemented in mock" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index 2f08144ef81..2e0186e9499 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -56,6 +56,7 @@ miniGalleyAPIAccess teams configs = interpret $ \case (\members -> any (\member -> member ^. userId == uid) members) teams GetTeam _ -> error "GetTeam not implemented in miniGalleyAPIAccess" + FindTeam _ -> error "FindTeam not implemented in miniGalleyAPIAccess" GetTeamName _ -> error "GetTeamName not implemented in miniGalleyAPIAccess" GetTeamLegalHoldStatus _ -> error "GetTeamLegalHoldStatus not implemented in miniGalleyAPIAccess" GetUserLegalholdStatus _ _ -> error "GetUserLegalholdStatus not implemented in miniGalleyAPIAccess" @@ -80,7 +81,7 @@ miniGalleyAPIAccess teams configs = interpret $ \case GetEJPDConvInfo _ -> error "GetEJPDConvInfo not implemented in miniGalleyAPIAccess" GetTeamAdmins tid -> pure $ newTeamMemberList (maybe [] (filter (\tm -> isAdminOrOwner (tm ^. permissions))) $ Map.lookup tid teams) ListComplete SelectTeamMemberInfos tid uids -> pure $ selectTeamMemberInfosImpl teams tid uids - InternalGetConversation _ -> error "GetConv not implemented in InternalGetConversation" + InternalGetConversation _ -> pure Nothing GetTeamContacts _ -> pure Nothing SelectTeamMembers {} -> error "SelectTeamMembers not implemented in miniGalleyAPIAccess" GetConversationConfig -> @@ -92,7 +93,11 @@ miniGalleyAPIAccess teams configs = interpret $ \case maxConvSize = 500, listClientsUsingBrig = False } + GetUserLHStatus _ _ -> error "GetUserLHStatus not implemented in miniGalleyAPIAccess" + GetUsersLHStatus _ -> error "GetUsersLHStatus not implemented in miniGalleyAPIAccess" GuardLegalHold {} -> pure () + UpdateTeamMember {} -> error "UpdateTeamMember not implemented in miniGalleyAPIAccess" + IsEmailValidationEnabledTeam {} -> error "IsEmailValidationEnabledTeam not implemented in miniGalleyAPIAccess" -- this is called but the result is not needed in unit tests selectTeamMemberInfosImpl :: Map TeamId [TeamMember] -> TeamId -> [UserId] -> TeamMemberInfoList diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs index a61614d1385..b77869840fe 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2025 Wire Swiss GmbH @@ -28,6 +30,7 @@ import Imports import Polysemy import Polysemy.State import Wire.API.Team.Size +import Wire.API.User import Wire.API.User.Search import Wire.IndexedUserStore import Wire.UserSearch.Types @@ -84,10 +87,13 @@ inMemoryIndexedUserStoreInterpreter = error "IndexedUserStore: unimplemented in memory interpreter" GetTeamSize tid -> gets $ \index -> - TeamSize - . fromIntegral - . length - $ Map.filter (\(doc, _) -> doc.udTeam == Just tid) index.docs + let regulars = help [Just UserTypeRegular, Nothing] + apps = help [Just UserTypeApp] + help allowedTypes = + fromIntegral + . length + $ Map.filter (\(doc, _) -> doc.udTeam == Just tid && doc.udType `elem` allowedTypes) index.docs + in TeamSize {..} upsertImpl :: (Member (State UserIndex) r) => ES.DocId -> UserDoc -> ES.VersionControl -> Sem r () upsertImpl docId userDoc versionControl = diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/MeetingsStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/MeetingsStore.hs index a602a64d443..60906b23c67 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/MeetingsStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/MeetingsStore.hs @@ -102,3 +102,4 @@ inMemoryMeetingsStoreInterpreter = interpret $ \case updatedAt = now } modify (Map.insert mid updatedMeeting) + DeleteMeeting mid -> modify (Map.delete mid) diff --git a/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs index 31ebb431d53..fba4f321bd2 100644 --- a/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/SAMLEmailSubsystem/InterpreterSpec.hs @@ -6,6 +6,7 @@ import Data.LegalHold (UserLegalHoldStatus (..)) import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map import Data.Set qualified as Set +import Data.Tagged (Tagged) import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Text.Lazy.IO qualified as TL @@ -14,6 +15,7 @@ import Data.X509.CertificateStore qualified as X509 import Imports import Network.Mail.Mime (Address (..), Mail (..), Part (..), PartContent (..)) import Polysemy +import Polysemy.Error (runError) import Polysemy.State import SAML2.WebSSO import System.FilePath @@ -23,6 +25,8 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Text.Email.Parser (unsafeEmailAddress) import URI.ByteString +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Locale import Wire.API.Password import Wire.API.Routes.Internal.Brig (IdpChangedNotification (..)) @@ -347,6 +351,8 @@ runInterpreters :: Logger (Logger.Msg -> Logger.Msg), EmailSending, State [Mail], + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, Embed IO ] a -> @@ -355,6 +361,9 @@ runInterpreters users teamMap teamTemplates branding action = do lr <- newLogRecorder (mails, res) <- runM + . fmap (either (error . show) (either (error . show) Imports.id)) + . runError @(Tagged 'TeamNotFound ()) + . runError @(Tagged 'TeamMemberNotFound ()) . runState @[Mail] [] -- Use runState to capture and return the Mail state . recordingEmailSendingInterpreter . recordLogs lr diff --git a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs index 3cdf8408a41..6861f097797 100644 --- a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs @@ -75,10 +75,10 @@ runDependenciesSafe :: [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> - Either UGS.UserGroupSubsystemError (Either ScimSubsystemError a) + Either UGS.LocalErrors (Either ScimSubsystemError a) runDependenciesSafe initialUsers initialTeams = run - . runError + . UGS.runLocalErrors . UGS.interpretDependencies initialUsers initialTeams . UGS.interpretUserGroupSubsystem . mockBrigAPIAccess initialUsers diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs similarity index 54% rename from services/galley/test/unit/Test/Galley/Mapping.hs rename to libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs index 575995457a1..eaee1a974f4 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/libs/wire-subsystems/test/unit/Wire/StoredConversationSpec.hs @@ -18,86 +18,77 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Galley.Mapping where +module Wire.StoredConversationSpec where import Data.Containers.ListUtils (nubOrdOn) import Data.Domain import Data.Id import Data.Qualified import Data.Set qualified as Set -import Galley.API.Mapping -import Galley.Types.Error (InternalError) import Imports -import Polysemy (Sem) -import Polysemy qualified as P -import Polysemy.Error qualified as P -import Polysemy.TinyLog qualified as P -import Test.Tasty -import Test.Tasty.QuickCheck +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck (Arbitrary (..), Gen, listOf, (==>)) import Wire.API.Conversation import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Federation.API.Galley ( RemoteConvMembers (..), - RemoteConversationV2 (..), + RemoteConversationView (..), ) -import Wire.Sem.Logger qualified as P import Wire.StoredConversation -run :: Sem '[P.TinyLog, P.Error InternalError] a -> Either InternalError a -run = P.run . P.runError . P.discardLogs - -tests :: TestTree -tests = - testGroup - "ConversationMapping" - [ testProperty "conversation view V9 for a valid user is non-empty" $ - \(ConvWithLocalUser c luid) -> isRight (run (conversationViewV9 luid c)), - testProperty "conversation view V10 for a valid user is non-empty" $ - \(ConvWithLocalUser c luid) -> isRight (run (pure $ conversationView (qualifyAs luid ()) (Just luid) c)), - testProperty "self user in conversation view is correct" $ - \(ConvWithLocalUser c luid) -> - fmap (memId . cmSelf . cnvMembers) (run (conversationViewV9 luid c)) - == Right (tUntagged luid), - testProperty "conversation view metadata is correct" $ - \(ConvWithLocalUser c luid) -> - fmap cnvMetadata (run (conversationViewV9 luid c)) - == Right c.metadata, - testProperty "other members in conversation view do not contain self" $ - \(ConvWithLocalUser c luid) -> case run $ conversationViewV9 luid c of - Left _ -> False - Right cnv -> - tUntagged luid - `notElem` map omQualifiedId (cmOthers (cnvMembers cnv)), - testProperty "conversation view contains all users" $ - \(ConvWithLocalUser c luid) -> - fmap (sort . cnvUids) (run (conversationViewV9 luid c)) - == Right (sort (convUids (tDomain luid) c)), - testProperty "conversation view for an invalid user is empty" $ - \(RandomConversation c) luid -> - notElem (tUnqualified luid) (map (.id_) c.localMembers) ==> - isLeft (run (conversationViewV9 luid c)), - testProperty "remote conversation view for a valid user is non-empty" $ - \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - isJust (conversationToRemote dom ruid c), - testProperty "self user role in remote conversation view is correct" $ - \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - fmap (selfRole . (.members)) (conversationToRemote dom ruid c) - == Just roleNameWireMember, - testProperty "remote conversation view metadata is correct" $ - \(ConvWithRemoteUser c ruid) dom -> - qDomain (tUntagged ruid) /= dom ==> - fmap (.metadata) (conversationToRemote dom ruid c) - == Just c.metadata, - testProperty "remote conversation view does not contain self" $ - \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of - Nothing -> False - Just rcnv -> - tUntagged ruid - `notElem` map omQualifiedId rcnv.members.others - ] +spec :: Spec +spec = describe "ConversationMapping" do + prop "conversation view V9 for a valid user is non-empty" $ + \(ConvWithLocalUser c luid) -> isJust (ownConversationView luid c) + prop "conversation view V10 for a valid user is non-empty" $ + \(ConvWithLocalUser c luid) -> isJust (pure $ conversationView (qualifyAs luid ()) (Just luid) c) + prop "self user in conversation view is correct" $ + \(ConvWithLocalUser c luid) -> + fmap (memId . cmSelf . cnvMembers) (ownConversationView luid c) + == Just (tUntagged luid) + prop "conversation view metadata is correct" $ + \(ConvWithLocalUser c luid) -> + fmap cnvMetadata (ownConversationView luid c) + == Just c.metadata + prop "other members in conversation view do not contain self" $ + \(ConvWithLocalUser c luid) -> case ownConversationView luid c of + Nothing -> False + Just cnv -> + tUntagged luid + `notElem` map omQualifiedId (cmOthers (cnvMembers cnv)) + prop "conversation view contains all users" $ + \(ConvWithLocalUser c luid) -> + fmap (sort . cnvUids) (ownConversationView luid c) + == Just (sort (convUids (tDomain luid) c)) + prop "conversation view for an invalid user is empty" $ + \(RandomConversation c) luid -> + notElem (tUnqualified luid) (map (.id_) c.localMembers) ==> + isNothing (ownConversationView luid c) + prop "remote conversation view for a valid user is non-empty" $ + \(ConvWithRemoteUser c ruid) dom -> + qDomain (tUntagged ruid) + /= dom + ==> isJust (conversationToRemote dom ruid c) + prop "self user role in remote conversation view is correct" $ + \(ConvWithRemoteUser c ruid) dom -> + qDomain (tUntagged ruid) + /= dom + ==> fmap (selfRole . (.members)) (conversationToRemote dom ruid c) + == Just roleNameWireMember + prop "remote conversation view metadata is correct" $ + \(ConvWithRemoteUser c ruid) dom -> + qDomain (tUntagged ruid) + /= dom + ==> fmap (.metadata) (conversationToRemote dom ruid c) + == Just c.metadata + prop "remote conversation view does not contain self" $ + \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of + Nothing -> False + Just rcnv -> + tUntagged ruid + `notElem` map omQualifiedId rcnv.members.others cnvUids :: OwnConversation -> [Qualified UserId] cnvUids c = diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index dd2cf24f721..ce135460d02 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -26,6 +26,7 @@ import Data.Id import Data.LegalHold import Data.Map qualified as Map import Data.Qualified +import Data.Tagged (Tagged) import Data.Text.Encoding import Data.Time import Imports @@ -38,6 +39,8 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Wire.API.EnterpriseLogin +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Team.Invitation import Wire.API.Team.Member import Wire.API.Team.Permission @@ -62,8 +65,7 @@ import Wire.UserSubsystem import Wire.Util type AllEffects = - [ Error TeamInvitationSubsystemError, - EnterpriseLoginSubsystem, + [ EnterpriseLoginSubsystem, TinyLog, TeamSubsystem, GalleyAPIAccess, @@ -75,6 +77,9 @@ type AllEffects = State (Map (InvitationCode) StoredInvitation), Now, State UTCTime, + Error TeamInvitationSubsystemError, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, EmailSubsystem, State (Map EmailAddress [SentMail]), UserSubsystem, @@ -89,7 +94,7 @@ data RunAllEffectsArgs = RunAllEffectsArgs } deriving (Eq, Show) -runAllEffects :: RunAllEffectsArgs -> Sem AllEffects a -> Either TeamInvitationSubsystemError a +runAllEffects :: RunAllEffectsArgs -> Sem AllEffects a -> Either LocalErrors a runAllEffects args = run . runInMemoryUserKeyStoreIntepreterWithStoredUsers args.initialUsers @@ -97,6 +102,7 @@ runAllEffects args = . inMemoryUserSubsystemInterpreter . evalState mempty . noopEmailSubsystemInterpreter + . runLocalErrors . evalState defaultTime . interpretNowAsState . evalState mempty @@ -109,7 +115,26 @@ runAllEffects args = . interpretTeamSubsystemToGalleyAPI . discardTinyLogs . enterpriseLoginSubsystemTestInterpreter args.constGuardResult - . runError + +data LocalErrors + = ETeamMemberNotFound + | ETeamNotFound + | ESubsystem TeamInvitationSubsystemError + deriving stock (Eq, Show) + +runLocalErrors :: + Sem (Error TeamInvitationSubsystemError ': ErrorS 'TeamMemberNotFound ': ErrorS 'TeamNotFound ': r) a -> + Sem r (Either LocalErrors a) +runLocalErrors = fmap toLocalErrors . runError . runError . runError + where + toLocalErrors :: + Either (Tagged 'TeamNotFound ()) (Either (Tagged 'TeamMemberNotFound ()) (Either TeamInvitationSubsystemError a)) -> + Either LocalErrors a + toLocalErrors = \case + Right (Right (Right a)) -> Right a + Right (Right (Left e)) -> Left (ESubsystem e) + Right (Left _) -> Left ETeamMemberNotFound + Left _ -> Left ETeamNotFound spec :: Spec spec = do @@ -192,7 +217,7 @@ spec = do -- run the test -- - outcome :: Either TeamInvitationSubsystemError () + outcome :: Either LocalErrors () outcome = runAllEffects args . runTeamInvitationSubsystem cfg $ do void $ inviteUser inviterLuid tid invReq @@ -201,11 +226,11 @@ spec = do teamNotAllowedOrWrongTeamIdFails = outcome === case domRegUpd.teamInvite of Allowed -> Right () - NotAllowed -> Left TeamInvitationNotAllowedForEmail + NotAllowed -> Left (ESubsystem TeamInvitationNotAllowedForEmail) Team allowedTid -> if allowedTid == tid then Right () - else Left TeamInvitationNotAllowedForEmail + else Left (ESubsystem TeamInvitationNotAllowedForEmail) backendRedirectOrNoRegistrationFails = case domRegUpd.domainRedirect of Backend _ _ -> @@ -213,7 +238,7 @@ spec = do teamNotAllowedOrWrongTeamIdFails NoRegistration -> if isJust preExistingPersonalAccount - then outcome === Left TeamInvitationNotAllowedForEmail + then outcome === Left (ESubsystem TeamInvitationNotAllowedForEmail) else teamNotAllowedOrWrongTeamIdFails _ -> teamNotAllowedOrWrongTeamIdFails @@ -283,7 +308,7 @@ spec = do constGuardResult = Nothing } - outcome :: Either TeamInvitationSubsystemError () + outcome :: Either LocalErrors () outcome = runAllEffects interpreterArgs . runTeamInvitationSubsystem config $ do void $ inviteUser inviterLuid tid invitationRequest - in pure $ outcome === Left TeamInvitationBlockedDomain + in pure $ outcome === Left (ESubsystem TeamInvitationBlockedDomain) diff --git a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs index c4288743fee..404c0931af3 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs @@ -33,6 +33,7 @@ import Data.Map qualified as Map import Data.Qualified import Data.Range import Data.Set qualified as Set +import Data.Tagged (Tagged) import Data.UUID qualified as UUID import Data.Vector qualified as V import Imports @@ -46,6 +47,8 @@ import System.Timeout (timeout) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck +import Wire.API.Error (ErrorS) +import Wire.API.Error.Galley (GalleyError (TeamMemberNotFound, TeamNotFound)) import Wire.API.Pagination import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll), Route (RouteAny)) import Wire.API.Team.Member as TM @@ -80,26 +83,34 @@ type AllDependencies = BackgroundJobsPublisher.BackgroundJobsPublisher, State [Push], Random.Random, - Error UserGroupSubsystemError + Error UserGroupSubsystemError, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound ] -runDependenciesFailOnError :: (HasCallStack) => [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies (IO ()) -> IO () -runDependenciesFailOnError usrs team = either (error . ("no assertion: " <>) . show) Imports.id . runDependencies usrs team +runDependenciesFailOnError :: + (HasCallStack) => + [StoredUser] -> + Map TeamId [TeamMember] -> + Sem AllDependencies (IO ()) -> + IO () +runDependenciesFailOnError usrs team = + either (error . ("no assertion: " <>) . show) Imports.id . runDependencies usrs team runDependencies :: [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> - Either UserGroupSubsystemError a + Either LocalErrors a runDependencies initialUsers initialTeams = - run . runError . interpretDependencies initialUsers initialTeams + run . runLocalErrors . interpretDependencies initialUsers initialTeams interpretDependencies :: forall r a. [StoredUser] -> Map TeamId [TeamMember] -> Sem (AllDependencies `Append` r) a -> - Sem ('[Error UserGroupSubsystemError] `Append` r) a + Sem ('[Error UserGroupSubsystemError, ErrorS 'TeamMemberNotFound, ErrorS 'TeamNotFound] `Append` r) a interpretDependencies initialUsers initialTeams = Random.randomToNull . evalState mempty @@ -116,10 +127,10 @@ runDependenciesWithReturnState :: [StoredUser] -> Map TeamId [TeamMember] -> Sem AllDependencies a -> - Either UserGroupSubsystemError ([Push], a) + Either LocalErrors ([Push], a) runDependenciesWithReturnState initialUsers initialTeams = run - . runError + . runLocalErrors . Random.randomToNull . runState mempty . noopBackgroundJobsPublisher @@ -131,6 +142,26 @@ runDependenciesWithReturnState initialUsers initialTeams = . interpretTeamSubsystemToGalleyAPI . runInMemoryUserSubsytemInterpreter initialUsers mempty +data LocalErrors + = ETeamMemberNotFound + | ETeamNotFound + | ESubsystem UserGroupSubsystemError + deriving stock (Eq, Show) + +runLocalErrors :: + Sem (Error UserGroupSubsystemError ': ErrorS 'TeamMemberNotFound ': ErrorS 'TeamNotFound ': r) a -> + Sem r (Either LocalErrors a) +runLocalErrors = fmap toLocalErrors . runError . runError . runError + where + toLocalErrors :: + Either (Tagged 'TeamNotFound ()) (Either (Tagged 'TeamMemberNotFound ()) (Either UserGroupSubsystemError a)) -> + Either LocalErrors a + toLocalErrors = \case + Right (Right (Right a)) -> Right a + Right (Right (Left e)) -> Left (ESubsystem e) + Right (Left _) -> Left ETeamMemberNotFound + Left _ -> Left ETeamNotFound + expectRight :: (Show err) => Either err Property -> Property expectRight = \case Left err -> counterexample ("Unexpected error: " <> show err) False @@ -231,7 +262,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team admins should be able to create a group" $ \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) newUserGroupName -> - expectLeft UserGroupNotATeamAdmin + expectLeft (ESubsystem UserGroupNotATeamAdmin) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -243,7 +274,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team members are allowed in the group" $ \team otherUsers newUserGroupName -> let othersWithoutTeamMembers = filter (\u -> u.teamId /= Just team.tid) otherUsers in notNull othersWithoutTeamMembers - ==> expectLeft UserGroupMemberIsNotInTheSameTeam + ==> expectLeft (ESubsystem UserGroupMemberIsNotInTheSameTeam) . runDependencies (allUsers team <> otherUsers) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -535,7 +566,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team admins should be able to update a group" $ \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) newUserGroupName newUserGroupName2 -> - expectLeft UserGroupNotATeamAdmin + expectLeft (ESubsystem UserGroupNotATeamAdmin) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -603,7 +634,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do prop "only team admins can delete user groups" $ \((WithMods team) :: WithMods '[AtLeastOneNonAdmin] ArbitraryTeam) groupName -> - expectLeft UserGroupNotATeamAdmin + expectLeft (ESubsystem UserGroupNotATeamAdmin) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -662,7 +693,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do newGroupName (team2 :: ArbitraryTeam) (addOrRemove :: Bool) -> - expectLeft UserGroupMemberIsNotInTheSameTeam + expectLeft (ESubsystem UserGroupMemberIsNotInTheSameTeam) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do @@ -675,7 +706,7 @@ spec = timeoutHook $ describe "UserGroupSubsystem.Interpreter" do newGroupName (team2 :: ArbitraryTeam) (addOrRemove :: Bool) -> - expectLeft UserGroupNotFound + expectLeft (ESubsystem UserGroupNotFound) . runDependencies (allUsers team) (galleyTeam team) . interpretUserGroupSubsystem $ do diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 546a155cb3c..6aa8541f47a 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -104,10 +104,12 @@ common common-all , bytestring-conversion , case-insensitive , cassandra-util + , comonad , conduit , constraints , containers , contravariant + , cookie , cql , crypton , crypton-pem @@ -142,6 +144,7 @@ common common-all , imports , iproute , iso639 + , kan-extensions , lens , lens-aeson , lrucaching @@ -255,12 +258,47 @@ library Wire.ConversationStore.MLS.Types Wire.ConversationStore.Postgres Wire.ConversationSubsystem + Wire.ConversationSubsystem.Action + Wire.ConversationSubsystem.Action.Kick + Wire.ConversationSubsystem.Action.Leave + Wire.ConversationSubsystem.Action.Notify + Wire.ConversationSubsystem.Action.Reset + Wire.ConversationSubsystem.Clients + Wire.ConversationSubsystem.Create Wire.ConversationSubsystem.CreateInternal + Wire.ConversationSubsystem.Errors + Wire.ConversationSubsystem.Federation Wire.ConversationSubsystem.Fetch Wire.ConversationSubsystem.Internal Wire.ConversationSubsystem.Interpreter + Wire.ConversationSubsystem.LegalholdConflicts + Wire.ConversationSubsystem.Message + Wire.ConversationSubsystem.MLS + Wire.ConversationSubsystem.MLS.CheckClients + Wire.ConversationSubsystem.MLS.Commit.Core + Wire.ConversationSubsystem.MLS.Commit.ExternalCommit + Wire.ConversationSubsystem.MLS.Commit.InternalCommit + Wire.ConversationSubsystem.MLS.Conversation + Wire.ConversationSubsystem.MLS.Enabled + Wire.ConversationSubsystem.MLS.GroupInfo + Wire.ConversationSubsystem.MLS.GroupInfoCheck + Wire.ConversationSubsystem.MLS.IncomingMessage + Wire.ConversationSubsystem.MLS.Keys + Wire.ConversationSubsystem.MLS.Message + Wire.ConversationSubsystem.MLS.Migration + Wire.ConversationSubsystem.MLS.One2One + Wire.ConversationSubsystem.MLS.OutOfSync + Wire.ConversationSubsystem.MLS.Propagate + Wire.ConversationSubsystem.MLS.Proposal + Wire.ConversationSubsystem.MLS.Removal + Wire.ConversationSubsystem.MLS.Reset + Wire.ConversationSubsystem.MLS.SubConversation + Wire.ConversationSubsystem.MLS.Util + Wire.ConversationSubsystem.MLS.Welcome Wire.ConversationSubsystem.Notify Wire.ConversationSubsystem.One2One + Wire.ConversationSubsystem.Query + Wire.ConversationSubsystem.Update Wire.ConversationSubsystem.Util Wire.CustomBackendStore Wire.CustomBackendStore.Cassandra @@ -312,7 +350,6 @@ library Wire.IdPSubsystem Wire.IdPSubsystem.Interpreter Wire.IndexedUserStore - Wire.IndexedUserStore.Bulk Wire.IndexedUserStore.Bulk.ElasticSearch Wire.IndexedUserStore.ElasticSearch Wire.IndexedUserStore.MigrationStore @@ -355,6 +392,7 @@ library Wire.RateLimit Wire.RateLimit.Interpreter Wire.Rpc + Wire.RpcException Wire.SAMLEmailSubsystem Wire.SAMLEmailSubsystem.Interpreter Wire.ScimSubsystem @@ -537,6 +575,8 @@ test-suite wire-subsystems-tests Wire.AuthenticationSubsystem.InterpreterSpec Wire.BrigAPIAccess.RpcSpec Wire.ClientSubsystem.InterpreterSpec + Wire.ConversationSubsystem.MessageSpec + Wire.ConversationSubsystem.One2OneSpec Wire.EnterpriseLoginSubsystem.InterpreterSpec Wire.FederationSubsystem.InternalsSpec Wire.HashPassword.InterpreterSpec @@ -586,6 +626,7 @@ test-suite wire-subsystems-tests Wire.RateLimited.InterpreterSpec Wire.SAMLEmailSubsystem.InterpreterSpec Wire.ScimSubsystem.InterpreterSpec + Wire.StoredConversationSpec Wire.TeamCollaboratorsSubsystem.InterpreterSpec Wire.TeamInvitationSubsystem.InterpreterSpec Wire.UserGroupSubsystem.InterpreterSpec diff --git a/nix/haskell-pins.nix b/nix/haskell-pins.nix index 79f352ca20f..c7fced9fddb 100644 --- a/nix/haskell-pins.nix +++ b/nix/haskell-pins.nix @@ -162,6 +162,11 @@ let amazonka-test = "lib/amazonka-test"; }; }; + + # PR: https://github.com/tvh/hasql-migration/pull/19 + hasql-migration = { + src = inputs.hasql-migration; + }; }; hackagePins = { diff --git a/nix/wire-server.nix b/nix/wire-server.nix index 8c1122d40d0..726fcdaa1e8 100644 --- a/nix/wire-server.nix +++ b/nix/wire-server.nix @@ -63,7 +63,7 @@ let owner = "hercules-ci"; repo = "gitignore.nix"; # put the latest commit sha of gitignore Nix library here: - rev = "a20de23b925fd8264fd7fad6454652e142fd7f73"; + rev = "a19de23b925fd8264fd7fad6454652e142fd7f73"; # use what nix suggests in the mismatch message here: sha256 = "sha256:07vg2i9va38zbld9abs9lzqblz193vc5wvqd6h7amkmwf66ljcgh"; }; @@ -90,6 +90,7 @@ let team-info = [ "team-info" ]; wire-server-enterprise = [ "wire-server-enterprise" ]; migrate-features = [ "migrate-features" ]; + mlsstats = [ "mlsstats" ]; }; inherit (lib) attrsets; diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index 20dc97d1263..981ae2139f6 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -26,7 +26,9 @@ import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Trans.Control import Data.Domain (Domain) +import Data.Id (TeamId) import Data.Map.Strict qualified as Map +import Data.Misc (HttpsUrl) import HTTP2.Client.Manager import Hasql.Pool qualified as Hasql import Hasql.Pool.Extended @@ -43,9 +45,13 @@ import System.Logger qualified as Log import System.Logger.Class (Logger, MonadLogger (..)) import System.Logger.Extended qualified as Log import Util.Options +import Wire.API.Conversation.Protocol (ProtocolTag) +import Wire.API.Team.FeatureFlags (FanoutLimit) import Wire.BackgroundWorker.Options +import Wire.Options.Galley (GuestLinkTTLSeconds, conversationCodeURISettings) import Wire.Options.Galley qualified as Galley import Wire.PostgresMigrationOpts +import Wire.RateLimit.Interpreter (RateLimitEnv, newRateLimitEnv) type IsWorking = Bool @@ -87,7 +93,17 @@ data Env = Env gundeckEndpoint :: Endpoint, sparEndpoint :: Endpoint, galleyEndpoint :: Endpoint, - brigEndpoint :: Endpoint + brigEndpoint :: Endpoint, + maxTeamSize :: !Word32, + maxFanoutSize :: !(Maybe FanoutLimit), + exposeInvitationURLsTeamAllowlist :: !(Maybe [TeamId]), + intraListing :: !Bool, + federationProtocols :: !(Maybe [ProtocolTag]), + guestLinkTTLSeconds :: !(Maybe GuestLinkTTLSeconds), + passwordHashingOptions :: !PasswordHashingOptions, + checkGroupInfo :: !(Maybe Bool), + convCodeURI :: Either HttpsUrl (Map Text HttpsUrl), + passwordHashingRateLimitEnv :: RateLimitEnv } data BackendNotificationMetrics = BackendNotificationMetrics @@ -138,6 +154,14 @@ mkEnv opts galleyOpts = do galleyEndpoint = opts.galley gundeckEndpoint = opts.gundeck sparEndpoint = opts.spar + maxTeamSize = galleyOpts._settings._maxTeamSize + maxFanoutSize = galleyOpts._settings._maxFanoutSize + exposeInvitationURLsTeamAllowlist = galleyOpts._settings._exposeInvitationURLsTeamAllowlist + intraListing = galleyOpts._settings._intraListing + federationProtocols = galleyOpts._settings._federationProtocols + guestLinkTTLSeconds = galleyOpts._settings._guestLinkTTLSeconds + passwordHashingOptions = galleyOpts._settings._passwordHashingOptions + checkGroupInfo = galleyOpts._settings._checkGroupInfo workerRunningGauge <- mkWorkerRunningGauge hasqlPool <- initPostgresPool opts.postgresqlPool galleyOpts._postgresql galleyOpts._postgresqlPassword amqpJobsPublisherChannel <- @@ -146,6 +170,8 @@ mkEnv opts galleyOpts = do amqpBackendNotificationsChannel <- mkRabbitMqChannelMVar logger (Just "background-worker-backend-notifications") $ either id demoteOpts opts.rabbitmq.unRabbitMqOpts + convCodeURI <- conversationCodeURISettings galleyOpts + passwordHashingRateLimitEnv <- newRateLimitEnv galleyOpts._settings._passwordHashingRateLimit pure Env {..} initHttp2Manager :: IO Http2Manager diff --git a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs index 4c13bf2d047..e595330f457 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Jobs/Registry.hs @@ -22,6 +22,7 @@ where import Bilge qualified import Bilge.Retry +import Cassandra (ClientState) import Control.Monad.Catch import Control.Retry import Data.ByteString qualified as BS @@ -32,27 +33,33 @@ import Data.Qualified import Data.Tagged (Tagged) import Data.Text qualified as T import Data.Text.Lazy qualified as TL -import Galley.Types.Error (InternalError, InvalidInput, internalErrorDescription, legalHoldServiceUnavailable) +import Galley.Types.Error (InternalError, internalErrorDescription, legalHoldServiceUnavailable) import Hasql.Pool (UsageError) +import Hasql.Pool qualified as Hasql import Imports import Network.HTTP.Client qualified as Http +import Network.Wai.Utilities.JSONResponse (JSONResponse (..)) import OpenSSL.Session qualified as SSL import Polysemy import Polysemy.Async (asyncToIOFinal) import Polysemy.Conc import Polysemy.Error import Polysemy.Input +import Polysemy.Resource (resourceToIOFinal) import Polysemy.TinyLog qualified as P import Ssl.Util import System.Logger as Logger import System.Logger.Class qualified as Log import URI.ByteString (uriPath) import Wire.API.BackgroundJobs (Job (..)) -import Wire.API.Conversation.Config (ConversationSubsystemConfig) +import Wire.API.Conversation.Config (ConversationSubsystemConfig (..)) +import Wire.API.Error (APIError (toResponse), DynError (..)) import Wire.API.Error.Galley import Wire.API.Federation.Error (FederationError) +import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.Team.Collaborator (TeamCollaboratorsError) -import Wire.API.Team.FeatureFlags (FeatureDefaults (FeatureLegalHoldDisabledPermanently)) +import Wire.API.Team.Feature (LegalholdConfig) +import Wire.API.Team.FeatureFlags (FanoutLimit, FeatureDefaults (FeatureLegalHoldDisabledPermanently), currentFanoutLimit) import Wire.BackendNotificationQueueAccess.RabbitMq qualified as BackendNotificationQueueAccess import Wire.BackgroundJobsPublisher.RabbitMQ (interpretBackgroundJobsPublisherRabbitMQ) import Wire.BackgroundJobsRunner (runJob) @@ -60,24 +67,34 @@ import Wire.BackgroundJobsRunner.Interpreter hiding (runJob) import Wire.BackgroundWorker.Env (AppT, Env (..)) import Wire.BrigAPIAccess.Rpc import Wire.ClientSubsystem.Error (ClientError) +import Wire.CodeStore.Cassandra (interpretCodeStoreToCassandra) +import Wire.CodeStore.DualWrite (interpretCodeStoreToCassandraAndPostgres) +import Wire.CodeStore.Postgres (interpretCodeStoreToPostgres) import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres (interpretConversationStoreToPostgres) -import Wire.ConversationSubsystem.Interpreter (interpretConversationSubsystem) +import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemError, GroupInfoCheckEnabled (..), IntraListing (..), interpretConversationSubsystem) import Wire.ExternalAccess.External import Wire.FeaturesConfigSubsystem (getAllTeamFeaturesForServer) import Wire.FeaturesConfigSubsystem.Interpreter (runFeaturesConfigSubsystem) import Wire.FeaturesConfigSubsystem.Types (ExposeInvitationURLsAllowlist (..)) import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess) +import Wire.FederationSubsystem.Interpreter (runFederationSubsystem) import Wire.FireAndForget (interpretFireAndForget) import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess.Rpc (interpretGalleyAPIAccessToRpc) import Wire.GundeckAPIAccess +import Wire.HashPassword.Interpreter (runHashPassword) import Wire.LegalHoldStore.Cassandra (interpretLegalHoldStoreToCassandra) import Wire.LegalHoldStore.Env (LegalHoldEnv (..)) import Wire.NotificationSubsystem.Interpreter +import Wire.Options.Galley (GuestLinkTTLSeconds) import Wire.ParseException import Wire.PostgresMigrationOpts +import Wire.ProposalStore.Cassandra (interpretProposalStoreToCassandra) +import Wire.RateLimit (RateLimitExceeded) +import Wire.RateLimit.Interpreter (interpretRateLimit) import Wire.Rpc +import Wire.RpcException import Wire.Sem.Concurrency (ConcurrencySafety (Unsafe)) import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) import Wire.Sem.Delay (runDelay) @@ -174,45 +191,54 @@ dispatchJob job = do let makeReq fpr url rb = makeVerifiedRequestIO env.logger extEnv fpr url rb makeReqFresh fpr url rb = makeVerifiedRequestFreshManagerIO env.logger fpr url rb in LegalHoldEnv {makeVerifiedRequest = makeReq, makeVerifiedRequestFreshManager = makeReqFresh} + convCodesStoreInterpreter = + case env.postgresMigration.conversationCodes of + CassandraStorage -> interpretCodeStoreToCassandra + MigrationToPostgresql -> interpretCodeStoreToCassandraAndPostgres + PostgresqlStorage -> interpretCodeStoreToPostgres runFinal @IO . unsafelyPerformConcurrency @_ @'Unsafe . embedToFinal @IO . asyncToIOFinal . interpretRace . runDelay + . resourceToIOFinal . runError + . mapError @DynError (.eMessage) + . mapError @JSONResponse (T.pack . show . (.value)) + . mapError @ConversationSubsystemError toResponse + . mapError @RpcException (T.pack . displayException) . mapError @ClientError (T.pack . displayException) . mapError @FederationError (T.pack . displayException) . mapError @UsageError (T.pack . show) . mapError @ParseException (T.pack . displayException) - . mapError (const ("Invalid input" :: Text) :: InvalidInput -> Text) . mapError @MigrationError (T.pack . show) . mapError @InternalError (TL.toStrict . internalErrorDescription) . mapError @UnreachableBackends (T.pack . show) . mapError @TeamCollaboratorsError (const ("Team collaborators error" :: Text)) . mapError @TeamFeatureStoreError (const ("Team feature store error" :: Text)) - . mapError @(Tagged HistoryNotSupported ()) (const ("History not supported" :: Text)) - . mapError @(Tagged OperationDenied ()) (const ("Operation denied" :: Text)) . mapError @(Tagged 'NotATeamMember ()) (const ("Not a team member" :: Text)) . mapError @(Tagged 'ConvAccessDenied ()) (const ("Conversation access denied" :: Text)) - . mapError @(Tagged 'NotConnected ()) (const ("Not connected" :: Text)) - . mapError @(Tagged 'MLSNotEnabled ()) (const ("MLS not enabled" :: Text)) - . mapError @(Tagged 'MLSNonEmptyMemberList ()) (const ("MLS non-empty member list" :: Text)) - . mapError @(Tagged 'MissingLegalholdConsent ()) (const ("Missing legalhold consent" :: Text)) - . mapError @(Tagged 'NonBindingTeam ()) (const ("Non-binding team" :: Text)) - . mapError @(Tagged 'NoBindingTeamMembers ()) (const ("No binding team members" :: Text)) . mapError @(Tagged 'TeamNotFound ()) (const ("Team not found" :: Text)) - . mapError @(Tagged 'InvalidOperation ()) (const ("Invalid operation" :: Text)) - . mapError @(Tagged 'ConvNotFound ()) (const ("Conversation not found" :: Text)) - . mapError @(Tagged 'ChannelsNotEnabled ()) (const ("Channels not enabled" :: Text)) - . mapError @(Tagged 'NotAnMlsConversation ()) (const ("Not an MLS conversation" :: Text)) + . mapError @(Tagged 'TeamMemberNotFound ()) (const ("Team member not found" :: Text)) + . mapError @(Tagged 'AccessDenied ()) (const ("Access denied" :: Text)) + . mapError @NonFederatingBackends (const ("Non federating backends" :: Text)) + . mapError @UnreachableBackendsLegacy (const ("Unreachable backends legacy" :: Text)) + . mapError @RateLimitExceeded (const ("Rate limit exceeded" :: Text)) . interpretTinyLog env job.requestId job.jobId - . runInputConst env.hasqlPool - . runInputConst (toLocalUnsafe env.federationDomain ()) - . runInputConst (FeatureLegalHoldDisabledPermanently) - . runInputConst env.cassandraGalley - . runInputConst legalHoldEnv - . runInputConst (ExposeInvitationURLsAllowlist []) + . runInputConst @Hasql.Pool env.hasqlPool + . runInputConst @(Local ()) (toLocalUnsafe env.federationDomain ()) + . runInputConst @(FeatureDefaults LegalholdConfig) FeatureLegalHoldDisabledPermanently + . runInputConst @ClientState env.cassandraGalley + . runInputConst @LegalHoldEnv legalHoldEnv + . runInputConst @ExposeInvitationURLsAllowlist (ExposeInvitationURLsAllowlist $ fromMaybe [] env.exposeInvitationURLsTeamAllowlist) + . runInputConst @(Either HttpsUrl (Map Text HttpsUrl)) env.convCodeURI + . runInputConst @IntraListing (IntraListing env.intraListing) + . runInputConst @(Maybe GroupInfoCheckEnabled) (GroupInfoCheckEnabled <$> env.checkGroupInfo) + . runInputConst @(Maybe GuestLinkTTLSeconds) env.guestLinkTTLSeconds + . runInputConst @FanoutLimit (currentFanoutLimit env.maxTeamSize env.maxFanoutSize) + . interpretMLSCommitLockStoreToCassandra env.cassandraGalley + . interpretProposalStoreToCassandra . interpretServiceStoreToCassandra env.cassandraBrig . interpretUserGroupStoreToPostgres . interpretTeamFeatureStoreToCassandra @@ -235,12 +261,20 @@ dispatchJob job = do . interpretBrigAccess env.brigEndpoint . interpretGalleyAPIAccessToRpc mempty env.galleyEndpoint . runInputSem getConversationSubsystemConfig + . runInputSem @(Maybe (MLSKeysByPurpose MLSPrivateKeys)) (inputs @ConversationSubsystemConfig (.mlsKeys)) . runInputSem getConfiguredFeatureFlags + . runHashPassword env.passwordHashingOptions + . interpretRateLimit env.passwordHashingRateLimitEnv + . convCodesStoreInterpreter . interpretExternalAccess extEnv . interpretSparAPIAccessToRpc env.sparEndpoint . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig job.requestId) . interpretFederationAPIAccess federationAPIAccessConfig . interpretTeamSubsystem teamSubsystemConfig + . ( \m -> do + p <- inputs @ConversationSubsystemConfig (.federationProtocols) + runFederationSubsystem p m + ) . runFeaturesConfigSubsystem . runInputSem getAllTeamFeaturesForServer . interpretTeamCollaboratorsSubsystem @@ -252,6 +286,7 @@ dispatchJob job = do Sem r ConversationSubsystemConfig getConversationSubsystemConfig = getConversationConfig + backendQueueEnv :: Env -> BackendNotificationQueueAccess.Env backendQueueEnv env = BackendNotificationQueueAccess.Env { channelMVar = env.amqpBackendNotificationsChannel, diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 30a9c045733..a3730bdaf27 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -57,7 +57,7 @@ import Test.Hspec import Test.QuickCheck import Test.Wire.Util import UnliftIO.Async -import Util.Options +import Util.Options (Endpoint (..), PasswordHashingOptions (..)) import Wire.API.Conversation.Action import Wire.API.Federation.API import Wire.API.Federation.API.Brig @@ -70,6 +70,7 @@ import Wire.BackgroundWorker.Env import Wire.BackgroundWorker.Options import Wire.BackgroundWorker.Util import Wire.PostgresMigrationOpts +import Wire.RateLimit.Interpreter (newRateLimitEnv) spec :: Spec spec = do @@ -371,7 +372,17 @@ spec = do brigEndpoint = undefined sparEndpoint = undefined galleyEndpoint = undefined - + maxTeamSize = 1000 + maxFanoutSize = Nothing + exposeInvitationURLsTeamAllowlist = Nothing + intraListing = True + federationProtocols = Nothing + guestLinkTTLSeconds = Nothing + passwordHashingOptions = PasswordHashingScrypt + checkGroupInfo = Nothing + convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") + + passwordHashingRateLimitEnv <- newRateLimitEnv defTestRateLimitConfig backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge domains <- runAppT Env {..} $ getRemoteDomains (fromJust rabbitmqAdminClient) @@ -412,6 +423,17 @@ spec = do brigEndpoint = undefined sparEndpoint = undefined galleyEndpoint = undefined + maxTeamSize = 1000 + maxFanoutSize = Nothing + exposeInvitationURLsTeamAllowlist = Nothing + intraListing = True + federationProtocols = Nothing + guestLinkTTLSeconds = Nothing + passwordHashingOptions = PasswordHashingScrypt + checkGroupInfo = Nothing + convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") + + passwordHashingRateLimitEnv <- newRateLimitEnv defTestRateLimitConfig backendNotificationMetrics <- mkBackendNotificationMetrics workerRunningGauge <- mkWorkerRunningGauge domainsThread <- async $ runAppT Env {..} $ getRemoteDomains (fromJust rabbitmqAdminClient) diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index 9810b9c2659..6aa6afa8c91 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -26,11 +26,12 @@ import Data.Range import Imports import Network.HTTP.Client hiding (Proxy) import System.Logger.Class qualified as Logger -import Util.Options (Endpoint (..)) +import Util.Options (Endpoint (..), PasswordHashingOptions (..)) import Wire.BackgroundWorker.Env hiding (federatorInternal) import Wire.BackgroundWorker.Env qualified as E import Wire.BackgroundWorker.Options import Wire.PostgresMigrationOpts +import Wire.RateLimit.Interpreter (RateLimitConfig (..), TokenBucketConfig (..), newRateLimitEnv) testEnv :: IO Env testEnv = do @@ -68,8 +69,30 @@ testEnv = do brigEndpoint = undefined sparEndpoint = Endpoint "localhost" 0 galleyEndpoint = undefined + maxTeamSize = 1000 + maxFanoutSize = Nothing + exposeInvitationURLsTeamAllowlist = Nothing + intraListing = True + federationProtocols = Nothing + guestLinkTTLSeconds = Nothing + passwordHashingOptions = PasswordHashingScrypt + checkGroupInfo = Nothing + convCodeURI = Left (fromRight (error "Failed to parse test HttpsUrl") $ httpsUrlFromText "https://localhost") + passwordHashingRateLimitEnv <- newRateLimitEnv defTestRateLimitConfig pure Env {..} +defTestRateLimitConfig :: RateLimitConfig +defTestRateLimitConfig = + RateLimitConfig + { ipv4CidrBlock = 32, + ipv6CidrBlock = 128, + ipAddressExceptions = [], + maxRateLimitedKeys = 1000, + ipAddrLimit = TokenBucketConfig {burst = 100, inverseRate = 1_000_000}, + userLimit = TokenBucketConfig {burst = 100, inverseRate = 1_000_000}, + internalLimit = TokenBucketConfig {burst = 100, inverseRate = 1_000_000} + } + runTestAppT :: AppT IO a -> Int -> IO a runTestAppT app port = do baseEnv <- testEnv diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 1f711c37aec..70e95dcd393 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -332,6 +332,7 @@ executable brig-index build-depends: , base , brig + , extended , imports , optparse-applicative , tinylog diff --git a/services/brig/index/src/Main.hs b/services/brig/index/src/Main.hs index bf2412d475c..99ea1f0c595 100644 --- a/services/brig/index/src/Main.hs +++ b/services/brig/index/src/Main.hs @@ -25,7 +25,7 @@ import Brig.Index.Options import Imports import Options.Applicative import System.Exit -import System.Logger.Class qualified as Log +import System.Logger.Extended qualified as Log main :: IO () main = do @@ -39,9 +39,4 @@ main = do header "brig-index" <> progDesc "Brig Search Index Utilities" <> fullDesc - initLogger = - Log.new -- TODO: use mkLogger'? - . Log.setOutput Log.StdOut - . Log.setFormat Nothing - . Log.setBufSize 0 - $ Log.defSettings + initLogger = Log.mkLogger Log.Debug Nothing (Just $ Last Log.JSON) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index a5eb8d4f30b..270f1a7affa 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -42,6 +42,7 @@ import Data.ZAuth.CryptoSign (CryptoSign, runCryptoSign) import Hasql.Pool (UsageError) import Hasql.Pool qualified as Hasql import Imports +import Network.Wai.Utilities.Error qualified as Wai import Polysemy import Polysemy.Async import Polysemy.Conc @@ -50,6 +51,8 @@ import Polysemy.Error (Error, errorToIOFinal, mapError, runError) import Polysemy.Input (Input, runInputConst) import Polysemy.Internal.Kind import Polysemy.TinyLog (TinyLog) +import Wire.API.Error (ErrorS, errorToWai) +import Wire.API.Error.Galley import Wire.API.Federation.Client qualified import Wire.API.Federation.Error import Wire.API.Team.Collaborator @@ -209,6 +212,9 @@ type BrigLowerLevelEffects = Error VerificationCodeSubsystemError, Error PropertySubsystemError, Error RateLimitExceeded, + ErrorS 'TeamMemberNotFound, + ErrorS 'TeamNotFound, + Error Wai.Error, Wire.FederationAPIAccess.FederationAPIAccess Wire.API.Federation.Client.FederatorClient, DomainVerificationChallengeStore, DomainRegistrationStore, @@ -437,6 +443,9 @@ runBrigToIO e (AppT ma) = do . interpretDomainRegistrationStoreToCassandra e.casClient . interpretDomainVerificationChallengeStoreToCassandra e.casClient e.settings.challengeTTL . interpretFederationAPIAccess federationApiAccessConfig + . mapError StdError -- Wai.Error + . mapError (const $ errorToWai @'TeamNotFound) -- ErrorS 'TeamNotFound + . mapError (const $ errorToWai @'TeamMemberNotFound) -- ErrorS 'TeamMemberNotFound . mapError rateLimitExceededToHttpError . mapError propertySubsystemErrorToHttpError . mapError verificationCodeSubsystemErrorToHttpError diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index e6196546041..f2b1baa3d1f 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -25,7 +25,8 @@ import Brig.App (initHttpManagerWithTLSConfig, mkIndexEnv) import Brig.Index.Options as IxOpts import Brig.Options as Opt import Brig.User.Search.Index -import Cassandra (Client, runClient) +import Cassandra (ClientState) +import Cassandra.Options import Cassandra.Util (defInitCassandra) import Control.Exception (throwIO) import Control.Lens @@ -39,83 +40,56 @@ import Data.Id import Database.Bloodhound qualified as ES import Database.Bloodhound.Internal.Client (BHEnv (..)) import Hasql.Pool -import Hasql.Pool.Extended import Imports +import Network.HTTP.Client (Manager) import Polysemy -import Polysemy.Embed (runEmbedded) import Polysemy.Error -import Polysemy.Input -import Polysemy.TinyLog hiding (Logger) +import Polysemy.TinyLog (TinyLog) import System.Logger qualified as Log import System.Logger.Class (Logger) import Util.Options -import Wire.API.Federation.Client (FederatorClient) -import Wire.API.Federation.Error -import Wire.AppStore -import Wire.AppStore.Postgres -import Wire.BlockListStore (BlockListStore) -import Wire.BlockListStore.Cassandra import Wire.ClientSubsystem.Error (ClientError) -import Wire.FederationAPIAccess -import Wire.FederationAPIAccess.Interpreter (noFederationAPIAccess) -import Wire.FederationConfigStore (FederationConfigStore) -import Wire.FederationConfigStore.Cassandra (interpretFederationDomainConfig) -import Wire.GalleyAPIAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess.Rpc import Wire.IndexedUserStore -import Wire.IndexedUserStore.Bulk (IndexedUserStoreBulk) -import Wire.IndexedUserStore.Bulk qualified as IndexedUserStoreBulk -import Wire.IndexedUserStore.Bulk.ElasticSearch (interpretIndexedUserStoreBulk) +import Wire.IndexedUserStore.Bulk.ElasticSearch qualified as IndexedUserStoreBulk import Wire.IndexedUserStore.ElasticSearch import Wire.IndexedUserStore.MigrationStore (IndexedUserMigrationStore) import Wire.IndexedUserStore.MigrationStore.ElasticSearch import Wire.ParseException import Wire.Rpc -import Wire.Sem.Concurrency -import Wire.Sem.Concurrency.IO import Wire.Sem.Logger.TinyLog -import Wire.Sem.Metrics +import Wire.Sem.Metrics (Metrics) import Wire.Sem.Metrics.IO import Wire.UserKeyStore (UserKeyStore) import Wire.UserKeyStore.Cassandra import Wire.UserSearch.Migration (MigrationException) -import Wire.UserStore +import Wire.UserStore (UserStore) import Wire.UserStore.Cassandra -import Wire.UserSubsystem.Error type BrigIndexEffectStack = - [ IndexedUserStoreBulk, - UserKeyStore, - BlockListStore, - Error UserSubsystemError, - FederationAPIAccess FederatorClient, - Error FederationError, + [ UserKeyStore, UserStore, - AppStore, IndexedUserStore, Error IndexedUserStoreError, IndexedUserMigrationStore, Error MigrationException, - FederationConfigStore, GalleyAPIAccess, Error ParseException, Rpc, Metrics, TinyLog, - Concurrency 'Unsafe, - Input Pool, Error UsageError, Error ClientError, Embed IO, Final IO ] -runSem :: ESConnectionSettings -> CassandraSettings -> PostgresSettings -> Endpoint -> Logger -> Sem BrigIndexEffectStack a -> IO a -runSem esConn cas pg galleyEndpoint logger action = do +mkSemDeps :: ESConnectionSettings -> CassandraSettings -> Logger -> IO (Manager, ClientState, BHEnv, IndexedUserStoreConfig, RequestId, IndexName) +mkSemDeps esConn cas logger = do mgr <- initHttpManagerWithTLSConfig esConn.esInsecureSkipVerifyTls esConn.esCaCert mEsCreds :: Maybe Credentials <- for esConn.esCredentials initCredentials casClient <- defInitCassandra (toCassandraOpts cas) logger - pgPool <- initPostgresPool pg.pool pg.settings pg.passwordFile let bhEnv = BHEnv { bhServer = toESServer esConn.esServer, @@ -133,32 +107,25 @@ runSem esConn cas pg galleyEndpoint logger action = do } reqId = (RequestId "brig-index") migrationIndexName = fromMaybe defaultMigrationIndexName (esMigrationIndexName esConn) + pure (mgr, casClient, bhEnv, indexedUserStoreConfig, reqId, migrationIndexName) + +runSem :: (Manager, ClientState, BHEnv, IndexedUserStoreConfig, RequestId, IndexName) -> Endpoint -> Logger -> Sem BrigIndexEffectStack a -> IO a +runSem (mgr, casClient, bhEnv, indexedUserStoreConfig, reqId, migrationIndexName) galleyEndpoint logger action = do runFinal . embedToFinal . throwErrorToIOFinal @ClientError . throwErrorToIOFinal @UsageError - . runInputConst pgPool - . unsafelyPerformConcurrency . loggerToTinyLogReqId reqId logger . ignoreMetrics . runRpcWithHttp mgr reqId . throwErrorToIOFinal @ParseException . interpretGalleyAPIAccessToRpc mempty galleyEndpoint - . runEmbedded (runClient casClient) - . interpretFederationDomainConfig casClient Nothing mempty - . raiseUnder @(Embed Client) . throwErrorToIOFinal @MigrationException . interpretIndexedUserMigrationStoreES bhEnv migrationIndexName . throwErrorToIOFinal @IndexedUserStoreError . interpretIndexedUserStoreES indexedUserStoreConfig - . interpretAppStoreToPostgres . interpretUserStoreCassandra casClient - . throwErrorToIOFinal @FederationError - . noFederationAPIAccess - . throwErrorToIOFinal @UserSubsystemError - . interpretBlockListStoreToCassandra casClient . interpretUserKeyStoreCassandra casClient - . interpretIndexedUserStoreBulk $ action throwErrorToIOFinal :: (Exception e, Member (Final IO) r) => InterpreterFor (Error e) r @@ -175,18 +142,18 @@ runCommand l = \case Reset es galley -> do e <- initIndex l (es ^. esConnection) galley runIndexIO e $ resetIndex (mkCreateIndexSettings es) - Reindex es cas pg galley -> do - runSem (es ^. esConnection) cas pg galley l $ - IndexedUserStoreBulk.syncAllUsers - ReindexSameOrNewer es cas pg galley -> do - runSem (es ^. esConnection) cas pg galley l $ - IndexedUserStoreBulk.forceSyncAllUsers + Reindex es cas _pg galley -> do + semDeps <- mkSemDeps (es ^. esConnection) cas l + IndexedUserStoreBulk.syncAllUsers (runSem semDeps galley l) + ReindexSameOrNewer es cas _pg galley -> do + semDeps <- mkSemDeps (es ^. esConnection) cas l + IndexedUserStoreBulk.forceSyncAllUsers (runSem semDeps galley l) UpdateMapping esConn galley -> do e <- initIndex l esConn galley runIndexIO e updateMapping - Migrate es cas pg galley -> do - runSem (es ^. esConnection) cas pg galley l $ - IndexedUserStoreBulk.migrateData + Migrate es cas _pg galley -> do + semDeps <- mkSemDeps (es ^. esConnection) cas l + IndexedUserStoreBulk.migrateData (runSem semDeps galley l) ReindexFromAnotherIndex reindexSettings -> do mgr <- initHttpManagerWithTLSConfig diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index 2fb1fbdf5fa..966bec0f148 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -396,12 +396,14 @@ testSearchNoMatch brig = do testSearchNoExtraResults :: (TestConstraints m) => Brig -> m () testSearchNoExtraResults brig = do - u1 <- randomUser brig - u2 <- randomUser brig + u1Handle <- ("zqnoextra1-" <>) <$> randomHandle + u1 <- createUser' True u1Handle brig + u2Handle <- ("zqnoextra2-" <>) <$> randomHandle + u2 <- createUser' True u2Handle brig let uid1 = userId u1 quid2 = userQualifiedId u2 refreshIndex brig - resultUIds <- map contactQualifiedId . searchResults <$> executeSearch brig uid1 (fromName $ userDisplayName u2) + resultUIds <- map contactQualifiedId . searchResults <$> executeSearch brig uid1 u2Handle liftIO $ assertEqual "Expected search returns only the searched" [quid2] resultUIds diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 174eb48a4b8..66e1ead9e28 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -154,7 +154,7 @@ testTeamSize brig req = do void $ get (req tid uid) =0.2 , cassandra-util >=0.16.2 , cassava >=0.5.2 - , comonad , containers >=0.5 , data-default , errors >=2.0 , exceptions >=0.4 , extended - , extra >=1.3 , galley-types >=0.65.0 , hasql-pool - , hex , hs-opentelemetry-instrumentation-wai , hs-opentelemetry-sdk , HsOpenSSL >=0.11 @@ -276,11 +236,9 @@ library , servant , servant-server , singletons - , sop-core , split >=0.2 , ssl-util >=0.1 , stm >=2.4 - , tagged , text >=0.11 , time >=1.4 , tinylog >=0.10 @@ -291,7 +249,6 @@ library , uri-bytestring >=0.2 , utf8-string , uuid >=1.3 - , vector , wai >=3.0 , wai-extra >=3.0 , wai-middleware-gunzip >=0.0.2 @@ -520,35 +477,3 @@ executable galley-schema if flag(static) ld-options: -static - -test-suite galley-tests - import: common-all - type: exitcode-stdio-1.0 - main-is: ../unit.hs - other-modules: - Paths_galley - Run - Test.Galley.API.Message - Test.Galley.API.One2One - Test.Galley.Mapping - - ghc-options: -threaded -with-rtsopts=-N -Wno-x-partial - hs-source-dirs: test/unit - build-depends: - , base - , containers - , extra >=1.3 - , galley - , galley-types - , imports - , lens - , polysemy - , polysemy-wire-zoo - , tasty - , tasty-hunit - , tasty-quickcheck - , types-common - , uuid-types - , wire-api - , wire-api-federation - , wire-subsystems diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs deleted file mode 100644 index 638e2b56cfe..00000000000 --- a/services/galley/src/Galley/API/Create.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.API.Create where - -import Data.Id -import Data.Qualified -import Data.Set qualified as Set -import Galley.API.Mapping -import Galley.Types.Error -import Imports -import Polysemy -import Polysemy.Error -import Polysemy.TinyLog qualified as P -import Wire.API.Conversation (CreateGroupConversation (..), CreateGroupOwnConversation (..), NewConv, NewOne2OneConv) -import Wire.API.Conversation qualified as Public -import Wire.API.Error.Galley (UnreachableBackendsLegacy (..)) -import Wire.API.Event.Conversation (Connect) -import Wire.API.FederationStatus (RemoteDomains (..)) -import Wire.API.Routes.Public.Galley.Conversation -import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -import Wire.API.User (baseProtocolToProtocol) -import Wire.ConversationSubsystem qualified as ConversationSubsystem -import Wire.FederationSubsystem (FederationSubsystem, checkFederationStatus, enforceFederationProtocol) - ----------------------------------------------------------------------------- --- API Handlers - -createGroupConversationUpToV3 :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error UnreachableBackendsLegacy) r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r (ConversationResponse Public.OwnConversation) -createGroupConversationUpToV3 lusr conn newConv = mapError UnreachableBackendsLegacy $ do - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - Created <$> conversationViewV9 lusr dbConv - -createGroupOwnConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member FederationSubsystem r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversationResponseV9 -createGroupOwnConversation lusr conn newConv = do - let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) - enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains - checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - GroupConversationCreatedV9 <$> (CreateGroupOwnConversation <$> conversationViewV9 lusr dbConv <*> pure mempty) - -createGroupConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member FederationSubsystem r - ) => - Local UserId -> - Maybe ConnId -> - NewConv -> - Sem r CreateGroupConversation -createGroupConversation lusr conn newConv = do - let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) - enforceFederationProtocol (baseProtocolToProtocol newConv.newConvProtocol) remoteDomains - checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) - dbConv <- ConversationSubsystem.createGroupConversation lusr conn newConv - pure $ - CreateGroupConversation - { conversation = conversationView (qualifyAs lusr ()) (Just lusr) dbConv, - failedToAdd = mempty - } - -createProteusSelfConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Sem r (ConversationResponse Public.OwnConversation) -createProteusSelfConversation lusr = do - (c, created) <- ConversationSubsystem.createProteusSelfConversation lusr - if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c - -createOne2OneConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - ConnId -> - NewOne2OneConv -> - Sem r (ConversationResponse Public.OwnConversation) -createOne2OneConversation lusr zcon j = do - (c, created) <- ConversationSubsystem.createOne2OneConversation lusr zcon j - if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c - ----------------------------------------------------------------------------- --- Helpers - -createConnectConversation :: - ( Member ConversationSubsystem.ConversationSubsystem r, - Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - Maybe ConnId -> - Connect -> - Sem r (ConversationResponse Public.OwnConversation) -createConnectConversation lusr conn j = do - (c, created) <- ConversationSubsystem.createConnectConversation lusr conn j - if created - then Created <$> conversationViewV9 lusr c - else Existed <$> conversationViewV9 lusr c diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 560000626df..d1e47cae92a 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -17,15 +17,19 @@ module Galley.API.Federation where -import Galley.API.Federation.Handlers +import Data.Domain import Galley.App +import Imports import Polysemy import Servant (ServerT) import Servant.API import Wire.API.Federation.API +import Wire.API.Federation.API.Common (EmptyResponse (..)) +import Wire.API.Federation.API.Galley import Wire.API.Federation.Endpoint import Wire.API.Federation.Version import Wire.API.Routes.Named +import Wire.ConversationSubsystem as ConversationSubsystem type FederationAPI = "federation" :> FedApi 'Galley @@ -33,26 +37,42 @@ type FederationAPI = "federation" :> FedApi 'Galley federationSitemap :: ServerT FederationAPI (Sem GalleyEffects) federationSitemap = - Named @"on-conversation-created" onConversationCreated - :<|> Named @"get-conversations@v1" getConversationsV1 - :<|> Named @"get-conversations" getConversations - :<|> Named @"leave-conversation" leaveConversation - :<|> Named @"send-message" sendMessage - :<|> Named @"update-conversation" updateConversation - :<|> Named @"mls-welcome" mlsSendWelcome - :<|> Named @"send-mls-message" sendMLSMessage - :<|> Named @"send-mls-commit-bundle" sendMLSCommitBundle - :<|> Named @"query-group-info" queryGroupInfo - :<|> Named @"update-typing-indicator" updateTypingIndicator - :<|> Named @"on-typing-indicator-updated" onTypingIndicatorUpdated - :<|> Named @"get-sub-conversation" getSubConversationForRemoteUser - :<|> Named @"delete-sub-conversation" deleteSubConversationForRemoteUser - :<|> Named @"leave-sub-conversation" leaveSubConversation - :<|> Named @"get-one2one-conversation@v1" getOne2OneConversationV1 - :<|> Named @"get-one2one-conversation" getOne2OneConversation - :<|> Named @"on-client-removed" onClientRemoved - :<|> Named @"on-message-sent" onMessageSent - :<|> Named @"on-mls-message-sent" onMLSMessageSent + Named @"on-conversation-created" federationOnConversationCreated + :<|> Named @"get-conversations@v1" federationGetLegacyConversations + :<|> Named @"get-conversations" federationGetConversations + :<|> Named @"leave-conversation" federationLeaveConversation + :<|> Named @"send-message" federationSendMessage + :<|> Named @"update-conversation" federationUpdateConversation + :<|> Named @"mls-welcome" federationMlsSendWelcome + :<|> Named @"send-mls-message" federationSendMLSMessage + :<|> Named @"send-mls-commit-bundle" federationSendMLSCommitBundle + :<|> Named @"query-group-info" federationQueryGroupInfo + :<|> Named @"update-typing-indicator" federationUpdateTypingIndicator + :<|> Named @"on-typing-indicator-updated" federationOnTypingIndicatorUpdated + :<|> Named @"get-sub-conversation" federationGetSubConversationForRemoteUser + :<|> Named @"delete-sub-conversation" federationDeleteSubConversationForRemoteUser + :<|> Named @"leave-sub-conversation" federationLeaveSubConversation + :<|> Named @"get-one2one-conversation@v1" federationGetLegacyOne2OneConversation + :<|> Named @"get-one2one-conversation" federationGetOne2OneConversation + :<|> Named @"on-client-removed" federationOnClientRemoved + :<|> Named @"on-message-sent" federationOnMessageSent + :<|> Named @"on-mls-message-sent" federationOnMLSMessageSent :<|> Named @(Versioned 'V0 "on-conversation-updated") onConversationUpdatedV0 - :<|> Named @"on-conversation-updated" onConversationUpdated - :<|> Named @"on-user-deleted-conversations" onUserDeleted + :<|> Named @"on-conversation-updated" federationOnConversationUpdated + :<|> Named @"on-user-deleted-conversations" federationOnUserDeleted + +onConversationUpdatedV0 :: + (Member ConversationSubsystem r) => + Domain -> + ConversationUpdateV0 -> + Sem r EmptyResponse +onConversationUpdatedV0 domain cu = + federationOnConversationUpdated domain (conversationUpdateFromV0 cu) + +federationGetLegacyConversations :: + (Member ConversationSubsystem r) => + Domain -> + GetConversationsRequest -> + Sem r GetConversationsResponse +federationGetLegacyConversations domain req = + getConversationsResponseFromView <$> ConversationSubsystem.federationGetConversations domain req diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 280fc91d94b..221da66c5b2 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -37,22 +37,15 @@ import Data.Qualified import Data.Range import Data.Singletons import Data.Time -import Galley.API.Action -import Galley.API.Clients qualified as Clients -import Galley.API.Create qualified as Create import Galley.API.LegalHold (unsetTeamLegalholdWhitelistedH) -import Galley.API.LegalHold.Conflicts -import Galley.API.MLS.Removal import Galley.API.Public.Servant -import Galley.API.Query qualified as Query import Galley.API.Teams import Galley.API.Teams qualified as Teams import Galley.API.Teams.Features -import Galley.API.Teams.Features.Get -import Galley.API.Update qualified as Update import Galley.App import Galley.Monad import Galley.Queue qualified as Q +import Galley.Types.Clients import Galley.Types.Error import Imports hiding (head) import Network.AMQP qualified as Q @@ -73,7 +66,6 @@ import Wire.API.Event.LeaveReason import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error -import Wire.API.MLS.Keys (MLSKeysByPurpose, MLSPrivateKeys) import Wire.API.Push.V2 qualified as PushV2 import Wire.API.Routes.API import Wire.API.Routes.Internal.Brig.EJPD @@ -82,31 +74,28 @@ import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiTablePaging qualified as MTP import Wire.API.Team.Feature -import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags (FeatureFlags) +import Wire.API.Team.LegalHold (UserLegalHoldStatusEntry (..)) import Wire.API.User (UserIds (cUsers)) import Wire.API.User.Client import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess (BrigAPIAccess) -import Wire.ConversationStore +import Wire.ConversationStore hiding (getConversations) import Wire.ConversationStore qualified as ConversationStore import Wire.ConversationStore.MLS.Types -import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.One2One -import Wire.ConversationSubsystem.Util +import Wire.ConversationSubsystem as Conv +import Wire.ConversationSubsystem.LegalholdConflicts (LegalholdConflicts, LegalholdConflictsOldClients) import Wire.CustomBackendStore -import Wire.ExternalAccess (ExternalAccess) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) +import Wire.FeaturesConfigSubsystem import Wire.FederationSubsystem (getFederationStatus) import Wire.LegalHoldStore as LegalHoldStore import Wire.ListItems import Wire.NotificationSubsystem -import Wire.Options.Galley hiding (brig) -import Wire.ProposalStore (ProposalStore) +import Wire.Options.Galley qualified import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra -import Wire.Sem.Random (Random) import Wire.ServiceStore import Wire.StoredConversation import Wire.StoredConversation qualified as Data @@ -114,7 +103,7 @@ import Wire.TeamStore import Wire.TeamStore qualified as E import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem -import Wire.UserClientIndexStore +import Wire.UserClientIndexStore as UserClientIndexStore import Wire.UserList import Wire.Util @@ -123,13 +112,13 @@ internalAPI = hoistAPI @InternalAPIBase Imports.id $ mkNamedAPI @"status" (pure ()) <@> mkNamedAPI @"delete-user" rmUser - <@> mkNamedAPI @"connect" Create.createConnectConversation + <@> mkNamedAPI @"connect" createConnectConversation <@> mkNamedAPI @"get-conversation-clients" iGetMLSClientListForConv <@> mkNamedAPI @"guard-legalhold-policy-conflicts" guardLegalholdPolicyConflictsH <@> legalholdWhitelistedTeamsAPI <@> iTeamsAPI <@> miscAPI - <@> mkNamedAPI @"upsert-one2one" iUpsertOne2OneConversation + <@> mkNamedAPI @"upsert-one2one" internalUpsertOne2OneConversation <@> featureAPI <@> federationAPI <@> conversationAPI @@ -145,23 +134,20 @@ getConversationConfigH = input iEJPDAPI :: API IEJPDAPI GalleyEffects iEJPDAPI = mkNamedAPI @"get-conversations-by-user" ejpdGetConvInfo --- | An unpaginated, internal http interface to `Query.conversationIdsPageFrom`. Used for +-- | An unpaginated, internal http interface to `conversationIdsPageFrom`. Used for -- EJPD reports. Called locally with very little data for each conv, so we don't expect -- pagination to ever be needed. ejpdGetConvInfo :: forall r. ( Member ConversationStore r, Member ConversationSubsystem r, - Member (Error InternalError) r, - Member (Input (Local ())) r, - Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, - Member P.TinyLog r + Member (Input (Local ())) r ) => UserId -> Sem r [EJPDConvInfo] ejpdGetConvInfo uid = do luid <- qualifyLocal uid - firstPage <- Query.conversationIdsPageFrom luid initialPageRequest + firstPage <- conversationIdsPageFrom luid initialPageRequest getPages luid firstPage where initialPageRequest = mkPageRequest (MTP.MultiTablePagingState MTP.PagingLocals Nothing) @@ -184,7 +170,7 @@ ejpdGetConvInfo uid = do renderedPage <- mapMaybe mk <$> ConversationStore.getConversations (fst $ partitionQualified luid convids) if MTP.mtpHasMore page then do - newPage <- Query.conversationIdsPageFrom luid (mkPageRequest . MTP.mtpPagingState $ page) + newPage <- conversationIdsPageFrom luid (mkPageRequest . MTP.mtpPagingState $ page) morePages <- getPages luid newPage pure $ renderedPage <> morePages else pure renderedPage @@ -195,14 +181,14 @@ federationAPI = conversationAPI :: API IConversationAPI GalleyEffects conversationAPI = - mkNamedAPI @"conversation-get-member" Query.internalGetMember - <@> mkNamedAPI @"conversation-accept-v2" Update.acceptConv - <@> mkNamedAPI @"conversation-block" Update.blockConv - <@> mkNamedAPI @"conversation-unblock" Update.unblockConv - <@> mkNamedAPI @"conversation-meta" Query.getConversationMeta - <@> mkNamedAPI @"conversation-mls-one-to-one" Query.getMLSOne2OneConversationInternal - <@> mkNamedAPI @"conversation-mls-one-to-one-established" Query.isMLSOne2OneEstablished - <@> mkNamedAPI @"get-conversation-by-id" Query.getLocalConversationInternal + mkNamedAPI @"conversation-get-member" internalGetMember + <@> mkNamedAPI @"conversation-accept-v2" acceptConv + <@> mkNamedAPI @"conversation-block" blockConv + <@> mkNamedAPI @"conversation-unblock" unblockConv + <@> mkNamedAPI @"conversation-meta" getConversationMeta + <@> mkNamedAPI @"conversation-mls-one-to-one" getMLSOne2OneConversationInternal + <@> mkNamedAPI @"conversation-mls-one-to-one-established" isMLSOne2OneEstablished + <@> mkNamedAPI @"get-conversation-by-id" getLocalConversationInternal <@> mkNamedAPI @"is-conversation-out-of-sync" ConversationStore.isConversationOutOfSync legalholdWhitelistedTeamsAPI :: API ILegalholdWhitelistedTeamsAPI GalleyEffects @@ -244,22 +230,24 @@ iTeamsAPI = mkAPI $ \tid -> hoistAPIHandler Imports.id (base tid) <@> mkNamedAPI @"finalize-delete-team" (\lusr mconn -> TeamSubsystem.internalFinalizeDeleteTeam lusr mconn tid $> NoContent) <@> hoistAPISegment ( mkNamedAPI @"get-search-visibility-internal" (Teams.getSearchVisibilityInternal tid) - <@> mkNamedAPI @"set-search-visibility-internal" (Teams.setSearchVisibilityInternal (featureEnabledForTeam @SearchVisibilityAvailableConfig) tid) + <@> mkNamedAPI @"set-search-visibility-internal" (Teams.setSearchVisibilityInternal (featureEnabledForTeam (Proxy @SearchVisibilityAvailableConfig)) tid) ) miscAPI :: API IMiscAPI GalleyEffects miscAPI = mkNamedAPI @"get-team-members" Teams.getBindingTeamMembers <@> mkNamedAPI @"get-team-id" lookupBindingTeam - <@> mkNamedAPI @"test-get-clients" Clients.getClients + <@> mkNamedAPI @"test-get-clients" (\uid -> clientIds uid <$> getClients [uid]) <@> mkNamedAPI @"test-add-client" createClient - <@> mkNamedAPI @"test-delete-client" Clients.rmClient + <@> mkNamedAPI @"remove-client" removeClient <@> mkNamedAPI @"add-service" createService <@> mkNamedAPI @"delete-service" deleteService - <@> mkNamedAPI @"i-add-bot" Update.addBot - <@> mkNamedAPI @"delete-bot" Update.rmBot + <@> mkNamedAPI @"i-add-bot" addBot + <@> mkNamedAPI @"delete-bot" rmBot <@> mkNamedAPI @"put-custom-backend" setCustomBackend <@> mkNamedAPI @"delete-custom-backend" deleteCustomBackend + <@> mkNamedAPI @"get-user-lh-status" (\uid mtid -> TeamSubsystem.getLHStatus mtid uid) + <@> mkNamedAPI @"get-users-lh-status" (\userIds -> map (uncurry UserLegalHoldStatusEntry) <$> TeamSubsystem.getLHStatusForUsers (cUsers userIds)) featureAPI1Full :: forall cfg r. @@ -341,7 +329,7 @@ featureAPI = <@> mkNamedAPI @"get-configured-feature-flags" getConfiguredFeatureFlags cellsAPI :: API ICellsAPI GalleyEffects -cellsAPI = mkNamedAPI @"set-cells-state" Update.updateCellsState +cellsAPI = mkNamedAPI @"set-cells-state" updateCellsState getConfiguredFeatureFlags :: forall r. @@ -360,20 +348,13 @@ rmUser :: Member ConversationStore r, Member (Error DynError) r, Member (Error FederationError) r, - Member (Error InternalError) r, - Member ExternalAccess r, Member NotificationSubsystem r, Member ConversationSubsystem r, - Member (Input (Maybe (MLSKeysByPurpose MLSPrivateKeys))) r, + Member TeamSubsystem r, Member Now r, Member (ListItems p2 TeamId) r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, - Member (Input FanoutLimit) r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, Member FeaturesConfigSubsystem r ) => Local UserId -> @@ -383,7 +364,7 @@ rmUser lusr conn = do let nRange1000 = toRange (Proxy @1000) :: Range 1 1000 Int32 tids <- listTeams (tUnqualified lusr) Nothing maxBound leaveTeams tids - allConvIds <- Query.conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000) + allConvIds <- conversationIdsPageFrom lusr (GetPaginatedConversationIds Nothing nRange1000) goConvPages nRange1000 allConvIds deleteClients (tUnqualified lusr) @@ -396,7 +377,7 @@ rmUser lusr conn = do when (mtpHasMore page) $ do let nextState = mtpPagingState page nextQuery = GetPaginatedConversationIds (Just nextState) range - newCids <- Query.conversationIdsPageFrom lusr nextQuery + newCids <- conversationIdsPageFrom lusr nextQuery goConvPages range newCids leaveTeams page = for_ (pageItems page) $ \tid -> do @@ -405,7 +386,7 @@ rmUser lusr conn = do getFeatureForTeam @_ @LimitedEventFanoutConfig tid >>= ( \case FeatureStatusEnabled -> Left <$> E.getTeamAdmins tid - FeatureStatusDisabled -> Right <$> getTeamMembersForFanout tid + FeatureStatusDisabled -> Right <$> TeamSubsystem.getTeamMembersForFanout tid ) . (.status) uncheckedDeleteTeamMember lusr conn tid (tUnqualified lusr) toNotify @@ -522,7 +503,7 @@ safeForever funName action = guardLegalholdPolicyConflictsH :: ( Member BrigAPIAccess r, - Member (Input Opts) r, + Member (Input FeatureFlags) r, Member P.TinyLog r, Member (ErrorS 'MissingLegalholdConsent) r, Member (ErrorS 'MissingLegalholdConsentOldClients) r, diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index c3e6abcfbe4..9d45370cdee 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -21,7 +21,6 @@ module Galley.API.LegalHold removeSettingsInternalPaging, removeSettings, removeSettings', - getUserStatus, grantConsent, requestDevice, approveDevice, @@ -40,10 +39,7 @@ import Data.Misc import Data.Proxy (Proxy (Proxy)) import Data.Qualified import Data.Range (toRange) -import Galley.API.LegalHold.Get import Galley.API.LegalHold.Team -import Galley.API.Query (iterateConversations) -import Galley.API.Update (removeMemberFromLocalConv) import Galley.External.LegalHoldService qualified as LHService import Galley.Types.Error import Imports @@ -54,12 +50,10 @@ import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger.Class qualified as Log import Wire.API.Conversation (ConvType (..), ConversationMetadata (..)) -import Wire.API.Conversation.Config (ConversationSubsystemConfig) import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Error import Wire.API.Error.Galley -import Wire.API.Federation.Error import Wire.API.Provider.Service import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Public.Galley.LegalHold @@ -72,21 +66,13 @@ import Wire.API.Team.LegalHold.Internal import Wire.API.Team.Member import Wire.API.User hiding (userId) import Wire.API.User.Client.Prekey -import Wire.BackendNotificationQueueAccess import Wire.BrigAPIAccess -import Wire.ConversationStore (ConversationStore) import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Util -import Wire.ExternalAccess (ExternalAccess) import Wire.FeaturesConfigSubsystem import Wire.FireAndForget import Wire.LegalHoldStore qualified as LegalHoldData -import Wire.NotificationSubsystem -import Wire.ProposalStore (ProposalStore) -import Wire.Sem.Now (Now) import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra -import Wire.Sem.Random (Random) import Wire.StoredConversation import Wire.StoredConversation qualified as Data import Wire.TeamMemberStore @@ -97,11 +83,11 @@ import Wire.Util createSettings :: forall r. - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'LegalHoldNotEnabled) r, + ( Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceInvalidKey) r, Member (ErrorS 'LegalHoldServiceBadResponse) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member LegalHoldData.LegalHoldStore r, Member P.TinyLog r, Member (Input (FeatureDefaults LegalholdConfig)) r, @@ -120,7 +106,7 @@ createSettings lzusr tid newService = do -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "LegalHold.createSettings") - void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldTeamSettings zusrMembership (key :: ServiceKey, fpr :: Fingerprint Rsa) <- LegalHoldData.validateServiceKey newService.newLegalHoldServiceKey >>= noteS @'LegalHoldServiceInvalidKey @@ -153,37 +139,28 @@ getSettings lzusr tid = do removeSettingsInternalPaging :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error AuthenticationError) r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'LegalHoldDisableUnimplemented) r, Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (Error AuthenticationError) r, Member FireAndForget r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member (TeamMemberStore InternalPaging) r, Member TeamStore r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (Input (Local ())) r ) => Local UserId -> TeamId -> @@ -197,35 +174,26 @@ removeSettings :: Bounded (PagingBounds p TeamMember), Member (TeamMemberStore p) r, Member TeamStore r, - Member BackendNotificationQueueAccess r, Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error AuthenticationError) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'LegalHoldDisableUnimplemented) r, Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (Error AuthenticationError) r, Member FireAndForget r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, - Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member LegalHoldData.LegalHoldStore r, + Member (Input (Local ())) r ) => UserId -> TeamId -> @@ -239,7 +207,7 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "LegalHold.removeSettings") - void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldTeamSettings zusrMembership ensureReAuthorised zusr mPassword Nothing Nothing removeSettings' @p tid where @@ -257,30 +225,21 @@ removeSettings' :: forall p r. ( Paging p, Bounded (PagingBounds p TeamMember), - Member BackendNotificationQueueAccess r, Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, - Member ExternalAccess r, Member FireAndForget r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, - Member (Input (Local ())) r, + Member TeamSubsystem r, Member LegalHoldData.LegalHoldStore r, Member (TeamMemberStore p) r, Member TeamStore r, - Member ProposalStore r, - Member Random r, Member P.TinyLog r, Member (Embed IO) r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member (Input (Local ())) r ) => TeamId -> Sem r () @@ -308,26 +267,17 @@ removeSettings' tid = -- @withdrawExplicitConsentH@ (lots of corner cases we'd have to implement for that to pan -- out). grantConsent :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member TeamSubsystem r ) => Local UserId -> TeamId -> @@ -346,10 +296,7 @@ grantConsent lusr tid = do -- | Request to provision a device on the legal hold service for a user requestDevice :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -357,27 +304,21 @@ requestDevice :: Member (ErrorS 'LegalHoldServiceBadResponse) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, Member (ErrorS 'MLSLegalholdIncompatible) r, - Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'NoUserLegalHoldConsent) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'UserLegalHoldAlreadyEnabled) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (Input (Local ())) r ) => Local UserId -> TeamId -> @@ -391,7 +332,7 @@ requestDevice lzusr tid uid = do Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.requestDevice") zusrMembership <- TeamSubsystem.internalGetTeamMember zusr tid - void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldUserSettings zusrMembership member <- noteS @'TeamMemberNotFound =<< TeamSubsystem.internalGetTeamMember uid tid case member ^. legalHoldStatus of UserLegalHoldEnabled -> throwS @'UserLegalHoldAlreadyEnabled @@ -406,9 +347,10 @@ requestDevice lzusr tid uid = do where disallowIfMLSUser :: Local UserId -> Sem r () disallowIfMLSUser luid = do - void $ iterateConversations luid (toRange (Proxy @500)) $ \convs -> do - when (any (\c -> c.metadata.cnvmType /= SelfConv && c.protocol /= ProtocolProteus) convs) $ do - throwS @'MLSLegalholdIncompatible + void $ + iterateConversations luid (toRange (Proxy @500)) $ \convs -> do + when (any (\c -> c.metadata.cnvmType /= SelfConv && c.protocol /= ProtocolProteus) convs) $ do + throwS @'MLSLegalholdIncompatible -- Wire's LH service that galley is usually calling here is idempotent in device creation, -- ie. it returns the existing device on multiple calls to `/init`, like here: @@ -440,11 +382,8 @@ requestDevice lzusr tid uid = do -- since they are replaced if needed when registering new LH devices. approveDevice :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, + ( Member BrigAPIAccess r, Member (Error AuthenticationError) r, - Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, @@ -452,25 +391,19 @@ approveDevice :: Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, Member (ErrorS 'NoLegalHoldDeviceAllocated) r, - Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'UserLegalHoldAlreadyEnabled) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, Member (ErrorS 'UserLegalHoldNotPending) r, - Member ExternalAccess r, - Member NotificationSubsystem r, + Member (ErrorS 'NotATeamMember) r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, Member (Embed IO) r, Member (Input (FeatureDefaults LegalholdConfig)) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r, - Member FeaturesConfigSubsystem r + Member FeaturesConfigSubsystem r, + Member (Input (Local ())) r ) => Local UserId -> ConnId -> @@ -486,7 +419,7 @@ approveDevice lzusr connId tid uid (Public.ApproveLegalHoldForUserRequest mPassw Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.approveDevice") unless (zusr == tUnqualified luid) $ throwS @'AccessDenied - assertOnTeam (tUnqualified luid) tid + TeamSubsystem.assertOnTeam (tUnqualified luid) tid ensureReAuthorised zusr mPassword Nothing Nothing userLHStatus <- maybe defUserLegalHoldStatus (view legalHoldStatus) <$> TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid @@ -521,31 +454,22 @@ approveDevice lzusr connId tid uid (Public.ApproveLegalHoldForUserRequest mPassw disableForUser :: forall r. - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error AuthenticationError) r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, - Member (Input (Local ())) r, - Member Now r, Member LegalHoldData.LegalHoldStore r, - Member ProposalStore r, Member P.TinyLog r, - Member Random r, Member TeamStore r, Member (Embed IO) r, Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member (Input (Local ())) r ) => Local UserId -> TeamId -> @@ -558,7 +482,7 @@ disableForUser lzusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.disableForUser") zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified lzusr) tid - void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership + void $ TeamSubsystem.permissionCheck ChangeLegalHoldUserSettings zusrMembership userLHStatus <- maybe defUserLegalHoldStatus (view legalHoldStatus) <$> TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid @@ -589,25 +513,16 @@ disableForUser lzusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = -- 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. changeLegalholdStatusAndHandlePolicyConflicts :: - ( Member BackendNotificationQueueAccess r, - Member BrigAPIAccess r, - Member ConversationStore r, - Member (Error FederationError) r, + ( Member BrigAPIAccess r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member ExternalAccess r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, + Member TeamSubsystem r, Member LegalHoldData.LegalHoldStore r, Member TeamStore r, - Member ProposalStore r, - Member Random r, - Member P.TinyLog r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member P.TinyLog r ) => TeamId -> Local UserId -> @@ -676,7 +591,7 @@ blockNonConsentingConnections uid = do -- FUTUREWORK: Handle remoteUsers here when federation is implemented for (chunksOf 32 localUids) $ \others -> do teamsOfUsers <- getUsersTeams others - filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others + filterM (fmap (== TeamSubsystem.ConsentNotGiven) . TeamSubsystem.checkConsent teamsOfUsers) others blockConflicts :: UserId -> [UserId] -> Sem r [String] blockConflicts _ [] = pure [] @@ -708,21 +623,10 @@ unsetTeamLegalholdWhitelistedH tid = do -- contains the hypothetical new LH status of `uid`'s so it can be consulted instead of the -- one from the database. handleGroupConvPolicyConflicts :: - ( Member BackendNotificationQueueAccess r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (Error InternalError) r, + ( Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, - Member ExternalAccess r, - Member NotificationSubsystem r, Member ConversationSubsystem r, - Member Now r, - Member ProposalStore r, - Member P.TinyLog r, - Member Random r, - Member TeamStore r, - Member TeamSubsystem r, - Member (Input ConversationSubsystemConfig) r + Member TeamSubsystem r ) => Local UserId -> UserLegalHoldStatus -> @@ -735,7 +639,7 @@ handleGroupConvPolicyConflicts luid hypotheticalLHStatus = do membersAndLHStatus :: [(LocalMember, UserLegalHoldStatus)] <- do let mems = conv.localMembers - uidsLHStatus <- getLHStatusForUsers ((.id_) <$> mems) + uidsLHStatus <- TeamSubsystem.getLHStatusForUsers ((.id_) <$> mems) pure $ zipWith ( \mem (mid, status) -> @@ -756,10 +660,10 @@ handleGroupConvPolicyConflicts luid hypotheticalLHStatus = do (InternalErrorWithDescription "conversation disappeared while iterating on a list of conversations") . mapErrorS @('ActionDenied 'LeaveConversation) @('ActionDenied 'RemoveConversationMember) $ if any - ((== ConsentGiven) . consentGiven . snd) + ((== TeamSubsystem.ConsentGiven) . TeamSubsystem.consentGiven . snd) (filter ((== roleNameWireAdmin) . (.convRoleName) . fst) membersAndLHStatus) then do - for_ (filter ((== ConsentNotGiven) . consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do + for_ (filter ((== TeamSubsystem.ConsentNotGiven) . TeamSubsystem.consentGiven . snd) membersAndLHStatus) $ \(memberNoConsent, _) -> do let lusr = qualifyAs luid memberNoConsent.id_ removeMemberFromLocalConv lcnv lusr Nothing (tUntagged lusr) else do diff --git a/services/galley/src/Galley/API/LegalHold/Get.hs b/services/galley/src/Galley/API/LegalHold/Get.hs deleted file mode 100644 index bc3c036beb7..00000000000 --- a/services/galley/src/Galley/API/LegalHold/Get.hs +++ /dev/null @@ -1,78 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.API.LegalHold.Get (getUserStatus) where - -import Control.Lens (view) -import Data.ByteString.Conversion (toByteString') -import Data.Id -import Data.LegalHold (UserLegalHoldStatus (..)) -import Data.Qualified -import Galley.Types.Error -import Imports -import Polysemy -import Polysemy.Error -import Polysemy.TinyLog qualified as P -import System.Logger.Class qualified as Log -import Wire.API.Error -import Wire.API.Error.Galley -import Wire.API.Team.LegalHold -import Wire.API.Team.LegalHold qualified as Public -import Wire.API.Team.Member -import Wire.API.User.Client.Prekey -import Wire.LegalHoldStore qualified as LegalHoldData -import Wire.TeamSubsystem (TeamSubsystem) -import Wire.TeamSubsystem qualified as TeamSubsystem - --- | 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 -getUserStatus :: - forall r. - ( Member (Error InternalError) r, - Member (ErrorS 'TeamMemberNotFound) r, - Member LegalHoldData.LegalHoldStore r, - Member P.TinyLog r, - Member TeamSubsystem r - ) => - Local UserId -> - TeamId -> - UserId -> - Sem r Public.UserLegalHoldStatusResponse -getUserStatus _lzusr tid uid = do - teamMember <- noteS @'TeamMemberNotFound =<< TeamSubsystem.internalGetTeamMember uid tid - let status = view legalHoldStatus teamMember - (mlk, lcid) <- case status of - UserLegalHoldNoConsent -> pure (Nothing, Nothing) - UserLegalHoldDisabled -> pure (Nothing, Nothing) - UserLegalHoldPending -> makeResponseDetails - UserLegalHoldEnabled -> makeResponseDetails - pure $ UserLegalHoldStatusResponse status mlk lcid - where - makeResponseDetails :: Sem r (Maybe LastPrekey, Maybe ClientId) - makeResponseDetails = do - mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid - lastKey <- case mLastKey of - Nothing -> do - P.err - . Log.msg - $ "expected to find a prekey for user: " - <> toByteString' uid - <> " but none was found" - throw NoPrekeyForUser - Just lstKey -> pure lstKey - let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey - pure (Just lastKey, Just clientId) diff --git a/services/galley/src/Galley/API/LegalHold/Team.hs b/services/galley/src/Galley/API/LegalHold/Team.hs index c7f511d4491..3c5d4caecae 100644 --- a/services/galley/src/Galley/API/LegalHold/Team.hs +++ b/services/galley/src/Galley/API/LegalHold/Team.hs @@ -21,19 +21,25 @@ module Galley.API.LegalHold.Team assertLegalHoldEnabledForTeam, ensureNotTooLargeToActivateLegalHold, teamSizeBelowLimit, + ensureReAuthorised, ) where +import Data.Code qualified as Code import Data.Id +import Data.Misc (PlainTextPassword6) import Data.Range import Imports import Polysemy +import Polysemy.Error import Polysemy.Input (Input, input) import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags as Team (FanoutLimit, FeatureDefaults (..)) import Wire.API.Team.Size +import Wire.API.User (VerificationAction) +import Wire.API.User.Auth.ReAuth import Wire.BrigAPIAccess import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getDbFeatureRawInternal) import Wire.LegalHold @@ -74,18 +80,18 @@ ensureNotTooLargeToActivateLegalHold :: TeamId -> Sem r () ensureNotTooLargeToActivateLegalHold tid = do - (TeamSize teamSize) <- getSize tid - unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ + teamSize <- getSize tid + unlessM (teamSizeBelowLimit teamSize) $ throwS @'CannotEnableLegalHoldServiceLargeTeam teamSizeBelowLimit :: ( Member (Input FanoutLimit) r, Member (Input (FeatureDefaults LegalholdConfig)) r ) => - Int -> + TeamSize -> Sem r Bool -teamSizeBelowLimit teamSize = do - limit <- fromIntegral . fromRange <$> input @FanoutLimit +teamSizeBelowLimit (fromIntegral . teamSizeTotal -> teamSize) = do + limit :: Int <- fromIntegral . fromRange <$> input @FanoutLimit let withinLimit = teamSize <= limit featureLegalHold <- input @(FeatureDefaults LegalholdConfig) case featureLegalHold of @@ -94,3 +100,15 @@ teamSizeBelowLimit teamSize = do FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> -- unlimited, see docs of 'ensureNotTooLargeForLegalHold' pure True + +ensureReAuthorised :: + ( Member BrigAPIAccess r, + Member (Error AuthenticationError) r + ) => + UserId -> + Maybe PlainTextPassword6 -> + Maybe Code.Value -> + Maybe VerificationAction -> + Sem r () +ensureReAuthorised u secret mbAction mbCode = + reauthUser u (ReAuthUser secret mbAction mbCode) >>= fromEither diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs deleted file mode 100644 index 3837b9e623b..00000000000 --- a/services/galley/src/Galley/API/Mapping.hs +++ /dev/null @@ -1,163 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.API.Mapping - ( conversationViewV9, - conversationView, - conversationViewWithCachedOthers, - remoteConversationView, - conversationToRemote, - ) -where - -import Data.Domain (Domain) -import Data.Id (UserId, idToText) -import Data.Qualified -import Galley.Types.Error (InternalError (BadMemberState)) -import Imports -import Polysemy -import Polysemy.Error -import Polysemy.TinyLog qualified as P -import System.Logger.Message (msg, val, (+++)) -import Wire.API.Conversation hiding (Member) -import Wire.API.Federation.API.Galley -import Wire.ConversationSubsystem.Util (localMemberToPublic) -import Wire.StoredConversation - --- | View for a given user of a stored conversation. --- --- Throws @BadMemberState@ when the user is not part of the conversation. -conversationViewV9 :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - Local UserId -> - StoredConversation -> - Sem r OwnConversation -conversationViewV9 luid conv = do - let remoteOthers = map remoteMemberToOther $ conv.remoteMembers - localOthers = map (localMemberToOther (tDomain luid)) $ conv.localMembers - conversationViewWithCachedOthers remoteOthers localOthers conv luid - -conversationView :: - Local x -> - Maybe (Local UserId) -> - StoredConversation -> - Conversation -conversationView l luid conv = - let remoteMembers = map remoteMemberToOther $ conv.remoteMembers - localMembers = map (localMemberToOther (tDomain l)) $ conv.localMembers - selfs = filter (\m -> fmap tUnqualified luid == Just m.id_) (conv.localMembers) - mSelf = localMemberToPublic l <$> listToMaybe selfs - others = filter (\oth -> (tUntagged <$> luid) /= Just (omQualifiedId oth)) localMembers <> remoteMembers - in Conversation - { members = ConvMembers mSelf others, - qualifiedId = (tUntagged . qualifyAs l $ conv.id_), - metadata = conv.metadata, - protocol = conv.protocol - } - --- | Like 'conversationView' but optimized for situations which could benefit --- from pre-computing the list of @OtherMember@s in the conversation. For --- instance, creating @ConversationView@ for more than 1 member of the same conversation. -conversationViewWithCachedOthers :: - ( Member (Error InternalError) r, - Member P.TinyLog r - ) => - [OtherMember] -> - [OtherMember] -> - StoredConversation -> - Local UserId -> - Sem r OwnConversation -conversationViewWithCachedOthers remoteOthers localOthers conv luid = do - let mbConv = conversationViewMaybe luid remoteOthers localOthers conv - maybe memberNotFound pure mbConv - where - memberNotFound = do - P.err . msg $ - val "User " - +++ idToText (tUnqualified luid) - +++ val " is not a member of conv " - +++ idToText conv.id_ - throw BadMemberState - --- | View for a given user of a stored conversation. --- --- Returns 'Nothing' if the user is not part of the conversation. -conversationViewMaybe :: Local UserId -> [OtherMember] -> [OtherMember] -> StoredConversation -> Maybe OwnConversation -conversationViewMaybe luid remoteOthers localOthers conv = do - let selfs = filter (\m -> tUnqualified luid == m.id_) conv.localMembers - self <- localMemberToPublic luid <$> listToMaybe selfs - let others = filter (\oth -> tUntagged luid /= omQualifiedId oth) localOthers <> remoteOthers - pure $ - OwnConversation - (tUntagged . qualifyAs luid $ conv.id_) - conv.metadata - (OwnConvMembers self others) - conv.protocol - --- | View for a local user of a remote conversation. -remoteConversationView :: - Local UserId -> - MemberStatus -> - Remote RemoteConversationV2 -> - OwnConversation -remoteConversationView uid status (tUntagged -> Qualified rconv rDomain) = - let mems = rconv.members - others = mems.others - self = - localMemberToPublic - uid - LocalMember - { id_ = tUnqualified uid, - service = Nothing, - status = status, - convRoleName = mems.selfRole - } - in OwnConversation - (Qualified rconv.id rDomain) - rconv.metadata - (OwnConvMembers self others) - rconv.protocol - --- | Convert a local conversation to a structure to be returned to a remote --- backend. --- --- This returns 'Nothing' if the given remote user is not part of the conversation. -conversationToRemote :: - Domain -> - Remote UserId -> - StoredConversation -> - Maybe RemoteConversationV2 -conversationToRemote localDomain ruid conv = do - let (selfs, rothers) = partition (\r -> r.id_ == ruid) (conv.remoteMembers) - lothers = conv.localMembers - selfRole' <- (.convRoleName) <$> listToMaybe selfs - let others' = - map (localMemberToOther localDomain) lothers - <> map remoteMemberToOther rothers - pure $ - RemoteConversationV2 - { id = conv.id_, - metadata = conv.metadata, - members = - RemoteConvMembers - { selfRole = selfRole', - others = others' - }, - protocol = conv.protocol - } diff --git a/services/galley/src/Galley/API/Meetings.hs b/services/galley/src/Galley/API/Meetings.hs index 3321e85ae04..e4e99e2b772 100644 --- a/services/galley/src/Galley/API/Meetings.hs +++ b/services/galley/src/Galley/API/Meetings.hs @@ -18,6 +18,7 @@ module Galley.API.Meetings ( createMeeting, updateMeeting, + deleteMeeting, getMeeting, listMeetings, addMeetingInvitation, @@ -33,48 +34,20 @@ import Polysemy import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Meeting -import Wire.API.Team.Feature (FeatureStatus (..), LockableFeature (..), MeetingsConfig) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getFeatureForTeam) import Wire.MeetingsSubsystem qualified as Meetings -import Wire.TeamStore qualified as TeamStore - --- | Check if meetings feature is enabled for the user (if they're in a team) -checkMeetingsEnabled :: - ( Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r, - Member (ErrorS 'InvalidOperation) r - ) => - UserId -> - Sem r () -checkMeetingsEnabled userId = do - maybeTeamId <- TeamStore.getOneUserTeam userId - case maybeTeamId of - Nothing -> pure () -- Personal users can use meetings - Just teamId -> do - meetingFeature <- getFeatureForTeam @_ @MeetingsConfig teamId - unless (meetingFeature.status == FeatureStatusEnabled) $ - throwS @'InvalidOperation createMeeting :: - ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'InvalidOperation) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r - ) => + (Member Meetings.MeetingsSubsystem r) => Local UserId -> NewMeeting -> Sem r Meeting createMeeting lUser newMeeting = do - checkMeetingsEnabled (tUnqualified lUser) (meeting, _conversation) <- Meetings.createMeeting lUser newMeeting pure meeting updateMeeting :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r + Member (ErrorS 'MeetingNotFound) r ) => Local UserId -> Domain -> @@ -82,26 +55,35 @@ updateMeeting :: UpdateMeeting -> Sem r Meeting updateMeeting zUser domain meetingId update = do - checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain maybeMeeting <- Meetings.updateMeeting zUser qMeetingId update case maybeMeeting of Nothing -> throwS @'MeetingNotFound Just meeting -> pure meeting +deleteMeeting :: + ( Member Meetings.MeetingsSubsystem r, + Member (ErrorS 'MeetingNotFound) r + ) => + Local UserId -> + ConnId -> + Domain -> + MeetingId -> + Sem r () +deleteMeeting zUser connId domain meetingId = do + let qMeetingId = Qualified meetingId domain + success <- Meetings.deleteMeeting zUser connId qMeetingId + unless success $ throwS @'MeetingNotFound + getMeeting :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r, - Member (ErrorS 'InvalidOperation) r + Member (ErrorS 'MeetingNotFound) r ) => Local UserId -> Domain -> MeetingId -> Sem r Meeting getMeeting zUser domain meetingId = do - checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain maybeMeeting <- Meetings.getMeeting zUser qMeetingId case maybeMeeting of @@ -109,23 +91,14 @@ getMeeting zUser domain meetingId = do Just meeting -> pure meeting listMeetings :: - ( Member Meetings.MeetingsSubsystem r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r, - Member (ErrorS 'InvalidOperation) r - ) => + (Member Meetings.MeetingsSubsystem r) => Local UserId -> Sem r [Meeting] -listMeetings lUser = do - checkMeetingsEnabled (tUnqualified lUser) - Meetings.listMeetings lUser +listMeetings lUser = Meetings.listMeetings lUser addMeetingInvitation :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r, - Member (ErrorS 'InvalidOperation) r + Member (ErrorS 'MeetingNotFound) r ) => Local UserId -> Domain -> @@ -133,17 +106,13 @@ addMeetingInvitation :: MeetingEmailsInvitation -> Sem r () addMeetingInvitation zUser domain meetingId (MeetingEmailsInvitation emails) = do - checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain success <- Meetings.addInvitedEmails zUser qMeetingId emails unless success $ throwS @'MeetingNotFound removeMeetingInvitation :: ( Member Meetings.MeetingsSubsystem r, - Member (ErrorS 'MeetingNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r, - Member (ErrorS 'InvalidOperation) r + Member (ErrorS 'MeetingNotFound) r ) => Local UserId -> Domain -> @@ -151,7 +120,6 @@ removeMeetingInvitation :: MeetingEmailsInvitation -> Sem r () removeMeetingInvitation zUser domain meetingId (MeetingEmailsInvitation emails) = do - checkMeetingsEnabled (tUnqualified zUser) let qMeetingId = Qualified meetingId domain success <- Meetings.removeInvitedEmails zUser qMeetingId emails unless success $ throwS @'MeetingNotFound diff --git a/services/galley/src/Galley/API/Public/Bot.hs b/services/galley/src/Galley/API/Public/Bot.hs index ecb4f18eb38..ff47adc6254 100644 --- a/services/galley/src/Galley/API/Public/Bot.hs +++ b/services/galley/src/Galley/API/Public/Bot.hs @@ -18,42 +18,28 @@ module Galley.API.Public.Bot where import Data.Id -import Data.Qualified -import Galley.API.Query qualified as Query -import Galley.API.Teams.Features qualified as Features -import Galley.API.Update import Galley.App import Polysemy -import Polysemy.Input -import Wire.API.Error -import Wire.API.Error.Galley import Wire.API.Event.Team qualified as Public () import Wire.API.Provider.Bot import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Bot -import Wire.ConversationStore (ConversationStore) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem) -import Wire.TeamStore (TeamStore) -import Wire.TeamSubsystem (TeamSubsystem) +import Wire.ConversationSubsystem +import Wire.FeaturesConfigSubsystem botAPI :: API BotAPI GalleyEffects botAPI = mkNamedAPI @"post-bot-message-unqualified" postBotMessageUnqualified - <@> mkNamedAPI @"get-bot-conversation" getBotConversation + <@> mkNamedAPI @"get-bot-conversation" getBotConversationH -getBotConversation :: +getBotConversationH :: forall r. - ( Member ConversationStore r, - Member (Input (Local ())) r, - Member (ErrorS 'AccessDenied) r, - Member (ErrorS 'ConvNotFound) r, - Member TeamStore r, - Member TeamSubsystem r, + ( Member ConversationSubsystem r, Member FeaturesConfigSubsystem r ) => BotId -> ConvId -> Sem r BotConvView -getBotConversation bid cnv = do - Features.guardSecondFactorDisabled (botUserId bid) cnv - Query.getBotConversation bid cnv +getBotConversationH bid cnv = do + guardSecondFactorDisabled (botUserId bid) cnv + getBotConversation bid cnv diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index cbab0c5663a..23598b787cf 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -17,16 +17,14 @@ module Galley.API.Public.Conversation where -import Galley.API.Create -import Galley.API.MLS.GroupInfo -import Galley.API.MLS.SubConversation -import Galley.API.Query -import Galley.API.Update +import Data.Qualified import Galley.App import Imports +import Wire.API.Conversation import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Conversation import Wire.ConversationStore.MLS.Types +import Wire.ConversationSubsystem conversationAPI :: API ConversationAPI GalleyEffects conversationAPI = @@ -39,16 +37,16 @@ conversationAPI = <@> mkNamedAPI @"get-conversation-roles" getConversationRoles <@> mkNamedAPI @"get-group-info" getGroupInfo <@> mkNamedAPI @"list-conversation-ids-unqualified" conversationIdsPageFromUnqualified - <@> mkNamedAPI @"list-conversation-ids-v2" (conversationIdsPageFromV2 DoNotListGlobalSelf) + <@> mkNamedAPI @"list-conversation-ids-v2" (conversationIdsPaginated DoNotListGlobalSelf) <@> mkNamedAPI @"list-conversation-ids" conversationIdsPageFrom - <@> mkNamedAPI @"get-conversations" getConversations + <@> mkNamedAPI @"get-conversations" getPaginatedConversations <@> mkNamedAPI @"list-conversations@v1" listConversations <@> mkNamedAPI @"list-conversations@v2" listConversations <@> mkNamedAPI @"list-conversations@v5" listConversations <@> mkNamedAPI @"list-conversations" listConversations <@> mkNamedAPI @"get-conversation-by-reusable-code" getConversationByReusableCode - <@> mkNamedAPI @"create-group-conversation@v2" createGroupConversationUpToV3 - <@> mkNamedAPI @"create-group-conversation@v3" createGroupConversationUpToV3 + <@> mkNamedAPI @"create-group-conversation@v2" createLegacyGroupConversation + <@> mkNamedAPI @"create-group-conversation@v3" createLegacyGroupConversation <@> mkNamedAPI @"create-group-conversation@v5" createGroupOwnConversation <@> mkNamedAPI @"create-group-conversation@v9" createGroupOwnConversation <@> mkNamedAPI @"create-group-conversation" createGroupConversation @@ -64,40 +62,40 @@ conversationAPI = <@> mkNamedAPI @"create-one-to-one-conversation@v2" createOne2OneConversation <@> mkNamedAPI @"create-one-to-one-conversation@v6" createOne2OneConversation <@> mkNamedAPI @"create-one-to-one-conversation" createOne2OneConversation - <@> mkNamedAPI @"get-one-to-one-mls-conversation@v5" getMLSOne2OneConversationV5 - <@> mkNamedAPI @"get-one-to-one-mls-conversation@v6" getMLSOne2OneConversationV6 + <@> mkNamedAPI @"get-one-to-one-mls-conversation@v5" getMLSOne2OneOwnConversation + <@> mkNamedAPI @"get-one-to-one-mls-conversation@v6" getMLSOne2OneMLSConversation <@> mkNamedAPI @"get-one-to-one-mls-conversation" getMLSOne2OneConversation - <@> mkNamedAPI @"add-members-to-conversation-unqualified" addMembersUnqualified - <@> mkNamedAPI @"add-members-to-conversation-unqualified2" addMembersUnqualifiedV2 + <@> mkNamedAPI @"add-members-to-conversation-unqualified" (\lusr con cnv invite -> addMembers lusr con (tUntagged (qualifyAs lusr cnv)) (InviteQualified (fmap (tUntagged . qualifyAs lusr) (invUsers invite)) (invRoleName invite))) + <@> mkNamedAPI @"add-members-to-conversation-unqualified2" addQualifiedMembersUnqualified <@> mkNamedAPI @"add-members-to-conversation" addMembers <@> mkNamedAPI @"replace-members-in-conversation" replaceMembers <@> mkNamedAPI @"join-conversation-by-id-unqualified" joinConversationById <@> mkNamedAPI @"join-conversation-by-code-unqualified" joinConversationByReusableCode <@> mkNamedAPI @"code-check" checkReusableCode <@> mkNamedAPI @"create-conversation-code-unqualified@v3" (addCodeUnqualified Nothing) - <@> mkNamedAPI @"create-conversation-code-unqualified" addCodeUnqualifiedWithReqBody + <@> mkNamedAPI @"create-conversation-code-unqualified" (\uid zhost conn conv req -> addCodeUnqualified (Just req) uid zhost conn conv) <@> mkNamedAPI @"get-conversation-guest-links-status" getConversationGuestLinksStatus <@> mkNamedAPI @"remove-code-unqualified" rmCodeUnqualified <@> mkNamedAPI @"get-code" getCode - <@> mkNamedAPI @"member-typing-unqualified" memberTypingUnqualified + <@> mkNamedAPI @"member-typing-unqualified" (\lusr con cnv status -> memberTyping lusr con (tUntagged (qualifyAs lusr cnv)) status) <@> mkNamedAPI @"member-typing-qualified" memberTyping - <@> mkNamedAPI @"remove-member-unqualified" removeMemberUnqualified + <@> mkNamedAPI @"remove-member-unqualified" (\lusr con cnv victim -> removeMemberQualified lusr con (tUntagged (qualifyAs lusr cnv)) (tUntagged (qualifyAs lusr victim))) <@> mkNamedAPI @"remove-member" removeMemberQualified - <@> mkNamedAPI @"update-other-member-unqualified" updateOtherMemberUnqualified + <@> mkNamedAPI @"update-other-member-unqualified" (\lusr con cnv victim update -> updateOtherMember lusr con (tUntagged (qualifyAs lusr cnv)) (tUntagged (qualifyAs lusr victim)) update) <@> mkNamedAPI @"update-other-member" updateOtherMember - <@> mkNamedAPI @"update-conversation-name-deprecated" updateUnqualifiedConversationName - <@> mkNamedAPI @"update-conversation-name-unqualified" updateUnqualifiedConversationName + <@> mkNamedAPI @"update-conversation-name-deprecated" (\lusr con cnv rename -> updateConversationName lusr con (tUntagged (qualifyAs lusr cnv)) rename) + <@> mkNamedAPI @"update-conversation-name-unqualified" (\lusr con cnv rename -> updateConversationName lusr con (tUntagged (qualifyAs lusr cnv)) rename) <@> mkNamedAPI @"update-conversation-name" updateConversationName - <@> mkNamedAPI @"update-conversation-message-timer-unqualified" updateConversationMessageTimerUnqualified + <@> mkNamedAPI @"update-conversation-message-timer-unqualified" (\lusr con cnv update -> updateConversationMessageTimer lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"update-conversation-message-timer" updateConversationMessageTimer - <@> mkNamedAPI @"update-conversation-receipt-mode-unqualified" updateConversationReceiptModeUnqualified + <@> mkNamedAPI @"update-conversation-receipt-mode-unqualified" (\lusr con cnv update -> updateConversationReceiptMode lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"update-conversation-receipt-mode" updateConversationReceiptMode - <@> mkNamedAPI @"update-conversation-access-unqualified" updateConversationAccessUnqualified + <@> mkNamedAPI @"update-conversation-access-unqualified" (\lusr con cnv update -> updateConversationAccess lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"update-conversation-access@v2" updateConversationAccess <@> mkNamedAPI @"update-conversation-access" updateConversationAccess <@> mkNamedAPI @"update-conversation-history" updateConversationHistory <@> mkNamedAPI @"get-conversation-self-unqualified" getLocalSelf - <@> mkNamedAPI @"update-conversation-self-unqualified" updateUnqualifiedSelfMember + <@> mkNamedAPI @"update-conversation-self-unqualified" (\lusr con cnv update -> updateSelfMember lusr con (tUntagged (qualifyAs lusr cnv)) update) <@> mkNamedAPI @"get-conversation-self" getSelfMember <@> mkNamedAPI @"update-conversation-self" updateSelfMember <@> mkNamedAPI @"update-conversation-protocol" updateConversationProtocolWithLocalUser diff --git a/services/galley/src/Galley/API/Public/Feature.hs b/services/galley/src/Galley/API/Public/Feature.hs index 0c55a19471b..6fea67c5905 100644 --- a/services/galley/src/Galley/API/Public/Feature.hs +++ b/services/galley/src/Galley/API/Public/Feature.hs @@ -20,16 +20,16 @@ module Galley.API.Public.Feature where +import Data.Proxy (Proxy (..)) import Galley.API.Teams import Galley.API.Teams.Features -import Galley.API.Teams.Features.Get import Galley.App import Imports import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Feature import Wire.API.Routes.Version import Wire.API.Team.Feature -import Wire.FeaturesConfigSubsystem (getAllTeamFeaturesForTeamMember) +import Wire.FeaturesConfigSubsystem featureAPIGetPut :: forall cfg r. (_) => API (FeatureAPIGetPut cfg) r featureAPIGetPut = @@ -42,7 +42,7 @@ featureAPI = <@> featureAPIGetPut <@> featureAPIGetPut <@> mkNamedAPI @"get-search-visibility" getSearchVisibility - <@> mkNamedAPI @"set-search-visibility" (setSearchVisibility (featureEnabledForTeam @SearchVisibilityAvailableConfig)) + <@> mkNamedAPI @"set-search-visibility" (setSearchVisibility (featureEnabledForTeam (Proxy @SearchVisibilityAvailableConfig))) <@> mkNamedAPI @'("get", RequireExternalEmailVerificationConfig) getFeature <@> mkNamedAPI @'("get", DigitalSignaturesConfig) getFeature <@> featureAPIGetPut diff --git a/services/galley/src/Galley/API/Public/LegalHold.hs b/services/galley/src/Galley/API/Public/LegalHold.hs index 04afca327fb..33a5eeb8bb1 100644 --- a/services/galley/src/Galley/API/Public/LegalHold.hs +++ b/services/galley/src/Galley/API/Public/LegalHold.hs @@ -21,6 +21,7 @@ import Galley.API.LegalHold import Galley.App import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.LegalHold +import Wire.TeamSubsystem (getUserStatus) legalHoldAPI :: API LegalHoldAPI GalleyEffects legalHoldAPI = diff --git a/services/galley/src/Galley/API/Public/MLS.hs b/services/galley/src/Galley/API/Public/MLS.hs index 687d9e48276..dafde053b89 100644 --- a/services/galley/src/Galley/API/Public/MLS.hs +++ b/services/galley/src/Galley/API/Public/MLS.hs @@ -17,12 +17,11 @@ module Galley.API.Public.MLS where -import Galley.API.MLS -import Galley.API.MLS.Reset import Galley.App import Imports import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.MLS +import Wire.ConversationSubsystem mlsAPI :: API MLSAPI GalleyEffects mlsAPI = diff --git a/services/galley/src/Galley/API/Public/Meetings.hs b/services/galley/src/Galley/API/Public/Meetings.hs index e494c5d1f65..825b7e96c79 100644 --- a/services/galley/src/Galley/API/Public/Meetings.hs +++ b/services/galley/src/Galley/API/Public/Meetings.hs @@ -26,6 +26,7 @@ meetingsAPI :: API MeetingsAPI GalleyEffects meetingsAPI = mkNamedAPI @"create-meeting" Meetings.createMeeting <@> mkNamedAPI @"update-meeting" Meetings.updateMeeting + <@> mkNamedAPI @"delete-meeting" Meetings.deleteMeeting <@> mkNamedAPI @"get-meeting" Meetings.getMeeting <@> mkNamedAPI @"list-meetings" Meetings.listMeetings <@> mkNamedAPI @"add-meeting-invitation" Meetings.addMeetingInvitation diff --git a/services/galley/src/Galley/API/Public/Messaging.hs b/services/galley/src/Galley/API/Public/Messaging.hs index 806484ae908..e96a78dd19c 100644 --- a/services/galley/src/Galley/API/Public/Messaging.hs +++ b/services/galley/src/Galley/API/Public/Messaging.hs @@ -17,10 +17,10 @@ module Galley.API.Public.Messaging where -import Galley.API.Update import Galley.App import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Messaging +import Wire.ConversationSubsystem messagingAPI :: API MessagingAPI GalleyEffects messagingAPI = diff --git a/services/galley/src/Galley/API/Public/Team.hs b/services/galley/src/Galley/API/Public/Team.hs index 7b8575c0e13..db27f6a176a 100644 --- a/services/galley/src/Galley/API/Public/Team.hs +++ b/services/galley/src/Galley/API/Public/Team.hs @@ -17,11 +17,11 @@ module Galley.API.Public.Team where -import Galley.API.Query import Galley.API.Teams import Galley.App import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Team +import Wire.ConversationSubsystem teamAPI :: API TeamAPI GalleyEffects teamAPI = diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index fbf7ed1b748..ee41c15cdaa 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -73,13 +73,9 @@ import Data.Proxy import Data.Qualified import Data.Range as Range import Data.Set qualified as Set -import Data.Singletons import Data.Time.Clock (UTCTime) -import Galley.API.Action import Galley.API.LegalHold.Team -import Galley.API.Teams.Features.Get import Galley.API.Teams.Notifications qualified as APITeamQueue -import Galley.API.Update qualified as API import Galley.App import Galley.Effects.Queue qualified as E import Galley.Types.Error as Galley @@ -91,13 +87,13 @@ import Polysemy.TinyLog qualified as P import System.Logger qualified as Log import Wire.API.Conversation (ConvType (..), ConversationRemoveMembers (..)) import Wire.API.Conversation qualified +import Wire.API.Conversation.Action (SConversationActionTag (SConversationRemoveMembersTag)) import Wire.API.Conversation.Role (wireConvRoles) import Wire.API.Conversation.Role qualified as Public import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Event.LeaveReason import Wire.API.Event.Team -import Wire.API.Federation.Error import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll)) import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Routes.MultiTablePaging (MultiTablePage (..), MultiTablePagingState (..)) @@ -119,21 +115,19 @@ import Wire.API.Team.SearchVisibility import Wire.API.Team.SearchVisibility qualified as Public import Wire.API.Team.Size import Wire.API.User qualified as U +import Wire.API.User.Search import Wire.BrigAPIAccess import Wire.BrigAPIAccess qualified as Brig import Wire.BrigAPIAccess qualified as E -import Wire.CodeStore import Wire.ConversationStore (ConversationStore) import Wire.ConversationStore qualified as E import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Util import Wire.FeaturesConfigSubsystem import Wire.LegalHoldStore (LegalHoldStore) import Wire.ListItems import Wire.ListItems qualified as E import Wire.NotificationSubsystem -import Wire.Options.Galley -import Wire.ProposalStore (ProposalStore) +import Wire.Options.Galley (Opts, maxTeamSize, settings) import Wire.Sem.Now import Wire.Sem.Now qualified as Now import Wire.Sem.Paging.Cassandra @@ -152,7 +146,11 @@ import Wire.Util getTeamH :: forall r. - (Member (ErrorS 'TeamNotFound) r, Member (E.Queue DeleteItem) r, Member TeamStore r, Member TeamSubsystem r) => + ( Member (ErrorS 'TeamNotFound) r, + Member (E.Queue DeleteItem) r, + Member TeamStore r, + Member TeamSubsystem r + ) => UserId -> TeamId -> Sem r Public.Team @@ -262,11 +260,11 @@ createBindingTeam tid zusr body = do updateTeamStatus :: ( Member E.BrigAPIAccess r, - Member (ErrorS 'InvalidTeamStatusUpdate) r, Member (ErrorS 'TeamNotFound) r, Member Now r, Member TeamStore r, - Member TeamJournal r + Member TeamJournal r, + Member (ErrorS InvalidTeamStatusUpdate) r ) => TeamId -> TeamStatusUpdate -> @@ -284,12 +282,12 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do -- When teams are created, they are activated immediately. In this situation, Brig will -- most likely report team size as 0 due to ES taking some time to index the team creator. -- This is also very difficult to test, so is not tested. - (TeamSize possiblyStaleSize) <- E.getSize tid - let size = - if possiblyStaleSize == 0 - then 1 - else possiblyStaleSize - Journal.teamActivate tid size c teamCreationTime + -- We could also write `updateTeamSize 1 size 0` here, but it seems clearer to do it + -- inline. + teamSize <- do + (TeamSize numRegulars numApps) <- E.getSize tid + pure $ TeamSize (max 1 numRegulars) numApps + Journal.teamActivate tid teamSize c teamCreationTime runJournal _ _ = throwS @'InvalidTeamStatusUpdate validateTransition :: (Member (ErrorS 'InvalidTeamStatusUpdate) r) => (TeamStatus, TeamStatus) -> Sem r Bool validateTransition = \case @@ -301,12 +299,12 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do (_, _) -> throwS @'InvalidTeamStatusUpdate updateTeamH :: - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS ('MissingPermission ('Just 'SetTeamData))) r, - Member NotificationSubsystem r, + ( Member NotificationSubsystem r, Member Now r, Member TeamStore r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member (ErrorS (MissingPermission (Just SetTeamData))) r, + Member (ErrorS NotATeamMember) r ) => UserId -> ConnId -> @@ -315,7 +313,7 @@ updateTeamH :: Sem r () updateTeamH zusr zcon tid updateData = do zusrMembership <- TeamSubsystem.internalGetTeamMember zusr tid - void $ permissionCheckS SSetTeamData zusrMembership + void $ TeamSubsystem.permissionCheckS SSetTeamData zusrMembership E.setTeamData tid updateData now <- Now.get admins <- E.getTeamAdmins tid @@ -333,15 +331,15 @@ updateTeamH zusr zcon tid updateData = do deleteTeam :: forall r. - ( Member E.BrigAPIAccess r, - Member (Error AuthenticationError) r, - Member (ErrorS 'DeleteQueueFull) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, + ( Member (ErrorS 'DeleteQueueFull) r, Member (ErrorS 'TeamNotFound) r, + Member (ErrorS OperationDenied) r, + Member (Error AuthenticationError) r, Member (E.Queue DeleteItem) r, + Member (ErrorS NotATeamMember) r, Member TeamStore r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member E.BrigAPIAccess r ) => UserId -> ConnId -> @@ -359,7 +357,7 @@ deleteTeam zusr zcon tid body = do queueTeamDeletion tid zusr (Just zcon) where checkPermissions team = do - void $ permissionCheck DeleteTeam =<< TeamSubsystem.internalGetTeamMember zusr tid + void $ TeamSubsystem.permissionCheck DeleteTeam =<< TeamSubsystem.internalGetTeamMember zusr tid when (tdTeam team ^. teamBinding == Binding) $ do ensureReAuthorised zusr (body ^. tdAuthPassword) (body ^. tdVerificationCode) (Just U.DeleteTeam) @@ -518,14 +516,14 @@ addTeamMember :: Member NotificationSubsystem r, Member (ErrorS 'InvalidPermissions) r, Member (ErrorS 'NoAddToBinding) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'NotConnected) r, - Member (ErrorS OperationDenied) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'TooManyTeamMembers) r, Member (ErrorS 'TooManyTeamAdmins) r, Member (ErrorS 'UserBindingExists) r, Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'NotConnected) r, Member (Input Opts) r, Member Now r, Member LegalHoldStore r, @@ -551,14 +549,12 @@ addTeamMember lzusr zcon tid nmem = do -- verify permissions zusrMembership <- TeamSubsystem.internalGetTeamMember zusr tid - >>= permissionCheck AddTeamMember + >>= TeamSubsystem.permissionCheck AddTeamMember let targetPermissions = nmem ^. nPermissions targetPermissions `ensureNotElevated` zusrMembership ensureNonBindingTeam tid ensureUnboundUsers [uid] - ensureConnectedToLocals zusr [uid] - (TeamSize sizeBeforeJoin) <- E.getSize tid - ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) + E.ensureConnectedToLocals zusr [uid] void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem -- This function is "unchecked" because there is no need to check for user binding (invite only). @@ -584,11 +580,9 @@ uncheckedAddTeamMember :: NewTeamMember -> Sem r () uncheckedAddTeamMember tid nmem = do - (TeamSize sizeBeforeJoin) <- E.getSize tid - ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) - (TeamSize sizeBeforeAdd) <- addTeamMemberInternal tid Nothing Nothing nmem + newTeamSize <- addTeamMemberInternal tid Nothing Nothing nmem owners <- E.getBillingTeamMembers tid - Journal.teamUpdate tid (sizeBeforeAdd + 1) owners + Journal.teamUpdate tid newTeamSize owners uncheckedUpdateTeamMember :: forall r. @@ -630,9 +624,9 @@ uncheckedUpdateTeamMember mlzusr mZcon tid newMem = do E.setTeamMemberPermissions (previousMember ^. permissions) tid targetId targetPermissions when (team ^. teamBinding == Binding) $ do - (TeamSize size) <- E.getSize tid + teamSize <- E.getSize tid owners <- E.getBillingTeamMembers tid - Journal.teamUpdate tid size owners + Journal.teamUpdate tid teamSize owners now <- Now.get let event = newEvent tid now (EdMemberUpdate targetId (Just targetPermissions)) @@ -655,8 +649,8 @@ updateTeamMember :: Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TooManyTeamAdmins) r, - Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member NotificationSubsystem r, Member Now r, Member P.TinyLog r, @@ -681,7 +675,7 @@ updateTeamMember lzusr zcon tid newMem = do -- get the team and verify permissions user <- TeamSubsystem.internalGetTeamMember zusr tid - >>= permissionCheck SetMemberPermissions + >>= TeamSubsystem.permissionCheck SetMemberPermissions -- user may not elevate permissions targetPermissions `ensureNotElevated` user @@ -705,22 +699,21 @@ updateTeamMember lzusr zcon tid newMem = do deleteTeamMember :: ( Member E.BrigAPIAccess r, Member ConversationStore r, - Member (Error AuthenticationError) r, Member (Error InvalidInput) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, - Member Now r, - Member NotificationSubsystem r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, + Member TeamSubsystem r, + Member NotificationSubsystem r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member P.TinyLog r, - Member (Input FanoutLimit) r, Member TeamJournal r, - Member TeamSubsystem r + Member Now r ) => Local UserId -> ConnId -> @@ -733,22 +726,21 @@ deleteTeamMember lusr zcon tid remove body = deleteTeamMember' lusr zcon tid rem deleteNonBindingTeamMember :: ( Member E.BrigAPIAccess r, Member ConversationStore r, - Member (Error AuthenticationError) r, Member (Error InvalidInput) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, - Member Now r, - Member NotificationSubsystem r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, + Member TeamSubsystem r, + Member NotificationSubsystem r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member P.TinyLog r, - Member (Input FanoutLimit) r, Member TeamJournal r, - Member TeamSubsystem r + Member Now r ) => Local UserId -> ConnId -> @@ -761,22 +753,21 @@ deleteNonBindingTeamMember lusr zcon tid remove = deleteTeamMember' lusr zcon ti deleteTeamMember' :: ( Member E.BrigAPIAccess r, Member ConversationStore r, - Member (Error AuthenticationError) r, Member (Error InvalidInput) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, - Member Now r, - Member NotificationSubsystem r, + Member (Error AuthenticationError) r, Member ConversationSubsystem r, + Member NotificationSubsystem r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member P.TinyLog r, - Member (Input FanoutLimit) r, Member TeamJournal r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member Now r ) => Local UserId -> ConnId -> @@ -790,7 +781,7 @@ deleteTeamMember' lusr zcon tid remove mBody = do . Log.field "action" (Log.val "Teams.deleteTeamMember") zusrMember <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid targetMember <- TeamSubsystem.internalGetTeamMember remove tid - void $ permissionCheck RemoveTeamMember zusrMember + void $ TeamSubsystem.permissionCheck RemoveTeamMember zusrMember do dm <- noteS @'NotATeamMember zusrMember tm <- noteS @'TeamMemberNotFound targetMember @@ -800,18 +791,19 @@ deleteTeamMember' lusr zcon tid remove mBody = do then do body <- mBody & note (InvalidPayload "missing request body") ensureReAuthorised (tUnqualified lusr) (body ^. tmdAuthPassword) Nothing Nothing - (TeamSize sizeBeforeDelete) <- E.getSize tid - -- TeamSize is 'Natural' and subtracting from 0 is an error - -- TeamSize could be reported as 0 if team members are added and removed very quickly, - -- which happens in tests - let sizeAfterDelete = - if sizeBeforeDelete == 0 - then 0 - else sizeBeforeDelete - 1 + uType <- + E.getUser remove <&> \case + Just u | u.userType == U.UserTypeApp -> UserTypeFilterApp + _ -> UserTypeFilterRegular + teamSizeAfterDelete <- do + before <- E.getSize tid + pure $ updateTeamSize uType before (-1) E.deleteUser remove - E.deleteApp tid remove + case uType of + UserTypeFilterRegular -> pure () + UserTypeFilterApp -> E.deleteApp tid remove owners <- E.getBillingTeamMembers tid - Journal.teamUpdate tid sizeAfterDelete $ filter (/= remove) owners + Journal.teamUpdate tid teamSizeAfterDelete $ filter (/= remove) owners pure TeamMemberDeleteAccepted else do (feat :: LockableFeature LimitedEventFanoutConfig) <- getFeatureForTeam tid @@ -820,7 +812,7 @@ deleteTeamMember' lusr zcon tid remove mBody = do admins <- E.getTeamAdmins tid uncheckedDeleteTeamMember lusr (Just zcon) tid remove (Left admins) FeatureStatusDisabled -> do - mems <- getTeamMembersForFanout tid + mems <- TeamSubsystem.getTeamMembersForFanout tid uncheckedDeleteTeamMember lusr (Just zcon) tid remove (Right mems) pure TeamMemberDeleteCompleted @@ -915,7 +907,7 @@ removeFromConvsAndPushConvLeaveEvent lusr zcon tid remove = do (Set.fromList bots) void $ sendConversationActionNotifications - (sing @'ConversationRemoveMembersTag) + SConversationRemoveMembersTag (tUntagged lusr) True zcon @@ -965,17 +957,7 @@ getTeamConversation zusr tid cid = do pure $ newTeamConversation teamConv deleteTeamConversation :: - ( Member CodeStore r, - Member ConversationStore r, - Member (Error FederationError) r, - Member (ErrorS 'ConvNotFound) r, - Member (ErrorS 'InvalidOperation) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS ('ActionDenied 'Public.DeleteConversation)) r, - Member ProposalStore r, - Member ConversationSubsystem r, - Member TeamSubsystem r - ) => + (Member ConversationSubsystem r) => Local UserId -> ConnId -> TeamId -> @@ -983,12 +965,12 @@ deleteTeamConversation :: Sem r () deleteTeamConversation lusr zcon _tid cid = do let lconv = qualifyAs lusr cid - void $ API.deleteLocalConversation lusr zcon lconv + void $ deleteLocalConversation lusr zcon lconv getSearchVisibility :: - ( Member (ErrorS 'NotATeamMember) r, + ( Member TeamStore r, Member (ErrorS OperationDenied) r, - Member TeamStore r, + Member (ErrorS 'NotATeamMember) r, Member TeamSubsystem r ) => Local UserId -> @@ -996,15 +978,15 @@ getSearchVisibility :: Sem r TeamSearchVisibilityView getSearchVisibility luid tid = do zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid - void $ permissionCheck ViewTeamSearchVisibility zusrMembership + void $ TeamSubsystem.permissionCheck ViewTeamSearchVisibility zusrMembership getSearchVisibilityInternal tid setSearchVisibility :: forall r. - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, + ( Member TeamStore r, Member (ErrorS 'TeamSearchVisibilityNotEnabled) r, - Member TeamStore r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member TeamSubsystem r ) => (TeamId -> Sem r Bool) -> @@ -1014,7 +996,7 @@ setSearchVisibility :: Sem r () setSearchVisibility availableForTeam luid tid req = do zusrMembership <- TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid - void $ permissionCheck ChangeTeamSearchVisibility zusrMembership + void $ TeamSubsystem.permissionCheck ChangeTeamSearchVisibility zusrMembership setSearchVisibilityInternal availableForTeam tid req -- Internal ----------------------------------------------------------------- @@ -1086,20 +1068,6 @@ ensureNotElevated targetPermissions member = ) $ throwS @'InvalidPermissions -ensureNotTooLarge :: - ( Member E.BrigAPIAccess r, - Member (ErrorS 'TooManyTeamMembers) r, - Member (Input Opts) r - ) => - TeamId -> - Sem r TeamSize -ensureNotTooLarge tid = do - o <- input - (TeamSize size) <- E.getSize tid - unless (size < fromIntegral (o ^. settings . maxTeamSize)) $ - throwS @'TooManyTeamMembers - pure $ TeamSize size - -- | Ensure that a team doesn't exceed the member count limit for the LegalHold -- feature. A team with more members than the fanout limit is too large, because -- the fanout limit would prevent turning LegalHold feature _off_ again (for @@ -1118,7 +1086,7 @@ ensureNotTooLargeForLegalHold :: Member FeaturesConfigSubsystem r ) => TeamId -> - Int -> + TeamSize -> Sem r () ensureNotTooLargeForLegalHold tid teamSize = whenM (isLegalHoldEnabledForTeam tid) $ @@ -1129,12 +1097,17 @@ addTeamMemberInternal :: ( Member E.BrigAPIAccess r, Member (ErrorS 'TooManyTeamMembers) r, Member (ErrorS 'TooManyTeamAdmins) r, + Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r, Member NotificationSubsystem r, Member (Input Opts) r, Member Now r, + Member LegalHoldStore r, Member TeamNotificationStore r, Member TeamStore r, - Member P.TinyLog r + Member P.TinyLog r, + Member (Input FanoutLimit) r, + Member (Input (FeatureDefaults LegalholdConfig)) r, + Member FeaturesConfigSubsystem r ) => TeamId -> Maybe UserId -> @@ -1145,7 +1118,14 @@ addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) = do P.debug $ Log.field "targets" (toByteString (new ^. userId)) . Log.field "action" (Log.val "Teams.addTeamMemberInternal") - sizeBeforeAdd <- ensureNotTooLarge tid + sizeAfterAdd <- do + n <- ensureNotTooLarge tid + uType <- + E.getUser (new ^. userId) <&> \case + Just u | u.userType == U.UserTypeApp -> UserTypeFilterApp + _ -> UserTypeFilterRegular + pure $ updateTeamSize uType n 1 + ensureNotTooLargeForLegalHold tid sizeAfterAdd admins <- E.getTeamAdmins tid let admins' = [new ^. userId | isAdminOrOwner (new ^. M.permissions)] <> admins @@ -1170,20 +1150,33 @@ addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) = do ] APITeamQueue.pushTeamEvent tid e - pure sizeBeforeAdd + pure sizeAfterAdd + where + ensureNotTooLarge :: + ( Member E.BrigAPIAccess r, + Member (ErrorS 'TooManyTeamMembers) r, + Member (Input Opts) r + ) => + TeamId -> + Sem r TeamSize + ensureNotTooLarge teamid = do + o <- input + teamSize <- E.getSize teamid + unless (teamSizeTotal teamSize < fromIntegral (o ^. settings . maxTeamSize)) $ + throwS @'TooManyTeamMembers + pure teamSize getBindingTeamMembers :: ( Member (ErrorS 'TeamNotFound) r, Member (ErrorS 'NonBindingTeam) r, Member TeamStore r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => UserId -> Sem r TeamMemberList getBindingTeamMembers zusr = do tid <- E.lookupBindingTeam zusr - getTeamMembersForFanout tid + TeamSubsystem.getTeamMembersForFanout tid -- This could be extended for more checks, for now we test only legalhold -- @@ -1212,8 +1205,15 @@ canUserJoinTeam :: canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do - (TeamSize sizeBeforeJoin) <- E.getSize tid - ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) + sizeBeforeJoin <- E.getSize tid + let uType = + -- We do not have a `UserId` to check here. Also, + -- `canUserJoinTeam` is called by Brig during user + -- registration via invitation (POST /register), where apps + -- never go. So it is safe to assume "regular" + UserTypeFilterRegular + let sizeAfterJoin = updateTeamSize uType sizeBeforeJoin 1 + ensureNotTooLargeForLegalHold tid sizeAfterJoin -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternal :: @@ -1242,8 +1242,8 @@ userIsTeamOwner :: ( Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'NotATeamMember) r, - Member (Input (Local ())) r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member (Input (Local ())) r ) => TeamId -> UserId -> @@ -1275,9 +1275,9 @@ checkAdminLimit adminCount = updateTeamCollaborator :: forall r. ( Member ConversationStore r, - Member (ErrorS OperationDenied) r, - Member (ErrorS NotATeamMember) r, Member P.TinyLog r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member TeamCollaboratorsSubsystem r, Member ConversationSubsystem r, Member TeamSubsystem r @@ -1292,7 +1292,7 @@ updateTeamCollaborator lusr tid rusr perms = do Log.field "targets" (toByteString rusr) . Log.field "action" (Log.val "Teams.updateTeamCollaborator") zusrMember <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid - void $ permissionCheck UpdateTeamCollaborator zusrMember + void $ TeamSubsystem.permissionCheck UpdateTeamCollaborator zusrMember when (Set.null $ Set.intersection (Set.fromList [Collaborator.CreateTeamConversation, Collaborator.ImplicitConnection]) perms) $ removeFromConvsAndPushConvLeaveEvent lusr Nothing tid rusr internalUpdateTeamCollaborator rusr tid perms @@ -1301,16 +1301,15 @@ updateTeamCollaborator lusr tid rusr perms = do removeTeamCollaborator :: forall r. ( Member ConversationStore r, - Member (ErrorS OperationDenied) r, - Member (ErrorS NotATeamMember) r, Member NotificationSubsystem r, Member ConversationSubsystem r, Member Now r, Member P.TinyLog r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member FeaturesConfigSubsystem r, Member TeamStore r, Member TeamCollaboratorsSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => Local UserId -> @@ -1322,12 +1321,12 @@ removeTeamCollaborator lusr tid rusr = do Log.field "targets" (toByteString rusr) . Log.field "action" (Log.val "Teams.removeTeamCollaborator") zusrMember <- TeamSubsystem.internalGetTeamMember (tUnqualified lusr) tid - void $ permissionCheck RemoveTeamCollaborator zusrMember + void $ TeamSubsystem.permissionCheck RemoveTeamCollaborator zusrMember toNotify <- (getFeatureForTeam @_ @LimitedEventFanoutConfig tid) >>= ( \case FeatureStatusEnabled -> Left <$> E.getTeamAdmins tid - FeatureStatusDisabled -> Right <$> getTeamMembersForFanout tid + FeatureStatusDisabled -> Right <$> TeamSubsystem.getTeamMembersForFanout tid ) . (.status) uncheckedDeleteTeamMember lusr Nothing tid rusr toNotify diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index c113e394fa6..46709503d44 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -22,13 +22,9 @@ module Galley.API.Teams.Features ( setFeature, setFeatureInternal, patchFeatureInternal, - getAllTeamFeaturesForTeam, - getAllTeamFeaturesForUser, updateLockStatus, GetFeatureConfig (..), SetFeatureConfig (..), - guardSecondFactorDisabled, - featureEnabledForTeam, guardMlsE2EIdConfig, ) where @@ -43,7 +39,6 @@ import Data.Kind import Data.Qualified (Local) import Galley.API.LegalHold qualified as LegalHold import Galley.API.LegalHold.Team qualified as LegalHold -import Galley.API.Teams.Features.Get import Galley.App import Galley.Types.Error (InternalError) import Imports @@ -59,6 +54,7 @@ import Wire.API.Error.Galley import Wire.API.Event.FeatureConfig import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error +import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Team.Feature import Wire.API.Team.FeatureFlags import Wire.API.Team.Member @@ -68,10 +64,9 @@ import Wire.BrigAPIAccess (BrigAPIAccess, getAppIdsForTeam, setAccountStatus, up import Wire.CodeStore import Wire.ConversationStore (ConversationStore, MLSCommitLockStore) import Wire.ConversationSubsystem -import Wire.ConversationSubsystem.Util (assertTeamExists, getTeamMembersForFanout, permissionCheck) import Wire.ExternalAccess (ExternalAccess) -import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getDbFeatureRawInternal) -import Wire.FeaturesConfigSubsystem.Types (GetFeatureConfigEffects) +import Wire.FeaturesConfigSubsystem (FeaturesConfigSubsystem, getDbFeatureRawInternal, getFeatureForTeam) +import Wire.FeaturesConfigSubsystem.Types import Wire.FeaturesConfigSubsystem.Utils (resolveServerFeature) import Wire.FederationAPIAccess (FederationAPIAccess) import Wire.FederationSubsystem (FederationSubsystem) @@ -100,12 +95,9 @@ patchFeatureInternal :: SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r, Member TeamFeatureStore r, Member P.TinyLog r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r, GetFeatureConfigEffects r ) => @@ -113,7 +105,7 @@ patchFeatureInternal :: LockableFeaturePatch cfg -> Sem r (LockableFeature cfg) patchFeatureInternal tid patch = do - assertTeamExists tid + TeamSubsystem.assertTeamExists tid dbFeature <- getDbFeatureRawInternal tid defFeature :: LockableFeature cfg <- resolveServerFeature let dbFeatureWithDefaults = dbFeature.applyDbFeature defFeature @@ -138,13 +130,12 @@ setFeature :: SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, Member (Error TeamFeatureError) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, Member TeamFeatureStore r, Member P.TinyLog r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => UserId -> @@ -153,7 +144,7 @@ setFeature :: Sem r (LockableFeature cfg) setFeature uid tid feat = do zusrMembership <- TeamSubsystem.internalGetTeamMember uid tid - void $ permissionCheck ChangeTeamFeature zusrMembership + void $ TeamSubsystem.permissionCheck ChangeTeamFeature zusrMembership setFeatureUnchecked tid feat setFeatureInternal :: @@ -162,20 +153,17 @@ setFeatureInternal :: SetFeatureConfig cfg, ComputeFeatureConstraints cfg r, SetFeatureForTeamConstraints cfg r, - Member (ErrorS 'TeamNotFound) r, Member (Error TeamFeatureError) r, - Member TeamStore r, Member TeamFeatureStore r, Member P.TinyLog r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> Feature cfg -> Sem r (LockableFeature cfg) setFeatureInternal tid feat = do - assertTeamExists tid + TeamSubsystem.assertTeamExists tid setFeatureUnchecked tid feat setFeatureUnchecked :: @@ -188,7 +176,6 @@ setFeatureUnchecked :: Member TeamFeatureStore r, Member (P.Logger (Log.Msg -> Log.Msg)) r, Member NotificationSubsystem r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> @@ -203,14 +190,13 @@ updateLockStatus :: forall cfg r. ( IsFeatureConfig cfg, Member TeamFeatureStore r, - Member TeamStore r, - Member (ErrorS 'TeamNotFound) r + Member TeamSubsystem r ) => TeamId -> LockStatus -> Sem r LockStatusResponse updateLockStatus tid lockStatus = do - assertTeamExists tid + TeamSubsystem.assertTeamExists tid setFeatureLockStatus @cfg tid lockStatus pure $ LockStatusResponse lockStatus @@ -231,15 +217,14 @@ pushFeatureEvent :: forall cfg r. ( IsFeatureConfig cfg, Member NotificationSubsystem r, - Member P.TinyLog r, - Member (Input FanoutLimit) r, - Member TeamSubsystem r + Member TeamSubsystem r, + Member P.TinyLog r ) => TeamId -> Event -> Sem r () pushFeatureEvent tid event = do - memList <- getTeamMembersForFanout tid + memList <- TeamSubsystem.getTeamMembersForFanout tid if ((memList ^. teamMemberListType) == ListTruncated) then do P.warn $ @@ -270,7 +255,6 @@ setFeatureForTeam :: Member P.TinyLog r, Member NotificationSubsystem r, Member TeamFeatureStore r, - Member (Input FanoutLimit) r, Member TeamSubsystem r ) => TeamId -> @@ -413,7 +397,7 @@ instance SetFeatureConfig SndFactorPasswordChallengeConfig instance SetFeatureConfig SearchVisibilityInboundConfig where type SetFeatureForTeamConstraints SearchVisibilityInboundConfig (r :: EffectRow) = (Member BrigAPIAccess r) prepareFeature tid feat = do - updateSearchVisibilityInbound $ toTeamStatus tid feat + updateSearchVisibilityInbound $ Multi.TeamStatus tid feat.status instance SetFeatureConfig MLSConfig where type diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs deleted file mode 100644 index 231aa5d3c85..00000000000 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# OPTIONS_GHC -Wno-ambiguous-fields #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.API.Teams.Features.Get - ( getFeature, - getFeatureInternal, - getAllTeamFeaturesForServer, - getAllTeamFeaturesForTeam, - getAllTeamFeaturesForUser, - getSingleFeatureForUser, - GetFeatureConfig (..), - getFeatureForTeam, - guardSecondFactorDisabled, - DoAuth (..), - featureEnabledForTeam, - toTeamStatus, - ) -where - -import Control.Error (hush) -import Data.Id -import Data.SOP -import Data.Tagged -import Imports -import Polysemy -import Polysemy.Error -import Wire.API.Conversation (cnvmTeam) -import Wire.API.Error -import Wire.API.Error.Galley -import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi -import Wire.API.Team.Feature -import Wire.ConversationStore as ConversationStore -import Wire.ConversationSubsystem.Util -import Wire.FeaturesConfigSubsystem -import Wire.FeaturesConfigSubsystem.Types -import Wire.TeamStore qualified as TeamStore -import Wire.TeamSubsystem (TeamSubsystem) -import Wire.TeamSubsystem qualified as TeamSubsystem - --- FUTUREWORK: everything in this module should be moved to the FeatureConfigSubsystem -data DoAuth = DoAuth UserId | DontDoAuth - -getFeatureInternal :: - ( GetFeatureConfig cfg, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r - ) => - TeamId -> - Sem r (LockableFeature cfg) -getFeatureInternal tid = do - assertTeamExists tid - getFeatureForTeam tid - -toTeamStatus :: TeamId -> LockableFeature cfg -> Multi.TeamStatus cfg -toTeamStatus tid feat = Multi.TeamStatus tid feat.status - -getTeamAndCheckMembership :: - ( Member TeamStore.TeamStore r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamSubsystem r - ) => - UserId -> - Sem r (Maybe TeamId) -getTeamAndCheckMembership uid = do - mTid <- TeamStore.getOneUserTeam uid - for_ mTid $ \tid -> do - zusrMembership <- TeamSubsystem.internalGetTeamMember uid tid - void $ maybe (throwS @'NotATeamMember) pure zusrMembership - assertTeamExists tid - pure mTid - -getAllTeamFeatures :: - forall r. - (Member FeaturesConfigSubsystem r) => - TeamId -> - Sem r AllTeamFeatures -getAllTeamFeatures tid = getAllTeamFeaturesForTeam tid - -getAllTeamFeaturesForUser :: - forall r. - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member TeamSubsystem r, - Member FeaturesConfigSubsystem r, - GetFeatureConfigEffects r - ) => - UserId -> - Sem r AllTeamFeatures -getAllTeamFeaturesForUser uid = do - mTid <- getTeamAndCheckMembership uid - case mTid of - Nothing -> hsequence' $ hcpure (Proxy @(GetAllTeamFeaturesForUserConstraints r)) $ Comp $ getFeatureForUser uid - Just tid -> getAllTeamFeatures tid - -getSingleFeatureForUser :: - forall cfg r. - ( GetFeatureConfig cfg, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member TeamSubsystem r, - Member FeaturesConfigSubsystem r - ) => - UserId -> - Sem r (LockableFeature cfg) -getSingleFeatureForUser uid = do - mTid <- getTeamAndCheckMembership uid - getFeatureForTeamUser @_ @cfg uid mTid - --- | If second factor auth is enabled, make sure that end-points that don't support it, but --- should, are blocked completely. (This is a workaround until we have 2FA for those --- end-points as well.) --- --- This function exists to resolve a cyclic dependency. -guardSecondFactorDisabled :: - forall r. - ( Member (ErrorS 'AccessDenied) r, - Member TeamStore.TeamStore r, - Member ConversationStore r, - Member FeaturesConfigSubsystem r - ) => - UserId -> - ConvId -> - Sem r () -guardSecondFactorDisabled uid cid = do - mTid <- fmap hush . runError @() $ do - convData <- ConversationStore.getConversationMetadata cid >>= note () - tid <- note () convData.cnvmTeam - mapError (unTagged @'TeamNotFound @()) $ assertTeamExists tid - pure tid - - tf <- getFeatureForTeamUser @_ @SndFactorPasswordChallengeConfig uid mTid - case tf.status of - FeatureStatusDisabled -> pure () - FeatureStatusEnabled -> throwS @'AccessDenied - -featureEnabledForTeam :: - forall cfg r. - ( GetFeatureConfig cfg, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore.TeamStore r, - Member FeaturesConfigSubsystem r - ) => - TeamId -> - Sem r Bool -featureEnabledForTeam tid = - (==) FeatureStatusEnabled - . (.status) - <$> getFeatureInternal @cfg tid diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 8ee5e1e092b..cc38ae92501 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -52,7 +52,6 @@ import Data.Misc import Data.Qualified import Data.Range import Data.Text qualified as Text -import Galley.API.MLS.GroupInfoCheck (GroupInfoCheckEnabled (GroupInfoCheckEnabled)) import Galley.Effects.Queue qualified as GE import Galley.Env import Galley.External.LegalHoldService.Internal qualified as LHInternal @@ -106,8 +105,8 @@ import Wire.CodeStore.Postgres import Wire.ConversationStore (ConversationStore, MLSCommitLockStore) import Wire.ConversationStore.Cassandra import Wire.ConversationStore.Postgres -import Wire.ConversationSubsystem (ConversationSubsystem) -import Wire.ConversationSubsystem.Interpreter (interpretConversationSubsystem) +import Wire.ConversationSubsystem +import Wire.ConversationSubsystem.Interpreter (ConversationSubsystemError, GroupInfoCheckEnabled (..), IntraListing (IntraListing), interpretConversationSubsystem) import Wire.CustomBackendStore import Wire.CustomBackendStore.Cassandra import Wire.Error @@ -149,6 +148,7 @@ import Wire.ProposalStore.Cassandra import Wire.RateLimit import Wire.RateLimit.Interpreter import Wire.Rpc +import Wire.RpcException import Wire.Sem.Concurrency import Wire.Sem.Concurrency.IO import Wire.Sem.Delay @@ -233,6 +233,8 @@ type GalleyEffects = Input FanoutLimit, Input (FeatureDefaults LegalholdConfig), Input (Local ()), + Input IntraListing, + Input (Maybe GuestLinkTTLSeconds), Input (Maybe (MLSKeysByPurpose MLSPrivateKeys)), Input (Maybe GroupInfoCheckEnabled), Input Opts, @@ -242,7 +244,10 @@ type GalleyEffects = Error Meeting.MeetingError, Error DynError, Error RateLimitExceeded, + Error ConversationSubsystemError, ErrorS OperationDenied, + ErrorS 'AccessDenied, + ErrorS 'TeamMemberNotFound, ErrorS 'HistoryNotSupported, ErrorS 'NotATeamMember, ErrorS 'ConvAccessDenied, @@ -260,6 +265,7 @@ type GalleyEffects = ErrorS 'NotATeamMember, ErrorS 'MeetingNotFound, ErrorS 'InvalidOperation, + Error RpcException, Input ClientState, Input Hasql.Pool, Input Env, @@ -292,7 +298,7 @@ type GalleyEffects = validateOptions :: Opts -> IO (Either HttpsUrl (Map Text HttpsUrl)) validateOptions o = do let settings' = view settings o - optFanoutLimit = fromIntegral . fromRange $ currentFanoutLimit o + optFanoutLimit = fromIntegral . fromRange $ currentFanoutLimit settings'._maxTeamSize settings'._maxFanoutSize when (settings'._maxConvSize > fromIntegral optFanoutLimit) $ error "setMaxConvSize cannot be > setTruncationLimit" when (settings' ^. maxTeamSize < optFanoutLimit) $ @@ -308,12 +314,7 @@ validateOptions o = do error "For starting MLS migration, MLS must be included in the supportedProtocol list" unless (mlsDefaultProtocol mlsConfig `elem` mlsSupportedProtocols mlsConfig) $ error "The list 'settings.featureFlags.mls.supportedProtocols' must include the value in the field 'settings.featureFlags.mls.defaultProtocol'" - let errMsg = "Either conversationCodeURI or multiIngress needs to be set." - case (settings' ^. conversationCodeURI, settings' ^. multiIngress) of - (Nothing, Nothing) -> error errMsg - (Nothing, Just mi) -> pure (Right mi) - (Just uri, Nothing) -> pure (Left uri) - (Just _, Just _) -> error errMsg + conversationCodeURISettings o createEnv :: Opts -> Logger -> IO Env createEnv o l = do @@ -484,6 +485,7 @@ evalGalley e = . runInputConst e . runInputConst (e ^. hasqlPool) . runInputConst (e ^. cstate) + . mapError (toResponse . rpcExcepctionToWaiError) -- Error RpcException . mapError toResponse -- ErrorS 'InvalidOperation . mapError toResponse -- ErrorS 'MeetingNotFound . mapError toResponse -- ErrorS 'NotATeamMember @@ -501,7 +503,10 @@ evalGalley e = . mapError toResponse -- ErrorS 'ConvAccessDenied . mapError toResponse -- ErrorS 'NotATeamMember . mapError toResponse -- ErrorS 'HistoryNotSupported + . mapError toResponse -- ErrorS 'TeamMemberNotFound + . mapError toResponse -- ErrorS 'AccessDenied . mapError toResponse -- ErrorS OperationDenied + . mapError toResponse -- Error ConversationSubsystemError, . mapError rateLimitExceededToHttpError . mapError toResponse -- DynError . mapError meetingError @@ -511,9 +516,11 @@ evalGalley e = . runInputConst (e ^. options) . runInputConst (GroupInfoCheckEnabled <$> e._options._settings._checkGroupInfo) . runInputConst e._mlsKeys + . runInputConst e._options._settings._guestLinkTTLSeconds + . runInputConst (IntraListing e._options._settings._intraListing) . runInputConst localUnit . interpretTeamFeatureSpecialContext e - . runInputConst (currentFanoutLimit (e ^. options)) + . runInputConst (currentFanoutLimitOpts (e ^. options)) . runInputSem (inputs @Opts $ view (O.settings . O.featureFlags)) . runInputSem (inputs @Opts $ ExposeInvitationURLsAllowlist . fromMaybe [] . view (O.settings . O.exposeInvitationURLsTeamAllowlist)) . interpretInternalTeamListToCassandra @@ -577,3 +584,4 @@ meetingError = \case Meeting.InvalidTimes -> Servant.Tagged @'InvalidOperation () Meeting.EmptyUpdate -> Servant.Tagged @'InvalidOperation () + Meeting.MeetingsFeatureDisabled -> Servant.Tagged @'InvalidOperation () diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 80de4fb949c..009ac952546 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -18,13 +18,35 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Env where +module Galley.Env + ( Env (..), + DeleteItem (..), + reqId, + options, + applog, + manager, + http2Manager, + Galley.Env.federator, + Galley.Env.brig, + cstate, + hasqlPool, + deleteQueue, + extEnv, + aEnv, + mlsKeys, + rabbitmqChannel, + convCodeURI, + passwordHashingRateLimitEnv, + reqIdMsg, + notificationSubsystemConfig, + currentFanoutLimitOpts, + ) +where import Cassandra import Control.Lens hiding ((.=)) import Data.Id import Data.Misc (HttpsUrl) -import Data.Range import Data.Time.Clock.DiffTime (millisecondsToDiffTime) import Galley.Queue qualified as Q import HTTP2.Client.Manager (Http2Manager) @@ -36,6 +58,7 @@ import System.Logger import Util.Options import Wire.API.MLS.Keys import Wire.API.Team.FeatureFlags (FanoutLimit) +import Wire.API.Team.FeatureFlags qualified as FeatureFlags import Wire.AWS qualified as Aws import Wire.ExternalAccess.External import Wire.NotificationSubsystem.Interpreter @@ -72,21 +95,19 @@ reqIdMsg :: RequestId -> Msg -> Msg reqIdMsg = ("request" .=) . unRequestId {-# INLINE reqIdMsg #-} -currentFanoutLimit :: Opts -> FanoutLimit -currentFanoutLimit o = do - let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defaultFanoutLimit (o ^. (O.settings . maxFanoutSize)) - let maxSize = fromIntegral (o ^. (O.settings . maxTeamSize)) - unsafeRange (min maxSize optFanoutLimit) - notificationSubsystemConfig :: Env -> NotificationSubsystemConfig notificationSubsystemConfig env = - NotificationSubsystemConfig - { chunkSize = defaultChunkSize, - fanoutLimit = currentFanoutLimit env._options, - slowPushDelay = - maybe - defaultSlowPushDelay - (millisecondsToDiffTime . toInteger) - (env ^. options . O.settings . deleteConvThrottleMillis), - requestId = env ^. reqId - } + let settings' = env._options._settings + in NotificationSubsystemConfig + { chunkSize = defaultChunkSize, + fanoutLimit = FeatureFlags.currentFanoutLimit settings'._maxTeamSize settings'._maxFanoutSize, + slowPushDelay = + maybe + defaultSlowPushDelay + (millisecondsToDiffTime . toInteger) + (env ^. options . O.settings . deleteConvThrottleMillis), + requestId = env ^. reqId + } + +currentFanoutLimitOpts :: Opts -> FanoutLimit +currentFanoutLimitOpts opts = FeatureFlags.currentFanoutLimit opts._settings._maxTeamSize opts._settings._maxFanoutSize diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 7ada3332644..5f9475e034b 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -66,7 +66,6 @@ import Data.Text.Ascii qualified as Ascii import Data.Time.Clock (getCurrentTime) import Federator.Discovery (DiscoveryFailure (..)) import Federator.MockServer hiding (status) -import Galley.API.Mapping import Imports hiding (id) import Imports qualified as I import Network.HTTP.Types.Status qualified as HTTP @@ -2375,8 +2374,8 @@ testBulkGetQualifiedConvs = do let mock = do d <- frTargetDomain <$> getRequest asum - [ guard (d == remoteDomainA) *> mockReply (GetConversationsResponseV2 [mockConversationA]), - guard (d == remoteDomainB) *> mockReply (GetConversationsResponseV2 [mockConversationB]), + [ guard (d == remoteDomainA) *> mockReply (GetRemoteConversationViewsResponse [mockConversationA]), + guard (d == remoteDomainB) *> mockReply (GetRemoteConversationViewsResponse [mockConversationB]), guard (d == remoteDomainC) *> liftIO (throw (DiscoveryFailureSrvNotAvailable "domainC")), do r <- getRequest @@ -3056,7 +3055,7 @@ putRemoteConvMemberOk update = do (qUnqualified qbob) roleNameWireMember [localMemberToOther remoteDomain bobAsLocal] - remoteConversationResponse = GetConversationsResponseV2 [mockConversation] + remoteConversationResponse = GetRemoteConversationViewsResponse [mockConversation] (rs, _) <- withTempMockFederator' (mockReply remoteConversationResponse) @@ -3381,7 +3380,7 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do pure . map omQualifiedId . cmOthers . cnvMembers $ conv RemoteActor -> do fedGalleyClient <- view tsFedGalleyClient - GetConversationsResponseV2 convs <- + GetRemoteConversationViewsResponse convs <- runFedClient @"get-conversations" fedGalleyClient (tDomain bob) $ GetConversationsRequest { userId = tUnqualified bob, @@ -3400,7 +3399,7 @@ testOne2OneConversationRequest shouldBeLocal actor desired = do found <- do let rconv = mkProteusConv (qUnqualified convId) (tUnqualified bob) roleNameWireAdmin [] (resp, _) <- - withTempMockFederator' (mockReply (GetConversationsResponseV2 [rconv])) $ + withTempMockFederator' (mockReply (GetRemoteConversationViewsResponse [rconv])) $ getConvQualified (tUnqualified alice) convId pure $ statusCode resp == 200 liftIO $ found @?= ((actor, desired) == (LocalActor, Included)) diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 01c5b35d9e0..3d4c74398a5 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -153,7 +153,7 @@ getConversationsAllFound = do fedGalleyClient <- view tsFedGalleyClient - GetConversationsResponseV2 convs <- + GetRemoteConversationViewsResponse convs <- runFedClient @"get-conversations" fedGalleyClient (qDomain aliceQ) $ GetConversationsRequest (qUnqualified aliceQ) @@ -198,7 +198,7 @@ getConversationsNotPartOf = do fedGalleyClient <- view tsFedGalleyClient rando <- Id <$> liftIO nextRandom - GetConversationsResponseV2 convs <- + GetRemoteConversationViewsResponse convs <- runFedClient @"get-conversations" fedGalleyClient localDomain $ GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1] liftIO $ assertEqual "conversation list not empty" [] convs diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 04263221b24..472092c6741 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -1280,7 +1280,7 @@ testBillingInLargeTeam = do refreshIndex opts <- view tsGConf galley <- viewGalley - let fanoutLimit = fromRange $ Galley.currentFanoutLimit opts + let fanoutLimit = fromRange $ Galley.currentFanoutLimitOpts opts allOwnersBeforeFanoutLimit <- foldM ( \billingMembers n -> do diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index f24abb8ada7..db9e3db7d0c 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -173,7 +173,7 @@ testRemoveLegalHoldFromTeam = do testAddTeamUserTooLargeWithLegalholdWhitelisted :: (HasCallStack) => TestM () testAddTeamUserTooLargeWithLegalholdWhitelisted = withTeam $ \owner tid -> do o <- view tsGConf - let fanoutLimit = fromIntegral @_ @Integer . fromRange $ Galley.currentFanoutLimit o + let fanoutLimit = fromIntegral @_ @Integer . fromRange $ Galley.currentFanoutLimitOpts o forM_ [2 .. (fanoutLimit + 5)] $ \_n -> do addUserToTeam' owner tid !!! do const 201 === statusCode diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index 222c2af34bf..734af584d74 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -200,7 +200,7 @@ testRemoveLegalHoldFromTeam = do testEnablePerTeamTooLarge :: TestM () testEnablePerTeamTooLarge = do o <- view tsGConf - let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimit o + let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimitOpts o -- TODO: it is impossible in this test to create teams bigger than the fanout limit. -- Change the +1 to anything else and look at the logs (tid, _owner, _others) <- createBindingTeamWithMembers (fanoutLimit + 5) @@ -215,7 +215,7 @@ testEnablePerTeamTooLarge = do testAddTeamUserTooLargeWithLegalhold :: TestM () testAddTeamUserTooLargeWithLegalhold = do o <- view tsGConf - let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimit o + let fanoutLimit = fromIntegral . fromRange $ Galley.currentFanoutLimitOpts o (tid, owner, _others) <- createBindingTeamWithMembers fanoutLimit feat :: Public.Feature Public.LegalholdConfig <- responseJsonUnsafe <$> (getEnabled tid RoleName -> [OtherMember] -> - RemoteConversationV2 + RemoteConversationView mkProteusConv cnvId creator selfRole otherMembers = - RemoteConversationV2 + RemoteConversationView cnvId ( ConversationMetadata RegularConv diff --git a/services/galley/test/unit/Run.hs b/services/galley/test/unit/Run.hs deleted file mode 100644 index 486fea4a91f..00000000000 --- a/services/galley/test/unit/Run.hs +++ /dev/null @@ -1,37 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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 Run - ( main, - ) -where - -import Imports -import Test.Galley.API.Message qualified -import Test.Galley.API.One2One qualified -import Test.Galley.Mapping qualified -import Test.Tasty - -main :: IO () -main = - defaultMain $ - testGroup - "Tests" - [ Test.Galley.API.Message.tests, - Test.Galley.API.One2One.tests, - Test.Galley.Mapping.tests - ] diff --git a/services/spar/default.nix b/services/spar/default.nix index 315c3c5d75a..5ad0fbf1fad 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -19,6 +19,7 @@ , cookie , crypton , crypton-x509 +, data-default , exceptions , extended , filepath @@ -208,6 +209,7 @@ mkDerivation { bytestring-conversion containers cookie + data-default filepath hscim hspec diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 42885b16c33..6512673b66b 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -30,9 +30,7 @@ library Spar.Data Spar.Data.Instances Spar.Error - Spar.Intra.Brig - Spar.Intra.BrigApp - Spar.Intra.Galley + Spar.Intra.RpcApp Spar.Options Spar.Orphans Spar.Run @@ -71,14 +69,10 @@ library Spar.Sem.AssIDStore Spar.Sem.AssIDStore.Cassandra Spar.Sem.AssIDStore.Mem - Spar.Sem.BrigAccess - Spar.Sem.BrigAccess.Http Spar.Sem.DefaultSsoCode Spar.Sem.DefaultSsoCode.Cassandra Spar.Sem.DefaultSsoCode.Mem Spar.Sem.DefaultSsoCode.Spec - Spar.Sem.GalleyAccess - Spar.Sem.GalleyAccess.Http Spar.Sem.IdPRawMetadataStore Spar.Sem.IdPRawMetadataStore.Cassandra Spar.Sem.IdPRawMetadataStore.Mem @@ -282,7 +276,6 @@ executable spar-integration Test.Spar.APISpec Test.Spar.AppSpec Test.Spar.DataSpec - Test.Spar.Intra.BrigSpec Test.Spar.Scim.AuthSpec Test.Spar.Scim.UserSpec Util @@ -630,6 +623,7 @@ test-suite spec , bytestring-conversion , containers , cookie + , data-default , filepath , hscim , hspec diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index bd8e285b66a..d1e255da57c 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -75,6 +75,7 @@ import qualified Data.X509 as X509 import Data.X509.Extended import Imports import Network.Wai (Request, requestHeaders) +import qualified Network.Wai.Utilities.Error as Wai import Network.Wai.Utilities.Request import Network.Wai.Utilities.Server (defaultRequestIdHeaderName) import Polysemy @@ -87,18 +88,14 @@ import Servant.Server.Experimental.Auth import Spar.App import Spar.CanonicalInterpreter import Spar.Error -import qualified Spar.Intra.BrigApp as Brig +import qualified Spar.Intra.RpcApp as Intra import Spar.Options import Spar.Orphans () import Spar.Scim hiding (handle) import Spar.Sem.AReqIDStore (AReqIDStore) import Spar.Sem.AssIDStore (AssIDStore) -import Spar.Sem.BrigAccess (BrigAccess, getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import qualified Spar.Sem.DefaultSsoCode as DefaultSsoCode -import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.GalleyAccess as GalleyAccess import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore) import qualified Spar.Sem.IdPRawMetadataStore as IdPRawMetadataStore import Spar.Sem.Reporter (Reporter) @@ -128,6 +125,9 @@ import Wire.API.User import Wire.API.User.Auth (CookieLabel) import Wire.API.User.IdentityProvider import Wire.API.User.Saml +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess as BrigAPIAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.IdPConfigStore (IdPConfigStore, Replaced (..), Replacing (..)) import qualified Wire.IdPConfigStore as IdPConfigStore import Wire.IdPSubsystem (IdPSubsystem) @@ -159,8 +159,8 @@ app ctx0 req cont = do cont api :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member (Input Opts) r, Member AssIDStore r, Member AReqIDStore r, @@ -198,10 +198,10 @@ api opts = :<|> apiINTERNAL apiSSO :: - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member (Logger String) r, Member (Input Opts) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member AssIDStore r, Member VerdictFormatStore r, Member AReqIDStore r, @@ -233,8 +233,8 @@ apiIDP :: ( Member Random r, Member (Logger String) r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -261,8 +261,8 @@ apiINTERNAL :: Member ScimUserTimesStore r, Member (Logger (Msg -> Msg)) r, Member Random r, - Member GalleyAccess r, - Member BrigAccess r + Member GalleyAPIAccess r, + Member BrigAPIAccess r ) => ServerT InternalAPI (Sem r) apiINTERNAL = @@ -384,8 +384,8 @@ authresp :: ( Member Random r, Member (Logger String) r, Member (Input Opts) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member AssIDStore r, Member VerdictFormatStore r, Member AReqIDStore r, @@ -491,7 +491,7 @@ authHandler :: Env -> AuthHandler Request TeamId authHandler ctx = mkAuthHandler $ \req -> (either throwError' pure =<<) $ runSparToHandler ctx $ runError $ do bs <- maybe (throwSparSem SparMissingZUsr) pure $ lookup "Z-User" (requestHeaders req) uid <- maybe (throwSparSem $ SparNoPermission "[internal error] Can't parse Z-User header") pure $ fromByteString bs - BrigAccess.checkAdminGetTeamId uid + BrigAPIAccess.checkAdminGetTeamId uid >>= either (\e -> throwSparSem $ SparNoPermission (Wai.message e)) pure where throwError' se = Spar.Error.sparToServerErrorWithLogging (sparCtxLogger ctx) se >>= throwError @@ -501,8 +501,8 @@ authContext e = authHandler e :. EmptyContext idpGet :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => @@ -515,8 +515,8 @@ idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do pure idp idpGetRaw :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, Member (Error SparError) r @@ -534,22 +534,22 @@ idpGetRaw zusr idpid = do idpGetAll :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => Maybe UserId -> Sem r IdPList idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do - teamid <- Brig.getZUsrCheckPerm zusr ReadIdp + teamid <- Intra.getZUsrCheckPerm zusr ReadIdp idpGetAllByTeamId teamid idpGetAllByTeamId :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => @@ -571,8 +571,8 @@ idpDelete :: forall r. ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member SAMLUserStore r, Member IdPConfigStore r, @@ -603,7 +603,7 @@ idpDelete samlConfig mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idp IdPConfigStore.deleteConfig idp IdPRawMetadataStore.delete idpid when (SAML.isMultiIngressConfig samlConfig) $ - BrigAccess.sendSAMLIdPChangedEmail $ + BrigAPIAccess.sendSAMLIdPChangedEmail $ IdPDeleted zusr idp logIdPAction "IdP deleted" @@ -615,13 +615,13 @@ idpDelete samlConfig mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idp assertEmptyOrPurge :: TeamId -> Cas.Page (SAML.UserRef, UserId) -> Sem r () assertEmptyOrPurge teamId page = do forM_ (Cas.result page) $ \(uref, uid) -> do - mAccount <- BrigAccess.getAccount NoPendingInvitations uid + mAccount <- BrigAPIAccess.getAccount NoPendingInvitations uid let mUserTeam = userTeam =<< mAccount when (mUserTeam == Just teamId) $ do if purge then do SAMLUserStore.delete uid uref - void $ BrigAccess.deleteUser uid + void $ BrigAPIAccess.deleteUser uid else do throwSparSem SparIdPHasBoundUsers when (Cas.hasMore page) $ @@ -648,7 +648,7 @@ idpDelete samlConfig mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idp idpDoesAuthSelf :: IdP -> UserId -> Sem r Bool idpDoesAuthSelf idp uid = do let idpIssuer = idp ^. SAML.idpMetadata . SAML.edIssuer - mUserIssuer <- (>>= userIssuer) <$> getAccount NoPendingInvitations uid + mUserIssuer <- (>>= userIssuer) <$> BrigAPIAccess.getAccount NoPendingInvitations uid pure $ mUserIssuer == Just idpIssuer -- | We generate a new UUID for each IdP used as IdPConfig's path, thereby ensuring uniqueness. @@ -664,8 +664,8 @@ idpDelete samlConfig mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idp idpCreate :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -682,7 +682,7 @@ idpCreate :: Sem r IdP idpCreate samlConfig tid zUser uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmeta) mReplaces (fromMaybe defWireIdPAPIVersion -> apiversion) mHandle = withDebugLog "idpCreateXML" (Just . show . (^. SAML.idpId)) $ do let mbHost = filterMultiIngressZHost (samlConfig._cfgDomainConfigs) uncheckedMbHost - GalleyAccess.assertSSOEnabled tid + Intra.assertSSOEnabled tid guardMultiIngressDuplicateDomain tid mbHost idp <- maybe (IdPConfigStore.newHandle tid) (pure . IdPHandle . fromRange) mHandle @@ -692,7 +692,7 @@ idpCreate samlConfig tid zUser uncheckedMbHost (IdPMetadataValue rawIdpMetadata forM_ mReplaces $ \replaces -> IdPConfigStore.setReplacedBy (Replaced replaces) (Replacing (idp ^. SAML.idpId)) when (SAML.isMultiIngressConfig samlConfig) $ - BrigAccess.sendSAMLIdPChangedEmail $ + BrigAPIAccess.sendSAMLIdPChangedEmail $ IdPCreated zUser idp logIdPAction "IdP created" @@ -737,8 +737,8 @@ filterMultiIngressZHost _ _ = Nothing idpCreateV7 :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -841,8 +841,8 @@ validateNewIdP apiversion _idpMetadata teamId mReplaces idpDomain idHandle = wit idpUpdate :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, Member (Error SparError) r @@ -861,8 +861,8 @@ idpUpdate samlConfig zusr uncheckedMbHost (IdPMetadataValue raw xml) = idpUpdateXML :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, Member (Error SparError) r @@ -877,7 +877,7 @@ idpUpdateXML :: Sem r IdP idpUpdateXML samlConfig mbZUsr mDomain raw idpmeta idpid mHandle = withDebugLog "idpUpdateXML" (Just . show . (^. SAML.idpId)) $ do (zUsr, teamid, idp, previousIdP) <- validateIdPUpdate mbZUsr idpmeta idpid - GalleyAccess.assertSSOEnabled teamid + Intra.assertSSOEnabled teamid guardMultiIngressDuplicateDomain teamid mDomain idpid IdPRawMetadataStore.store (idp ^. SAML.idpId) raw let idp' :: IdP = case mHandle of @@ -895,7 +895,7 @@ idpUpdateXML samlConfig mbZUsr mDomain raw idpmeta idpid mHandle = withDebugLog WireIdPAPIV2 -> Just teamid forM_ (idp'' ^. SAML.idpExtraInfo . oldIssuers) (flip IdPConfigStore.deleteIssuer mbteamid) when (SAML.isMultiIngressConfig samlConfig) $ - BrigAccess.sendSAMLIdPChangedEmail $ + BrigAPIAccess.sendSAMLIdPChangedEmail $ IdPUpdated zUsr previousIdP idp'' logIdPUpdate zUsr idp'' previousIdP pure idp'' @@ -982,8 +982,8 @@ validateIdPUpdate :: (HasCallStack, m ~ Sem r) => ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => @@ -1048,8 +1048,8 @@ withDebugLog msg showval action = do authorizeIdP :: ( HasCallStack, - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member (Error SparError) r ) ) => @@ -1063,7 +1063,7 @@ authorizeIdP Nothing _ = ) authorizeIdP (Just zusr) idp = do let teamid = idp ^. SAML.idpExtraInfo . team - GalleyAccess.assertHasPermission teamid CreateUpdateDeleteIdp zusr + Intra.assertHasPermission teamid CreateUpdateDeleteIdp zusr pure (zusr, teamid) enforceHttps :: (Member (Error SparError) r) => URI.URI -> Sem r () diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index f43a93abddd..8ec7c658523 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -71,14 +71,10 @@ import qualified SAML2.WebSSO as SAML import Servant import qualified Servant.Multipart as Multipart import Spar.Error hiding (sparToServerErrorWithLogging) -import qualified Spar.Intra.BrigApp as Intra +import qualified Spar.Intra.RpcApp as Intra import Spar.Options import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) -import Spar.Sem.BrigAccess (BrigAccess, getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess -import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.GalleyAccess as GalleyAccess import Spar.Sem.Reporter (Reporter) import qualified Spar.Sem.Reporter as Reporter import Spar.Sem.SAMLUserStore (SAMLUserStore) @@ -97,7 +93,11 @@ import Wire.API.User import Wire.API.User.Auth import Wire.API.User.IdentityProvider import Wire.API.User.Saml +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess as BrigAPIAccess import Wire.Error +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import qualified Wire.GalleyAPIAccess as GalleyAPIAccess import Wire.IdPConfigStore (IdPConfigStore) import qualified Wire.IdPConfigStore as IdPConfigStore import Wire.ScimSubsystem.Interpreter @@ -139,17 +139,17 @@ data Env = Env -- -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQSERVICES-1655 getUserByUrefUnsafe :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r ) => SAML.UserRef -> Sem r (Maybe User) getUserByUrefUnsafe uref = do - maybe (pure Nothing) (getAccount Intra.WithPendingInvitations) =<< SAMLUserStore.get uref + maybe (pure Nothing) (BrigAPIAccess.getAccount Intra.WithPendingInvitations) =<< SAMLUserStore.get uref -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR getUserIdByScimExternalId :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r ) => TeamId -> @@ -182,7 +182,7 @@ getUserIdByScimExternalId tid eid = do -- undeletable in the team admin page, and ask admins to go talk to their IdP system. createSamlUserWithId :: ( Member (Error SparError) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member SAMLUserStore r ) => TeamId -> @@ -194,7 +194,7 @@ createSamlUserWithId teamid buid suid role = do uname <- either (throwSparSem . SparBadUserName . LText.pack) pure $ Intra.mkUserName Nothing (That suid) - buid' <- BrigAccess.createSAML suid buid teamid uname ManagedByWire Nothing Nothing Nothing role + buid' <- BrigAPIAccess.createSAML suid buid teamid uname ManagedByWire Nothing Nothing Nothing role assert (buid == buid') $ pure () SAMLUserStore.insert suid buid @@ -203,8 +203,8 @@ createSamlUserWithId teamid buid suid role = do -- https://wearezeta.atlassian.net/browse/SQSERVICES-1655) autoprovisionSamlUser :: forall r. - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member (Error SparError) r, @@ -237,8 +237,8 @@ autoprovisionSamlUser idp buid suid = do -- make brig initiate the email validate procedure. validateSamlEmailIfExists :: forall r. - ( Member GalleyAccess r, - Member BrigAccess r + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r ) => UserId -> SAML.UserRef -> @@ -251,17 +251,17 @@ validateSamlEmailIfExists uid = \case validateEmail :: forall r. - ( Member GalleyAccess r, - Member BrigAccess r + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r ) => Maybe TeamId -> UserId -> EmailAddress -> Sem r () validateEmail (Just tid) uid email = do - enabled <- GalleyAccess.isEmailValidationEnabledTeam tid + enabled <- GalleyAPIAccess.isEmailValidationEnabledTeam tid let activation = if enabled then SendActivationEmail else AutoActivate - BrigAccess.updateEmail uid email activation + BrigAPIAccess.updateEmail uid email activation validateEmail _ _ _ = pure () -- | The from of the response on the finalize-login request depends on the verdict (denied or @@ -277,8 +277,8 @@ verdictHandler :: (HasCallStack) => ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member AReqIDStore r, Member VerdictFormatStore r, Member ScimTokenStore r, @@ -324,8 +324,8 @@ verdictHandlerResult :: (HasCallStack) => ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member (Error SparError) r, @@ -368,7 +368,7 @@ catchVerdictErrors = (`catch` hndlr) -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQSERVICES-1655 getUserByUrefViaOldIssuerUnsafe :: forall r. - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r ) => IdP -> @@ -386,7 +386,7 @@ getUserByUrefViaOldIssuerUnsafe idp (SAML.UserRef _ subject) = do -- | After a user has been found using 'findUserWithOldIssuer', update it everywhere so that -- the old IdP is not needed any more next time. moveUserToNewIssuer :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r ) => SAML.UserRef -> @@ -395,15 +395,15 @@ moveUserToNewIssuer :: Sem r () moveUserToNewIssuer oldUserRef newUserRef uid = do SAMLUserStore.insert newUserRef uid - BrigAccess.setSSOId uid (UserSSOId newUserRef) + BrigAPIAccess.setSSOId uid (UserSSOId newUserRef) SAMLUserStore.delete uid oldUserRef verdictHandlerResultCore :: (HasCallStack) => ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member (Error SparError) r, @@ -439,7 +439,7 @@ verdictHandlerResultCore idp verdict mlabel = case verdict of pure buid Logger.log Logger.Debug ("granting sso login for " <> show uid) - cky <- BrigAccess.ssoLogin uid mlabel + cky <- BrigAPIAccess.ssoLogin uid mlabel pure $ VerifyHandlerGranted cky uid -- | If the client is web, it will be served with an HTML page that it can process to decide whether diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index 884a534b4d1..235a7f78392 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -41,12 +41,8 @@ import Spar.Sem.AReqIDStore (AReqIDStore) import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra) import Spar.Sem.AssIDStore (AssIDStore) import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) -import Spar.Sem.BrigAccess (BrigAccess) -import Spar.Sem.BrigAccess.Http (brigAccessToHttp) import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) -import Spar.Sem.GalleyAccess (GalleyAccess) -import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore) import Spar.Sem.IdPRawMetadataStore.Cassandra (idpRawMetadataStoreToCassandra) import Spar.Sem.Reporter (Reporter) @@ -63,23 +59,24 @@ import Spar.Sem.ScimTokenStore (ScimTokenStore) import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra) import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra) -import Spar.Sem.Utils (idpDbErrorToSparError, interpretClientToIO, ttlErrorToSparError) +import Spar.Sem.Utils import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import Spar.Sem.VerdictFormatStore.Cassandra (verdictFormatStoreToCassandra) import qualified System.Logger as TinyLog import Wire.API.Routes.Version (expandVersionExp) import Wire.API.User.Saml (TTLError) -import Wire.BrigAPIAccess (BrigAPIAccess) -import Wire.BrigAPIAccess.Rpc (interpretBrigAccess) +import Wire.BrigAPIAccess +import Wire.BrigAPIAccess.Rpc import Wire.ClientSubsystem.Error (ClientError, clientErrorToHttpError) -import Wire.GalleyAPIAccess (GalleyAPIAccess) -import Wire.GalleyAPIAccess.Rpc (interpretGalleyAPIAccessToRpc) +import Wire.GalleyAPIAccess +import Wire.GalleyAPIAccess.Rpc import Wire.IdPConfigStore (IdPConfigStore) import Wire.IdPConfigStore.Cassandra (idPToCassandra) import Wire.IdPSubsystem (IdPSubsystem) import Wire.IdPSubsystem.Interpreter (IdPSubsystemError, interpretIdPSubsystem) import Wire.ParseException (ParseException, parseExceptionToHttpError) import Wire.Rpc (Rpc, runRpcWithHttp) +import Wire.RpcException import Wire.ScimSubsystem import Wire.ScimSubsystem.Interpreter import Wire.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog) @@ -114,10 +111,9 @@ type LowerLevelCanonicalEffs = IdPRawMetadataStore, SAMLUserStore, Embed Cas.Client, - BrigAccess, - GalleyAccess, Error IdpDbError, Error TTLError, + Error RpcException, Error SparError, Reporter, Logger String, @@ -142,10 +138,9 @@ runSparToIO ctx = . stringLoggerToTinyLog . reporterToTinyLogWai . runError @SparError + . rpcExceptionToSparError . ttlErrorToSparError . idpDbErrorToSparError - . galleyAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) - . brigAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx) . interpretClientToIO (sparCtxCas ctx) . samlUserStoreToCassandra . idpRawMetadataStoreToCassandra diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index 328c4725b3f..2dbc8675461 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -31,8 +31,6 @@ module Spar.Error IdpDbError (..), throwSpar, sparToServerErrorWithLogging, - rethrow, - parseResponse, -- FUTUREWORK: we really shouldn't export this, but that requires that we can use our -- custom servant monad in the 'MakeCustomError' instances. sparToServerError, @@ -44,15 +42,11 @@ module Spar.Error ) where -import Bilge (ResponseLBS, responseBody, responseJsonMaybe) -import qualified Bilge import Control.Monad.Except import Data.Aeson import qualified Data.ByteString.Lazy as LBS import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Encoding as LText -import Data.Typeable (typeRep) -import GHC.Stack (callStack, prettyCallStack) import Imports import Network.HTTP.Types.Status import qualified Network.Wai as Wai @@ -67,6 +61,7 @@ import Wire.API.User.Saml (TTLError) import Wire.Error import Wire.IdPConfigStore import Wire.IdPSubsystem.Interpreter +import Wire.RpcException import Wire.ScimSubsystem.Interpreter type SparError = SAML.Error SparCustomError @@ -99,11 +94,13 @@ data SparCustomError | SparCannotCreateUsersOnReplacedIdP LText | SparCouldNotParseRfcResponse LText LText | SparReAuthRequired + | SparReAuthRateLimitExceeded | SparReAuthCodeAuthFailed | SparReAuthCodeAuthRequired | SparCouldNotRetrieveCookie | SparCassandraError LText | SparCassandraTTLError TTLError + | SparRpcException RpcException | SparNewIdPBadMetadata LText | SparNewIdPPubkeyMismatch | SparNewIdPAlreadyInUse LText @@ -163,6 +160,7 @@ renderSparError (SAML.CustomError (SparCannotCreateUsersOnReplacedIdP replacingI -- RFC-specific errors renderSparError (SAML.CustomError (SparCouldNotParseRfcResponse service msg)) = StdError $ Wai.mkError status502 "bad-upstream" ("Could not parse " <> service <> " response body: " <> msg) renderSparError (SAML.CustomError SparReAuthRequired) = StdError $ Wai.mkError status403 "access-denied" "This operation requires reauthentication." +renderSparError (SAML.CustomError SparReAuthRateLimitExceeded) = StdError $ Wai.mkError status429 "rate-limit-exceeded" "Please use exponential backoff throttling to mitigate this." renderSparError (SAML.CustomError SparReAuthCodeAuthFailed) = StdError $ Wai.mkError status403 "code-authentication-failed" "Reauthentication failed with invalid verification code." renderSparError (SAML.CustomError SparReAuthCodeAuthRequired) = StdError $ Wai.mkError status403 "code-authentication-required" "Reauthentication failed. Verification code required." renderSparError (SAML.CustomError SparCouldNotRetrieveCookie) = StdError $ Wai.mkError status502 "bad-upstream" "Unable to get a cookie from an upstream server." @@ -173,6 +171,7 @@ renderSparError (SAML.CustomError (SparCassandraTTLError ttlerr)) = status400 "ttl-error" (LText.pack $ show ttlerr) +renderSparError (SAML.CustomError (SparRpcException err)) = StdError $ rpcExcepctionToWaiError err renderSparError (SAML.UnknownIdP msg) = StdError $ Wai.mkError status404 "not-found" ("IdP not found: " <> msg) renderSparError (SAML.Forbidden msg) = StdError $ Wai.mkError status403 "forbidden" ("Forbidden: " <> msg) renderSparError (SAML.BadSamlResponseBase64Error msg) = @@ -239,47 +238,6 @@ renderSparError (SAML.CustomError (SparSomeHttpError err)) = err -- Other renderSparError (SAML.CustomServant err) = serverErrorToHttpError err --- | If a call to another backend service fails, just respond with whatever it said. --- --- FUTUREWORK: with servant, there will be a way for the type checker to confirm that we --- handle all exceptions that brig can legally throw! -rethrow :: LText -> ResponseLBS -> (HasCallStack, Log.MonadLogger m, MonadError SparError m) => m a -rethrow serviceName resp = do - Log.info - ( Log.msg ("rfc error" :: Text) - . Log.field "status" (Bilge.statusCode resp) - . Log.field "error" (show err) - . Log.field "callstack" (prettyCallStack callStack) - ) - throwError err - where - err :: SparError - err = - responseJsonMaybe resp - & maybe - ( SAML.CustomError - . SparCouldNotParseRfcResponse serviceName - . ("internal error: " <>) - . LText.pack - . show - . (Bilge.statusCode resp,) - . fromMaybe "" - . responseBody - $ resp - ) - (SAML.CustomServant . waiToServant) - -parseResponse :: forall a m. (FromJSON a, MonadError SparError m, Typeable a) => LText -> ResponseLBS -> m a -parseResponse serviceName resp = do - let typeinfo :: LText - typeinfo = LText.pack $ show (typeRep ([] @a)) <> ": " - - err :: forall a'. LText -> m a' - err = throwSpar . SparCouldNotParseRfcResponse serviceName . (typeinfo <>) - - bdy <- maybe (err "no body") pure $ responseBody resp - either (err . LText.pack) pure $ eitherDecode' bdy - mapScimSubsystemErrors :: (Member (Error SparError) r) => InterpreterFor (Error ScimSubsystemError) r mapScimSubsystemErrors = Polysemy.Error.mapError (SAML.CustomError . SparScimError . scimSubsystemErrorToScimError) diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs deleted file mode 100644 index fef947f5c28..00000000000 --- a/services/spar/src/Spar/Intra/Brig.hs +++ /dev/null @@ -1,463 +0,0 @@ --- Disabling to stop warnings on HasCallStack -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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 . - --- | Client functions for interacting with the Brig API. -module Spar.Intra.Brig - ( MonadSparToBrig (..), - getBrigUserAccount, - getBrigUserByHandle, - getBrigUserByEmail, - getBrigUserRichInfo, - setBrigUserName, - setBrigUserHandle, - setBrigUserManagedBy, - setBrigUserSSOId, - setBrigUserRichInfo, - setBrigUserLocale, - checkHandleAvailable, - deleteBrigUserInternal, - createBrigUserSAML, - createBrigUserNoSAML, - updateEmail, - ensureReAuthorised, - ssoLogin, - getStatus, - getStatusMaybe, - setStatus, - getDefaultUserLocale, - checkAdminGetTeamId, - sendSAMLIdPChangedEmail, - ) -where - -import Bilge -import Control.Monad.Except -import Data.ByteString.Conversion -import Data.Code as Code -import Data.Handle (Handle (fromHandle)) -import Data.Id (Id (Id), TeamId, UserId) -import Data.Misc (PlainTextPassword6) -import qualified Data.Text.Lazy as Lazy -import Imports -import Network.HTTP.Types.Method -import qualified Network.Wai.Utilities.Error as Wai -import qualified SAML2.WebSSO as SAML -import Spar.Error -import qualified System.Logger.Class as Log -import Web.Cookie -import Wire.API.Locale -import Wire.API.Routes.Internal.Brig (IdpChangedNotification) -import Wire.API.Team.Role (Role) -import Wire.API.User -import Wire.API.User.Auth -import Wire.API.User.Auth.ReAuth -import Wire.API.User.Auth.Sso -import Wire.API.User.RichInfo as RichInfo -import Wire.UserSubsystem (HavePendingInvitations (..)) - ----------------------------------------------------------------------- - --- | Similar to 'Network.Wire.Client.API.Auth.tokenResponse', but easier: we just need to set the --- cookie in the response, and the redirect will make the client negotiate a fresh auth token. --- (This is the easiest way, since the login-request that we are in the middle of responding to here --- is not from the wire client, but from a browser that is still processing a redirect from the --- IdP.) -respToCookie :: (HasCallStack, MonadError SparError m) => ResponseLBS -> m SetCookie -respToCookie resp = do - let crash = throwSpar SparCouldNotRetrieveCookie - unless (statusCode resp == 200) crash - maybe crash (pure . parseSetCookie) $ getHeader "Set-Cookie" resp - ----------------------------------------------------------------------- - -class (Log.MonadLogger m, MonadError SparError m) => MonadSparToBrig m where - call :: (Request -> Request) -> m ResponseLBS - -createBrigUserSAML :: - (HasCallStack, MonadSparToBrig m) => - SAML.UserRef -> - UserId -> - TeamId -> - -- | User name - Name -> - -- | Who should have control over the user - ManagedBy -> - Maybe Handle -> - Maybe RichInfo -> - Maybe Locale -> - Role -> - m UserId -createBrigUserSAML uref (Id buid) teamid name managedBy handle richInfo mLocale role = do - let newUser = - NewUserSpar - { newUserSparUUID = buid, - newUserSparDisplayName = name, - newUserSparSSOId = UserSSOId uref, - newUserSparTeamId = teamid, - newUserSparManagedBy = managedBy, - newUserSparHandle = handle, - newUserSparRichInfo = richInfo, - newUserSparLocale = mLocale, - newUserSparRole = role - } - resp :: ResponseLBS <- - call $ - method POST - . path "/i/users/spar" - . json newUser - if statusCode resp `elem` [200, 201] - then userId . selfUser <$> parseResponse @SelfProfile "brig" resp - else rethrow "brig" resp - -createBrigUserNoSAML :: - (HasCallStack, MonadSparToBrig m) => - Text -> - EmailAddress -> - UserId -> - TeamId -> - -- | User name - Name -> - Maybe Locale -> - Role -> - m UserId -createBrigUserNoSAML extId email uid teamid uname locale role = do - let newUser = NewUserScimInvitation teamid uid extId locale uname email role - resp :: ResponseLBS <- - call $ - method POST - . paths ["/i/teams", toByteString' teamid, "invitations"] - . json newUser - - if statusCode resp `elem` [200, 201] - then userId <$> parseResponse @User "brig" resp - else rethrow "brig" resp - -updateEmail :: (HasCallStack, MonadSparToBrig m) => UserId -> EmailAddress -> EmailActivation -> m () -updateEmail buid email activation = do - resp <- - call $ - method PUT - . path "/i/self/email" - . header "Z-User" (toByteString' buid) - . query - [ ("activation", Just (toByteString' activation)), - -- FUTUREWORK: the following two are for backwards compatibility during deployment - -- of the release containing https://github.com/wireapp/wire-server/pull/4617, can - -- be removed later (fisx, 2025-06-19) - ("validate", Just (fromBool validate)), - ("activate", Just (fromBool activate)) - ] - . json (EmailUpdate email) - case statusCode resp of - 204 -> pure () - 202 -> pure () - _ -> rethrow "brig" resp - where - (validate, activate) = case activation of - AutoActivate -> (False, True) - SendActivationEmail -> (True, False) - - fromBool :: Bool -> ByteString - fromBool True = "true" - fromBool False = "false" - --- | Get a user; returns 'Nothing' if the user was not found or has been deleted. -getBrigUserAccount :: (HasCallStack, MonadSparToBrig m) => HavePendingInvitations -> UserId -> m (Maybe User) -getBrigUserAccount havePending buid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["/i/users"] - . query - [ ("ids", Just $ toByteString' buid), - ( "includePendingInvitations", - Just . toByteString' $ - case havePending of - WithPendingInvitations -> True - NoPendingInvitations -> False - ) - ] - - case statusCode resp of - 200 -> - parseResponse @[User] "brig" resp >>= \case - [account] -> - pure $ - if userDeleted account - then Nothing - else Just account - _ -> pure Nothing - 404 -> pure Nothing - _ -> rethrow "brig" resp - --- | Get a user; returns 'Nothing' if the user was not found. --- --- TODO: currently this is not used, but it might be useful later when/if --- @hscim@ stops doing checks during user creation. -getBrigUserByHandle :: (HasCallStack, MonadSparToBrig m) => Handle -> m (Maybe User) -getBrigUserByHandle handle = do - resp :: ResponseLBS <- - call $ - method GET - . path "/i/users" - . queryItem "handles" (toByteString' handle) - . queryItem "includePendingInvitations" "true" - case statusCode resp of - 200 -> listToMaybe <$> parseResponse @[User] "brig" resp - 404 -> pure Nothing - _ -> rethrow "brig" resp - -getBrigUserByEmail :: (HasCallStack, MonadSparToBrig m) => EmailAddress -> m (Maybe User) -getBrigUserByEmail email = do - resp :: ResponseLBS <- - call $ - method GET - . path "/i/users" - . queryItem "email" (toByteString' email) - . queryItem "includePendingInvitations" "true" - case statusCode resp of - 200 -> do - macc <- listToMaybe <$> parseResponse @[User] "brig" resp - case userEmail =<< macc of - Just email' | email' == email -> pure macc - _ -> pure Nothing - 404 -> pure Nothing - _ -> rethrow "brig" resp - --- | Set user' name. Fails with status <500 if brig fails with <500, and with 500 if brig --- fails with >= 500. -setBrigUserName :: (HasCallStack, MonadSparToBrig m) => UserId -> Name -> m () -setBrigUserName buid (Name name) = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' buid, "name"] - . json (NameUpdate name) - let sCode = statusCode resp - if sCode < 300 - then pure () - else rethrow "brig" resp - --- | Set user's handle. Fails with status <500 if brig fails with <500, and with 500 if brig fails --- with >= 500. --- --- NB: that this doesn't take a 'HandleUpdate', since we already construct a valid handle in --- 'validateScimUser' to increase the odds that user creation doesn't fail half-way through --- the many database write operations. -setBrigUserHandle :: (HasCallStack, MonadSparToBrig m) => UserId -> Handle {- not 'HandleUpdate'! -} -> m () -setBrigUserHandle buid handle = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' buid, "handle"] - . json (HandleUpdate (fromHandle handle)) - case (statusCode resp, Wai.label <$> responseJsonMaybe @Wai.Error resp) of - (200, Nothing) -> - pure () - _ -> - rethrow "brig" resp - --- | Set user's managedBy. Fails with status <500 if brig fails with <500, and with 500 if --- brig fails with >= 500. -setBrigUserManagedBy :: (HasCallStack, MonadSparToBrig m) => UserId -> ManagedBy -> m () -setBrigUserManagedBy buid managedBy = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' buid, "managed-by"] - . json (ManagedByUpdate managedBy) - unless (statusCode resp == 200) $ - rethrow "brig" resp - --- | Set user's UserSSOId. -setBrigUserSSOId :: (HasCallStack, MonadSparToBrig m) => UserId -> UserSSOId -> m () -setBrigUserSSOId buid ssoId = do - resp <- - call $ - method PUT - . paths ["i", "users", toByteString' buid, "sso-id"] - . json ssoId - case statusCode resp of - 200 -> pure () - _ -> rethrow "brig" resp - --- | Set user's richInfo. Fails with status <500 if brig fails with <500, and with 500 if --- brig fails with >= 500. -setBrigUserRichInfo :: (HasCallStack, MonadSparToBrig m) => UserId -> RichInfo -> m () -setBrigUserRichInfo buid richInfo = do - resp <- - call $ - method PUT - . paths ["i", "users", toByteString' buid, "rich-info"] - . json (RichInfoUpdate $ unRichInfo richInfo) - unless (statusCode resp == 200) $ - rethrow "brig" resp - -setBrigUserLocale :: (HasCallStack, MonadSparToBrig m) => UserId -> Maybe Locale -> m () -setBrigUserLocale buid = \case - Just locale -> do - resp <- - call $ - method PUT - . paths ["i", "users", toByteString' buid, "locale"] - . json (LocaleUpdate locale) - unless (statusCode resp == 200) $ - rethrow "brig" resp - Nothing -> do - resp <- - call $ - method DELETE - . paths ["i", "users", toByteString' buid, "locale"] - unless (statusCode resp == 200) $ - rethrow "brig" resp - -getBrigUserRichInfo :: (HasCallStack, MonadSparToBrig m) => UserId -> m RichInfo -getBrigUserRichInfo buid = do - resp <- - call $ - method GET - . paths ["/i/users", toByteString' buid, "rich-info"] - case statusCode resp of - 200 -> parseResponse "brig" resp - _ -> rethrow "brig" resp - -checkHandleAvailable :: (HasCallStack, MonadSparToBrig m) => Handle -> m Bool -checkHandleAvailable hnd = do - resp <- - call $ - method HEAD - . paths ["/i/users/handles", toByteString' hnd] - let sCode = statusCode resp - if - | sCode == 200 -> -- handle exists - pure False - | sCode == 404 -> -- handle not found - pure True - | otherwise -> - rethrow "brig" resp - --- | Call brig to delete a user. --- If the user wasn't deleted completely before, another deletion attempt will be made. -deleteBrigUserInternal :: (HasCallStack, MonadSparToBrig m) => UserId -> m DeleteUserResult -deleteBrigUserInternal buid = do - resp <- - call $ - method DELETE - . paths ["/i/users", toByteString' buid] - case statusCode resp of - 200 -> pure AccountAlreadyDeleted - 202 -> pure AccountDeleted - 404 -> pure NoUser - _ -> rethrow "brig" resp - --- | Verify user's password (needed for certain powerful operations). -ensureReAuthorised :: - (HasCallStack, MonadSparToBrig m) => - Maybe UserId -> - Maybe PlainTextPassword6 -> - Maybe Code.Value -> - Maybe VerificationAction -> - m () -ensureReAuthorised Nothing _ _ _ = throwSpar SparMissingZUsr -ensureReAuthorised (Just uid) secret mbCode mbAction = do - resp <- - call $ - method GET - . paths ["/i/users", toByteString' uid, "reauthenticate"] - . json (ReAuthUser secret mbCode mbAction) - case (statusCode resp, errorLabel resp) of - (200, _) -> pure () - (403, Just "code-authentication-required") -> throwSpar SparReAuthCodeAuthRequired - (403, Just "code-authentication-failed") -> throwSpar SparReAuthCodeAuthFailed - (403, _) -> throwSpar SparReAuthRequired - (_, _) -> rethrow "brig" resp - where - errorLabel :: ResponseLBS -> Maybe Lazy.Text - errorLabel = fmap Wai.label . responseJsonMaybe - --- | Get persistent cookie from brig and redirect user past login process. --- --- If brig responds with status >=400;<500, return Nothing. Otherwise, crash (500). -ssoLogin :: - (HasCallStack, MonadSparToBrig m) => - UserId -> - Maybe CookieLabel -> - m SetCookie -ssoLogin buid mlabel = do - resp :: ResponseLBS <- - call $ - method POST - . path "/i/sso-login" - . json (SsoLogin buid mlabel) - . queryItem "persist" "true" - if statusCode resp == 200 - then respToCookie resp - else rethrow "brig" resp - -getStatus' :: (HasCallStack, MonadSparToBrig m) => UserId -> m ResponseLBS -getStatus' uid = call $ method GET . paths ["/i/users", toByteString' uid, "status"] - --- | FUTUREWORK: this is probably unnecessary, and we can get the status info from 'UserAccount'. -getStatus :: (HasCallStack, MonadSparToBrig m) => UserId -> m AccountStatus -getStatus uid = do - resp <- getStatus' uid - case statusCode resp of - 200 -> fromAccountStatusResp <$> parseResponse @AccountStatusResp "brig" resp - _ -> rethrow "brig" resp - --- | FUTUREWORK: this is probably unnecessary, and we can get the status info from 'UserAccount'. -getStatusMaybe :: (HasCallStack, MonadSparToBrig m) => UserId -> m (Maybe AccountStatus) -getStatusMaybe uid = do - resp <- getStatus' uid - case statusCode resp of - 200 -> Just . fromAccountStatusResp <$> parseResponse @AccountStatusResp "brig" resp - 404 -> pure Nothing - _ -> rethrow "brig" resp - -setStatus :: (HasCallStack, MonadSparToBrig m) => UserId -> AccountStatus -> m () -setStatus uid status = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' uid, "status"] - . json (AccountStatusUpdate status) - case statusCode resp of - 200 -> pure () - _ -> rethrow "brig" resp - -getDefaultUserLocale :: (HasCallStack, MonadSparToBrig m) => m Locale -getDefaultUserLocale = do - resp <- call $ method GET . paths ["/i/users/locale"] - case statusCode resp of - 200 -> luLocale <$> parseResponse @LocaleUpdate "brig" resp - _ -> rethrow "brig" resp - -checkAdminGetTeamId :: (HasCallStack, MonadSparToBrig m) => UserId -> m TeamId -checkAdminGetTeamId uid = do - resp <- call $ method GET . paths ["/i/users", toByteString' uid, "check-admin-get-team-id"] - case statusCode resp of - 200 -> parseResponse @TeamId "brig" resp - _ -> rethrow "brig" resp - -sendSAMLIdPChangedEmail :: (HasCallStack, MonadSparToBrig m) => IdpChangedNotification -> m () -sendSAMLIdPChangedEmail notif = do - resp <- call $ method POST . path "/i/idp/send-idp-changed-email" . json notif - unless (statusCode resp == 200) $ - rethrow "brig" resp diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs deleted file mode 100644 index 31e3e89ba88..00000000000 --- a/services/spar/src/Spar/Intra/Galley.hs +++ /dev/null @@ -1,131 +0,0 @@ --- Disabling to stop warnings on HasCallStack -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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 . - --- | Client functions for interacting with the Galley API. -module Spar.Intra.Galley where - -import Bilge -import Control.Lens -import Control.Monad.Except -import Data.ByteString.Conversion -import Data.Id (TeamId, UserId) -import qualified Data.Text.Lazy as LText -import Imports -import Network.HTTP.Types.Method -import Spar.Error -import qualified System.Logger.Class as Log -import Wire.API.Team.Feature -import Wire.API.Team.Member -import Wire.API.Team.Role - ----------------------------------------------------------------------- - -class (Monad m, Log.MonadLogger m) => MonadSparToGalley m where - call :: (Request -> Request) -> m ResponseLBS - --- | Get all members of a team. -getTeamMembers :: - (HasCallStack, MonadError SparError m, MonadSparToGalley m) => - TeamId -> - m [TeamMember] -getTeamMembers tid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "members"] - if statusCode resp == 200 - then (^. teamMembers) <$> parseResponse @TeamMemberList "galley" resp - else rethrow "galley" resp - --- | Get a single member of a team. -getTeamMember :: - (HasCallStack, MonadError SparError m, MonadSparToGalley m) => - TeamId -> - UserId -> - m (Maybe TeamMember) -getTeamMember tid uid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "members", toByteString' uid] - if statusCode resp == 200 - then Just <$> parseResponse @TeamMember "galley" resp - else - if statusCode resp == 404 - then pure Nothing - else rethrow "galley" resp - --- | user is member of a given team and has a given permission there. -assertHasPermission :: - (HasCallStack, MonadSparToGalley m, MonadError SparError m, IsPerm TeamMember perm, Show perm) => - TeamId -> - perm -> - UserId -> - m () -assertHasPermission tid perm uid = do - resp <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "members", toByteString' uid] - case (statusCode resp, parseResponse @TeamMember "galley" resp) of - (200, Right member) | hasPermission member perm -> pure () - _ -> throwSpar (SparNoPermission (LText.pack $ show perm)) - -assertSSOEnabled :: - (HasCallStack, MonadError SparError m, MonadSparToGalley m) => - TeamId -> - m () -assertSSOEnabled tid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "features", "sso"] - unless (statusCode resp == 200) $ - rethrow "galley" resp - ws :: LockableFeature SSOConfig <- parseResponse "galley" resp - unless (ws.status == FeatureStatusEnabled) $ - throwSpar SparSSODisabled - -isEmailValidationEnabledTeam :: (HasCallStack, MonadSparToGalley m) => TeamId -> m Bool -isEmailValidationEnabledTeam tid = do - resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validateSAMLemails"] - pure - ( statusCode resp == 200 - && ( ((.status) <$> responseJsonMaybe @(LockableFeature RequireExternalEmailVerificationConfig) resp) - == Just FeatureStatusEnabled - ) - ) - --- | Update a team member. -updateTeamMember :: - (MonadIO m, HasCallStack, MonadSparToGalley m) => - UserId -> - TeamId -> - Role -> - m () -updateTeamMember u tid role = do - let reqBody = mkNewTeamMember u (rolePermissions role) Nothing - rs <- - call $ - method PUT - . paths ["i", "teams", toByteString' tid, "members"] - . contentJson - . json reqBody - print rs diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/RpcApp.hs similarity index 71% rename from services/spar/src/Spar/Intra/BrigApp.hs rename to services/spar/src/Spar/Intra/RpcApp.hs index c1729747b3a..7b959a9a094 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/RpcApp.hs @@ -19,8 +19,8 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . --- | Client functions for interacting with the Brig API. -module Spar.Intra.BrigApp +-- | Client functions for interacting with the APIs of Brig, Galley, and possibly others. +module Spar.Intra.RpcApp ( veidToUserSSOId, urefToExternalId, oldVeidFromBrigUser, @@ -31,8 +31,10 @@ module Spar.Intra.BrigApp getBrigUserTeam, getZUsrCheckPerm, authorizeScimTokenManagement, - parseResponse, giveDefaultHandle, + ensureReAuthorised, + assertHasPermission, + assertSSOEnabled, -- * re-exports, mostly for historical reasons and lazyness emailFromSAML, @@ -44,25 +46,31 @@ import Control.Monad.Except import Data.ByteString.Conversion import Data.CaseInsensitive (original) import qualified Data.CaseInsensitive as CI +import Data.Code as Code import Data.Handle (Handle, parseHandle) import Data.HavePendingInvitations import Data.Id (TeamId, UserId) +import Data.Misc (PlainTextPassword6) import Data.Text.Encoding import Data.Text.Encoding.Error +import qualified Data.Text.Lazy as LText import Data.These import Data.These.Combinators import Imports import Polysemy import Polysemy.Error import qualified SAML2.WebSSO as SAML -import Spar.Error -import Spar.Sem.BrigAccess (BrigAccess) -import qualified Spar.Sem.BrigAccess as BrigAccess -import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.GalleyAccess as GalleyAccess -import Wire.API.Team.Member (HiddenPerm (CreateReadDeleteScimToken), IsPerm, TeamMember) +import Spar.Error (SparCustomError (..), SparError) +import Wire.API.Error.Galley (AuthenticationError (..)) +import Wire.API.Team.Feature +import Wire.API.Team.Member (HiddenPerm (CreateReadDeleteScimToken), IsPerm, TeamMember, hasPermission) import Wire.API.User +import Wire.API.User.Auth.ReAuth (ReAuthUser (..)) import Wire.API.User.Scim (ValidScimId (..)) +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess as BrigAPIAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import qualified Wire.GalleyAPIAccess as GalleyAPIAccess ---------------------------------------------------------------------- @@ -138,16 +146,16 @@ mkUserName Nothing = -- | Check that an id maps to an user on brig that is 'Active' (or optionally -- 'PendingInvitation') and has a team id. -getBrigUserTeam :: (HasCallStack, Member BrigAccess r) => HavePendingInvitations -> UserId -> Sem r (Maybe TeamId) -getBrigUserTeam ifpend = fmap (userTeam =<<) . BrigAccess.getAccount ifpend +getBrigUserTeam :: (HasCallStack, Member BrigAPIAccess r) => HavePendingInvitations -> UserId -> Sem r (Maybe TeamId) +getBrigUserTeam ifpend = fmap (userTeam =<<) . BrigAPIAccess.getAccount ifpend -- | Pull team id for z-user from brig. Check permission in galley. Return team id. Fail if -- permission check fails or the user is not in status 'Active'. getZUsrCheckPerm :: forall r perm. ( HasCallStack, - ( Member BrigAccess r, - Member GalleyAccess r, + ( Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member (Error SparError) r ), IsPerm TeamMember perm, @@ -161,13 +169,13 @@ getZUsrCheckPerm (Just uid) perm = do getBrigUserTeam NoPendingInvitations uid >>= maybe (throw $ SAML.CustomError SparNotInTeam) - (\teamid -> teamid <$ GalleyAccess.assertHasPermission teamid perm uid) + (\teamid -> teamid <$ assertHasPermission teamid perm uid) authorizeScimTokenManagement :: forall r. ( HasCallStack, - ( Member BrigAccess r, - Member GalleyAccess r, + ( Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member (Error SparError) r ) ) => @@ -178,7 +186,7 @@ authorizeScimTokenManagement (Just uid) = do getBrigUserTeam NoPendingInvitations uid >>= maybe (throw $ SAML.CustomError SparNotInTeam) - (\teamid -> teamid <$ GalleyAccess.assertHasPermission teamid CreateReadDeleteScimToken uid) + (\teamid -> teamid <$ assertHasPermission teamid CreateReadDeleteScimToken uid) -- | If the user has no 'Handle', set it to its 'UserId' and update the user in brig. -- Return the handle the user now has (the old one if it existed, the newly created one @@ -194,11 +202,61 @@ authorizeScimTokenManagement (Just uid) = do -- We cannot simply respond with 404 in this case, because the user exists. 404 would suggest -- do the scim peer that it should post the user to create it, but that would create a new -- user instead of finding the old that should be put under scim control. -giveDefaultHandle :: (HasCallStack, Member BrigAccess r) => User -> Sem r Handle +giveDefaultHandle :: (HasCallStack, Member BrigAPIAccess r) => User -> Sem r Handle giveDefaultHandle usr = case userHandle usr of Just handle -> pure handle Nothing -> do let handle = fromJust . parseHandle . decodeUtf8With lenientDecode . toByteString' $ uid uid = userId usr - BrigAccess.setHandle uid handle + BrigAPIAccess.setHandle uid handle pure handle + +-- | Verify user's password (needed for certain powerful operations). +ensureReAuthorised :: + ( Member BrigAPIAccess r, + Member (Error SparError) r + ) => + Maybe UserId -> + Maybe PlainTextPassword6 -> + Maybe Code.Value -> + Maybe VerificationAction -> + Sem r () +ensureReAuthorised Nothing _ _ _ = throw $ SAML.CustomError SparMissingZUsr +ensureReAuthorised (Just uid) mpwd mcode maction = do + result <- BrigAPIAccess.reauthUser uid (ReAuthUser mpwd mcode maction) + case result of + Right () -> pure () + Left ReAuthFailed -> throw $ SAML.CustomError SparReAuthRequired + Left VerificationCodeRequired -> throw $ SAML.CustomError SparReAuthCodeAuthRequired + Left VerificationCodeAuthFailed -> throw $ SAML.CustomError SparReAuthCodeAuthFailed + Left RateLimitExceeded -> throw $ SAML.CustomError SparReAuthRateLimitExceeded + +-- | User is member of a given team and has a given permission there. +assertHasPermission :: + ( Member GalleyAPIAccess r, + Member (Error SparError) r, + IsPerm TeamMember perm, + Show perm + ) => + TeamId -> + perm -> + UserId -> + Sem r () +assertHasPermission tid perm uid = do + mbMember <- GalleyAPIAccess.getTeamMember uid tid + case mbMember of + Just member | hasPermission member perm -> pure () + _ -> throw $ SAML.CustomError (SparNoPermission (LText.pack $ show perm)) + +-- | Check that SSO is enabled for the given team. +assertSSOEnabled :: + ( Member GalleyAPIAccess r, + Member (Error SparError) r + ) => + TeamId -> + Sem r () +assertSSOEnabled tid = do + feat <- GalleyAPIAccess.getFeatureConfigForTeam @_ @SSOConfig tid + unless (feat.status == FeatureStatusEnabled) $ + throw $ + SAML.CustomError SparSSODisabled diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index f2095772ede..caf48e2e7bd 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -83,8 +83,6 @@ import Spar.Options import Spar.Scim.Auth import Spar.Scim.Group () import Spar.Scim.User -import Spar.Sem.BrigAccess (BrigAccess) -import Spar.Sem.GalleyAccess (GalleyAccess) import Spar.Sem.Reporter (Reporter) import Spar.Sem.SAMLUserStore (SAMLUserStore) import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) @@ -100,6 +98,8 @@ import qualified Web.Scim.Schema.Schema as Scim.Schema import qualified Web.Scim.Server as Scim import Wire.API.Routes.Public.Spar import Wire.API.User.Scim +import Wire.BrigAPIAccess (BrigAPIAccess) +import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.IdPConfigStore (IdPConfigStore) import Wire.ScimSubsystem import Wire.Sem.Logger (Logger) @@ -121,8 +121,8 @@ apiScim :: Member (Logger String) r, Member Now r, Member (Error SparError) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimSubsystem r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index c05a53defcb..a915a38bbd5 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -50,11 +50,8 @@ import qualified SAML2.WebSSO as SAML import Servant (NoContent (NoContent), ServerT, (:<|>) ((:<|>))) import Spar.App (throwSparSem) import qualified Spar.Error as E -import qualified Spar.Intra.BrigApp as Intra.Brig +import qualified Spar.Intra.RpcApp as Intra import Spar.Options -import Spar.Sem.BrigAccess (BrigAccess) -import qualified Spar.Sem.BrigAccess as BrigAccess -import Spar.Sem.GalleyAccess (GalleyAccess) import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import qualified Web.Scim.Class.Auth as Scim.Class.Auth @@ -64,6 +61,8 @@ import Wire.API.Routes.Named import Wire.API.Routes.Public.Spar (APIScimToken) import Wire.API.User as User import Wire.API.User.Scim as Api +import Wire.BrigAPIAccess +import Wire.GalleyAPIAccess import Wire.IdPConfigStore (IdPConfigStore) import qualified Wire.IdPConfigStore as IdPConfigStore import Wire.Sem.Now (Now) @@ -91,8 +90,8 @@ instance (Member ScimTokenStore r) => Scim.Class.Auth.AuthDB SparTag (Sem r) whe apiScimToken :: ( Member Random r, Member (Input Opts) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member Now r, Member IdPConfigStore r, @@ -108,17 +107,17 @@ apiScimToken = :<|> Named @"auth-tokens-list" listScimTokens updateScimTokenName :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r, - Member GalleyAccess r + Member GalleyAPIAccess r ) => UserId -> ScimTokenId -> ScimTokenName -> Sem r () updateScimTokenName lusr tokenId name = do - teamid <- Intra.Brig.authorizeScimTokenManagement (Just lusr) + teamid <- Intra.authorizeScimTokenManagement (Just lusr) ScimTokenStore.updateName teamid tokenId name.fromScimTokenName -- | > docs/reference/provisioning/scim-token.md {#RefScimTokenCreate} @@ -128,8 +127,8 @@ createScimTokenV7 :: forall r. ( Member Random r, Member (Input Opts) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member Now r, @@ -167,8 +166,8 @@ createScimToken :: forall r. ( Member Random r, Member (Input Opts) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member Now r, @@ -187,8 +186,8 @@ createScimToken zusr Api.CreateScimToken {..} = do guardScimTokenCreation :: forall r. ( Member (Input Opts) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => @@ -198,8 +197,8 @@ guardScimTokenCreation :: Maybe Code.Value -> Sem r TeamId guardScimTokenCreation zusr password verificationCode = do - teamid <- Intra.Brig.authorizeScimTokenManagement zusr - BrigAccess.ensureReAuthorised zusr password verificationCode (Just User.CreateScimToken) + teamid <- Intra.authorizeScimTokenManagement zusr + Intra.ensureReAuthorised zusr password verificationCode (Just User.CreateScimToken) tokenNumber <- length <$> ScimTokenStore.lookupByTeam teamid maxTokens <- inputs maxScimTokens unless (tokenNumber < maxTokens) $ @@ -240,8 +239,8 @@ createScimTokenUnchecked teamid mName desc mIdPId = do -- -- Delete a token belonging to user's team. deleteScimToken :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => @@ -250,13 +249,13 @@ deleteScimToken :: ScimTokenId -> Sem r NoContent deleteScimToken zusr tokenid = do - teamid <- Intra.Brig.authorizeScimTokenManagement zusr + teamid <- Intra.authorizeScimTokenManagement zusr ScimTokenStore.delete teamid tokenid pure NoContent listScimTokensV7 :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => @@ -276,8 +275,8 @@ listScimTokensV7 zusr = toV7 <$> listScimTokens zusr -- List all tokens belonging to user's team. Tokens themselves are not available, only -- metadata about them. listScimTokens :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => @@ -285,5 +284,5 @@ listScimTokens :: Maybe UserId -> Sem r ScimTokenList listScimTokens zusr = do - teamid <- Intra.Brig.authorizeScimTokenManagement zusr + teamid <- Intra.authorizeScimTokenManagement zusr ScimTokenList <$> ScimTokenStore.lookupByTeam teamid diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 1b8f7902628..118e00d2ed2 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -74,15 +74,11 @@ import Polysemy.Input import qualified SAML2.WebSSO as SAML import Spar.App (getUserByUrefUnsafe, getUserByUrefViaOldIssuerUnsafe, getUserIdByScimExternalId) import qualified Spar.App -import Spar.Intra.BrigApp as Intra -import qualified Spar.Intra.BrigApp as Brig +import Spar.Intra.RpcApp as Intra import Spar.Options import Spar.Scim.Auth () import Spar.Scim.Types import qualified Spar.Scim.Types as ST -import Spar.Sem.BrigAccess (BrigAccess, getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess -import Spar.Sem.GalleyAccess as GalleyAccess import Spar.Sem.SAMLUserStore (SAMLUserStore) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) @@ -112,6 +108,10 @@ import Wire.API.User.IdentityProvider (IdP) import qualified Wire.API.User.RichInfo as RI import Wire.API.User.Scim (ScimTokenInfo (..), ValidScimId (..)) import qualified Wire.API.User.Scim as ST +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess as BrigAPIAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import qualified Wire.GalleyAPIAccess as GalleyAPIAccess import Wire.IdPConfigStore (IdPConfigStore) import qualified Wire.IdPConfigStore as IdPConfigStore import Wire.Sem.Logger (Logger) @@ -130,8 +130,8 @@ instance Member Random r, Member (Input Opts) r, Member Now r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member IdPConfigStore r, @@ -208,7 +208,7 @@ validateScimUser :: forall r. ( Member (Logger (Msg -> Msg)) r, Member SAMLUserStore r, - Member BrigAccess r, + Member BrigAPIAccess r, Member (Input Opts) r, Member IdPConfigStore r ) => @@ -230,7 +230,7 @@ validateScimUser errloc tokinfo user = validateScimUserNoLogging :: forall r. ( Member SAMLUserStore r, - Member BrigAccess r, + Member BrigAPIAccess r, Member (Input Opts) r, Member IdPConfigStore r ) => @@ -289,7 +289,7 @@ validateHandle txt = case parseHandle txt of validateScimUser' :: forall r. ( Member (Error Scim.ScimError) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member SAMLUserStore r ) => -- | Error location (call site, for debugging) @@ -315,7 +315,7 @@ validateScimUser' errloc midp richInfoLimit user = do <> " (" <> errloc <> ")" - either err pure $ Brig.mkUserName (Scim.displayName user) (ST.validScimIdAuthInfo veid) + either err pure $ Intra.mkUserName (Scim.displayName user) (ST.validScimIdAuthInfo veid) richInfo <- validateRichInfo (Scim.extra user ^. ST.sueRichInfo) let active = Scim.active user lang <- maybe (throw $ badRequest "Could not parse language. Expected format is ISO 639-1.") pure $ mapM parseLanguage $ Scim.preferredLanguage user @@ -377,7 +377,7 @@ validateScimUser' errloc midp richInfoLimit user = do -- recover the 'SAML.UserRef' of the scim user before the update from the database. mkValidScimId :: forall r. - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r, Member (Error Scim.ScimError) r ) => @@ -508,8 +508,8 @@ createValidScimUser :: Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member (Logger String) r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member SAMLUserStore r, @@ -533,7 +533,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- If this is the case we can safely create the user again, AFTER THE -- HALF-CREATED ACCOUNT HAS BEEN GARBAGE-COLLECTED. -- Otherwise we return a conflict error. - lift (BrigAccess.getStatusMaybe buid) >>= \case + lift (BrigAPIAccess.getStatusMaybe buid) >>= \case Just Active -> throwError (externalIdTakenError ("user with status Active exists: " <> Text.pack (show (externalId, buid)))) Just Suspended -> throwError (externalIdTakenError ("user with status Suspended exists" <> Text.pack (show (externalId, buid)))) Just Ephemeral -> throwError (externalIdTakenError ("user with status Ephemeral exists" <> Text.pack (show (externalId, buid)))) @@ -560,14 +560,14 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- FUTUREWORK: outsource this and some other fragments from -- `createValidScimUser` into a function `createValidScimUserBrig` similar -- to `createValidScimUserSpar`? - void $ BrigAccess.createSAML uref buid stiTeam name ManagedByScim (Just handle) (Just richInfo) locale (fromMaybe defaultRole role) + void $ BrigAPIAccess.createSAML uref buid stiTeam name ManagedByScim (Just handle) (Just richInfo) locale (fromMaybe defaultRole role) doEmail email = do - void $ BrigAccess.createNoSAML externalId.validScimIdExternal email buid stiTeam name locale (fromMaybe defaultRole role) - BrigAccess.setHandle buid handle -- FUTUREWORK: possibly do the same one req as we do for saml? + void $ BrigAPIAccess.createNoSAML externalId.validScimIdExternal email buid stiTeam name locale (fromMaybe defaultRole role) + BrigAPIAccess.setHandle buid handle -- FUTUREWORK: possibly do the same one req as we do for saml? these doEmail doUref (\_ uref -> doUref uref) (validScimIdAuthInfo externalId) Logger.debug ("createValidScimUser: brig says " <> show buid) - BrigAccess.setRichInfo buid richInfo + BrigAPIAccess.setRichInfo buid richInfo -- {If we crash now, a POST retry will fail with 409 user already exists. -- Azure at some point will retry with GET /Users?filter=userName eq handle @@ -579,7 +579,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- to reload the Account from brig. storedUser <- do acc <- - lift (BrigAccess.getAccount Brig.WithPendingInvitations buid) + lift (BrigAPIAccess.getAccount Intra.WithPendingInvitations buid) >>= maybe (throwError $ Scim.serverError "Server error: user vanished") pure synthesizeStoredUser acc externalId lift $ Logger.debug ("createValidScimUser: spar says " <> show storedUser) @@ -594,10 +594,10 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- TODO: suspension via scim is brittle, and may leave active users behind: if we don't -- reach the following line due to a crash, the user will be active. lift $ do - old <- BrigAccess.getStatus buid + old <- BrigAPIAccess.getStatus buid let new = ST.scimActiveFlagToAccountStatus old (Scim.unScimBool <$> active') active' = Scim.active . Scim.value . Scim.thing $ storedUser - when (new /= old) $ BrigAccess.setStatus buid new + when (new /= old) $ BrigAPIAccess.setStatus buid new lift $ ScimExternalIdStore.insertStatus stiTeam externalId buid ScimUserCreated pure storedUser @@ -642,8 +642,8 @@ updateValidScimUser :: Member (Logger (Msg -> Msg)) r, Member (Logger String) r, Member Now r, - Member GalleyAccess r, - Member BrigAccess r, + Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member IdPConfigStore r, @@ -670,7 +670,7 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid nvsu = -- if the locale of the new valid SCIM user is not set, -- we set it to default value from brig - defLocale <- lift BrigAccess.getDefaultUserLocale + defLocale <- lift BrigAPIAccess.getDefaultUserLocale let newValidScimUser = nvsu {ST.locale = ST.locale nvsu <|> Just defLocale} -- assertions about new valid scim user that cannot be checked in 'validateScimUser' because @@ -689,33 +689,33 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid nvsu = updateVsuUref stiTeam uid (oldValidScimUser.externalId) (newValidScimUser.externalId) when (newValidScimUser.name /= oldValidScimUser.name) $ - BrigAccess.setName uid (newValidScimUser.name) + BrigAPIAccess.setName uid (newValidScimUser.name) when (oldValidScimUser.handle /= newValidScimUser.handle) $ - BrigAccess.setHandle uid (newValidScimUser.handle) + BrigAPIAccess.setHandle uid (newValidScimUser.handle) when (oldValidScimUser.richInfo /= newValidScimUser.richInfo) $ - BrigAccess.setRichInfo uid (newValidScimUser.richInfo) + BrigAPIAccess.setRichInfo uid (newValidScimUser.richInfo) when (oldValidScimUser.locale /= newValidScimUser.locale) $ do - BrigAccess.setLocale uid (newValidScimUser.locale) + BrigAPIAccess.setLocale uid (newValidScimUser.locale) forM_ (newValidScimUser.role) $ \newRole -> do when (oldValidScimUser.role /= Just newRole) $ do - GalleyAccess.updateTeamMember uid stiTeam newRole + GalleyAPIAccess.updateTeamMember uid stiTeam newRole - BrigAccess.getStatusMaybe uid >>= \case + BrigAPIAccess.getStatusMaybe uid >>= \case Nothing -> pure () Just old -> do let new = ST.scimActiveFlagToAccountStatus old (Just $ newValidScimUser.active) - when (new /= old) $ BrigAccess.setStatus uid new + when (new /= old) $ BrigAPIAccess.setStatus uid new ScimUserTimesStore.write newScimStoredUser Scim.getUser tokinfo uid updateVsuUref :: - ( Member GalleyAccess r, - Member BrigAccess r, + ( Member GalleyAPIAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -735,7 +735,7 @@ updateVsuUref team uid old new = do ScimExternalIdStore.insert team new.validScimIdExternal uid for_ (justThere new.validScimIdAuthInfo) (`SAMLUserStore.insert` uid) - BrigAccess.setSSOId uid $ veidToUserSSOId new + BrigAPIAccess.setSSOId uid $ veidToUserSSOId new toScimStoredUser :: (HasCallStack) => @@ -793,7 +793,7 @@ updScimStoredUser' now usr (Scim.WithMeta meta (Scim.WithId scimuid _)) = deleteScimUser :: ( Member (Logger (Msg -> Msg)) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member SAMLUserStore r, @@ -814,7 +814,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = -- ("tombstones") would not have the needed values (`userIdentity = -- Nothing`) to delete a user in spar. I.e. `SAML.UserRef` and `Email` -- cannot be figured out when a `User` has status `Deleted`. - mbAccount <- lift $ BrigAccess.getAccount WithPendingInvitations uid + mbAccount <- lift $ BrigAPIAccess.getAccount WithPendingInvitations uid case mbAccount of Nothing -> -- Ensure there's no left-over of this user in brig. This is safe @@ -823,7 +823,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = -- be hard as the check relies on the data of `mbBrigUser`): The worst -- thing that could happen is that foreign users cleanup partially -- deleted users. - void . lift $ BrigAccess.deleteUser uid + void . lift $ BrigAPIAccess.deleteUser uid Just brigUser -> do if userTeam brigUser == Just stiTeam then do @@ -834,7 +834,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = -- (via the TM app) is blocked, though, so there is no legal way to enter -- that situation. deleteUserInSpar brigUser - void . lift $ BrigAccess.deleteUser uid + void . lift $ BrigAPIAccess.deleteUser uid else do -- if we find the user in another team, we pretend it wasn't even there, to -- avoid leaking data to attackers (very unlikely, but hey). @@ -852,14 +852,14 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = mIdpConfig <- mapM (lift . IdPConfigStore.getConfig) stiIdP -- delete user with idp associated *before* this update. - case Brig.oldVeidFromBrigUser account of + case Intra.oldVeidFromBrigUser account of Nothing -> pure () Just veid -> lift $ do for_ (justThere veid.validScimIdAuthInfo) (SAMLUserStore.delete uid) ScimExternalIdStore.delete stiTeam veid.validScimIdExternal -- delete user with idp associated to current scim token. - case Brig.newVeidFromBrigUser account ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of + case Intra.newVeidFromBrigUser account ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of Left _ -> pure () Right veid -> lift $ do for_ (justThere veid.validScimIdAuthInfo) (SAMLUserStore.delete uid) @@ -894,7 +894,7 @@ calculateVersion uid usr = Scim.Weak (Text.pack (show h)) -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. assertExternalIdUnused :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -911,7 +911,7 @@ assertExternalIdUnused = -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. assertExternalIdNotUsedElsewhere :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -927,7 +927,7 @@ assertExternalIdNotUsedElsewhere tid veid wireUserId = veid assertExternalIdInAllowedValues :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -945,18 +945,18 @@ assertExternalIdInAllowedValues allowedValues errmsg tid veid = do unless isGood $ throwError Scim.conflict {Scim.detail = Just errmsg} -assertHandleUnused :: (Member BrigAccess r) => Handle -> Scim.ScimHandler (Sem r) () +assertHandleUnused :: (Member BrigAPIAccess r) => Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused = assertHandleUnused' "userName is already taken" -assertHandleUnused' :: (Member BrigAccess r) => Text -> Handle -> Scim.ScimHandler (Sem r) () +assertHandleUnused' :: (Member BrigAPIAccess r) => Text -> Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused' msg hndl = - lift (BrigAccess.checkHandleAvailable hndl) >>= \case + lift (BrigAPIAccess.checkHandleAvailable hndl) >>= \case True -> pure () False -> throwError Scim.conflict {Scim.detail = Just msg} -assertHandleNotUsedElsewhere :: (Member BrigAccess r) => UserId -> Handle -> Scim.ScimHandler (Sem r) () +assertHandleNotUsedElsewhere :: (Member BrigAPIAccess r) => UserId -> Handle -> Scim.ScimHandler (Sem r) () assertHandleNotUsedElsewhere uid hndl = do - musr <- lift $ getAccount Brig.WithPendingInvitations uid + musr <- lift $ BrigAPIAccess.getAccount Intra.WithPendingInvitations uid unless ((userHandle =<< musr) == Just hndl) $ assertHandleUnused' "userName already in use by another wire user" hndl @@ -968,8 +968,8 @@ synthesizeStoredUser :: ( Member (Input Opts) r, Member Now r, Member (Logger (Msg -> Msg)) r, - Member BrigAccess r, - Member GalleyAccess r, + Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member ScimUserTimesStore r ) => User -> @@ -991,7 +991,7 @@ synthesizeStoredUser acc veid = let readState :: Sem r (RI.RichInfo, Maybe (UTCTimeMillis, UTCTimeMillis), URIBS.URI, Role) readState = (,,,) - <$> BrigAccess.getRichInfo uid + <$> BrigAPIAccess.getRichInfo uid <*> ScimUserTimesStore.read uid <*> inputs scimBaseUri <*> getRole @@ -1001,16 +1001,16 @@ synthesizeStoredUser acc veid = when (isNothing oldAccessTimes) $ ScimUserTimesStore.write storedUser when (oldManagedBy /= ManagedByScim) $ - BrigAccess.setManagedBy uid ManagedByScim + BrigAPIAccess.setManagedBy uid ManagedByScim let newRichInfo = view ST.sueRichInfo . Scim.extra . Scim.value . Scim.thing $ storedUser when (oldRichInfo /= newRichInfo) $ - BrigAccess.setRichInfo uid newRichInfo + BrigAPIAccess.setRichInfo uid newRichInfo (richInfo, accessTimes, baseuri, role) <- lift readState now <- toUTCTimeMillis <$> lift Now.get let (createdAt, lastUpdatedAt) = fromMaybe (now, now) accessTimes - handle <- lift $ Brig.giveDefaultHandle acc + handle <- lift $ Intra.giveDefaultHandle acc let emails = maybeToList $ @@ -1036,7 +1036,7 @@ synthesizeStoredUser acc veid = getRole :: Sem r Role getRole = do let tmRoleOrDefault m = fromMaybe defaultRole $ m >>= \member -> member ^. Member.permissions . to Member.permissionsRole - maybe (pure defaultRole) (\tid -> tmRoleOrDefault <$> GalleyAccess.getTeamMember tid (userId acc)) (userTeam acc) + maybe (pure defaultRole) (fmap tmRoleOrDefault . GalleyAPIAccess.getTeamMember (userId acc)) (userTeam acc) synthesizeStoredUser' :: (MonadError Scim.ScimError m) => @@ -1094,8 +1094,8 @@ synthesizeScimUser info = -- TODO: now write a test, either in /integration or in spar, whichever is easier. (spar) getUserById :: forall r. - ( Member BrigAccess r, - Member GalleyAccess r, + ( Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member Now r, @@ -1108,9 +1108,9 @@ getUserById :: UserId -> MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) getUserById midp stiTeam uid = do - brigUser <- MaybeT . lift $ BrigAccess.getAccount Brig.WithPendingInvitations uid - let mbOldVeid = Brig.oldVeidFromBrigUser brigUser - mbNewVeid = Brig.newVeidFromBrigUser brigUser ((^. SAML.idpMetadata . SAML.edIssuer) <$> midp) + brigUser <- MaybeT . lift $ BrigAPIAccess.getAccount Intra.WithPendingInvitations uid + let mbOldVeid = Intra.oldVeidFromBrigUser brigUser + mbNewVeid = Intra.newVeidFromBrigUser brigUser ((^. SAML.idpMetadata . SAML.edIssuer) <$> midp) case mbNewVeid of Right veid | userTeam brigUser == Just stiTeam -> lift $ do storedUser :: Scim.StoredUser ST.SparTag <- synthesizeStoredUser brigUser veid @@ -1126,10 +1126,10 @@ getUserById midp stiTeam uid = do handleVeidChange brigUser mbOldVeid newVeid = do -- set sso_id when (mbOldVeid /= Just newVeid) do - lift $ BrigAccess.setSSOId uid (veidToUserSSOId newVeid) + lift $ BrigAPIAccess.setSSOId uid (veidToUserSSOId newVeid) -- set managed_by when (userManagedBy brigUser /= ManagedByScim) do - lift $ BrigAccess.setManagedBy uid ManagedByScim + lift $ BrigAPIAccess.setManagedBy uid ManagedByScim -- remove dangling entry from spar.user_v2 table (cassandra) case mbOldVeid of Just oldVeid | ST.veidUref newVeid /= ST.veidUref oldVeid -> do @@ -1138,8 +1138,8 @@ getUserById midp stiTeam uid = do scimFindUserByHandle :: forall r. - ( Member BrigAccess r, - Member GalleyAccess r, + ( Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member Now r, @@ -1153,7 +1153,7 @@ scimFindUserByHandle :: MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) scimFindUserByHandle mIdpConfig stiTeam hndl = do handle <- MaybeT . pure . parseHandle . Text.toLower $ hndl - brigUser <- MaybeT . lift . BrigAccess.getByHandle $ handle + brigUser <- MaybeT . lift . BrigAPIAccess.getAccountByHandle $ handle getUserById mIdpConfig stiTeam . userId $ brigUser -- | Construct a 'ValidScimId'. If it is an 'Email', find the non-SAML SCIM user in spar; if @@ -1164,8 +1164,8 @@ scimFindUserByHandle mIdpConfig stiTeam hndl = do -- successful authentication with their SAML credentials. scimFindUserByExternalId :: forall r. - ( Member BrigAccess r, - Member GalleyAccess r, + ( Member BrigAPIAccess r, + Member GalleyAPIAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member Now r, @@ -1186,11 +1186,11 @@ scimFindUserByExternalId mIdpConfig stiTeam eid = do -- there are a few ways to find a user. this should all be redundant, especially the where -- we lookup a user from brig by email, throw it away and only keep the uid, and then use -- the uid to lookup the account again. but cassandra, and also reasons. - mViaEmail :: Maybe UserId <- join <$> (for (justHere veid.validScimIdAuthInfo) ((userId <$$>) . BrigAccess.getByEmail)) + mViaEmail :: Maybe UserId <- join <$> (for (justHere veid.validScimIdAuthInfo) ((userId <$$>) . BrigAPIAccess.getByEmail)) mViaUref :: Maybe UserId <- join <$> (for (justThere veid.validScimIdAuthInfo) SAMLUserStore.get) pure $ mViaEmail <|> mViaUref Just uid -> pure uid - acc <- MaybeT . lift . BrigAccess.getAccount Brig.WithPendingInvitations $ uid + acc <- MaybeT . lift . BrigAPIAccess.getAccount Intra.WithPendingInvitations $ uid getUserById mIdpConfig stiTeam (userId acc) logFilter :: Filter -> (Msg -> Msg) diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs deleted file mode 100644 index b8765965f32..00000000000 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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 Spar.Sem.BrigAccess - ( BrigAccess (..), - createSAML, - createNoSAML, - updateEmail, - getAccount, - getByHandle, - getByEmail, - setName, - setHandle, - setManagedBy, - setSSOId, - setRichInfo, - setLocale, - getRichInfo, - checkHandleAvailable, - deleteUser, - ensureReAuthorised, - ssoLogin, - getStatus, - getStatusMaybe, - setStatus, - getDefaultUserLocale, - checkAdminGetTeamId, - sendSAMLIdPChangedEmail, - ) -where - -import Data.Code as Code -import Data.Handle (Handle) -import Data.HavePendingInvitations -import Data.Id (TeamId, UserId) -import Data.Misc (PlainTextPassword6) -import Imports -import Polysemy -import qualified SAML2.WebSSO as SAML -import Web.Cookie -import Wire.API.Locale -import Wire.API.Routes.Internal.Brig (IdpChangedNotification) -import Wire.API.Team.Role -import Wire.API.User -import Wire.API.User.Auth -import Wire.API.User.RichInfo as RichInfo - -data BrigAccess m a where - CreateSAML :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> Maybe Locale -> Role -> BrigAccess m UserId - CreateNoSAML :: Text -> EmailAddress -> UserId -> TeamId -> Name -> Maybe Locale -> Role -> BrigAccess m UserId - UpdateEmail :: UserId -> EmailAddress -> EmailActivation -> BrigAccess m () - GetAccount :: HavePendingInvitations -> UserId -> BrigAccess m (Maybe User) - GetByHandle :: Handle -> BrigAccess m (Maybe User) - GetByEmail :: EmailAddress -> BrigAccess m (Maybe User) - SetName :: UserId -> Name -> BrigAccess m () - SetHandle :: UserId -> Handle {- not 'HandleUpdate'! -} -> BrigAccess m () - SetManagedBy :: UserId -> ManagedBy -> BrigAccess m () - SetSSOId :: UserId -> UserSSOId -> BrigAccess m () - SetRichInfo :: UserId -> RichInfo -> BrigAccess m () - SetLocale :: UserId -> Maybe Locale -> BrigAccess m () - GetRichInfo :: UserId -> BrigAccess m RichInfo - CheckHandleAvailable :: Handle -> BrigAccess m Bool - DeleteUser :: UserId -> BrigAccess m DeleteUserResult - EnsureReAuthorised :: Maybe UserId -> Maybe PlainTextPassword6 -> Maybe Code.Value -> Maybe VerificationAction -> BrigAccess m () - SsoLogin :: UserId -> Maybe CookieLabel -> BrigAccess m SetCookie - GetStatus :: UserId -> BrigAccess m AccountStatus - GetStatusMaybe :: UserId -> BrigAccess m (Maybe AccountStatus) - SetStatus :: UserId -> AccountStatus -> BrigAccess m () - GetDefaultUserLocale :: BrigAccess m Locale - CheckAdminGetTeamId :: UserId -> BrigAccess m TeamId - SendSAMLIdPChangedEmail :: IdpChangedNotification -> BrigAccess m () - -makeSem ''BrigAccess diff --git a/services/spar/src/Spar/Sem/BrigAccess/Http.hs b/services/spar/src/Spar/Sem/BrigAccess/Http.hs deleted file mode 100644 index 08880ae3014..00000000000 --- a/services/spar/src/Spar/Sem/BrigAccess/Http.hs +++ /dev/null @@ -1,68 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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 Spar.Sem.BrigAccess.Http - ( brigAccessToHttp, - ) -where - -import Bilge -import Imports -import Polysemy -import Polysemy.Error (Error) -import Spar.Error (SparError) -import qualified Spar.Intra.Brig as Intra -import Spar.Sem.BrigAccess -import Spar.Sem.Utils (RunHttpEnv (..), viaRunHttp) -import qualified System.Logger as TinyLog -import Wire.Sem.Logger (Logger) - -brigAccessToHttp :: - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Error SparError) r, - Member (Embed IO) r - ) => - Bilge.Manager -> - Bilge.Request -> - Sem (BrigAccess ': r) a -> - Sem r a -brigAccessToHttp mgr req = - interpret $ - viaRunHttp (RunHttpEnv mgr req) . \case - CreateSAML u itlu itlt n m h ri ml r -> Intra.createBrigUserSAML u itlu itlt n m h ri ml r - CreateNoSAML eid e uid itlt n ml r -> Intra.createBrigUserNoSAML eid e uid itlt n ml r - UpdateEmail itlu e a -> Intra.updateEmail itlu e a - GetAccount h itlu -> Intra.getBrigUserAccount h itlu - GetByHandle h -> Intra.getBrigUserByHandle h - GetByEmail e -> Intra.getBrigUserByEmail e - SetName itlu n -> Intra.setBrigUserName itlu n - SetHandle itlu h -> Intra.setBrigUserHandle itlu h - SetManagedBy itlu m -> Intra.setBrigUserManagedBy itlu m - SetSSOId itlu v -> Intra.setBrigUserSSOId itlu v - SetRichInfo itlu r -> Intra.setBrigUserRichInfo itlu r - SetLocale itlu l -> Intra.setBrigUserLocale itlu l - GetRichInfo itlu -> Intra.getBrigUserRichInfo itlu - CheckHandleAvailable h -> Intra.checkHandleAvailable h - DeleteUser itlu -> Intra.deleteBrigUserInternal itlu - EnsureReAuthorised mitlu mp mc ma -> Intra.ensureReAuthorised mitlu mp mc ma - SsoLogin itlu mlabel -> Intra.ssoLogin itlu mlabel - GetStatus itlu -> Intra.getStatus itlu - GetStatusMaybe itlu -> Intra.getStatusMaybe itlu - SetStatus itlu a -> Intra.setStatus itlu a - GetDefaultUserLocale -> Intra.getDefaultUserLocale - CheckAdminGetTeamId itlu -> Intra.checkAdminGetTeamId itlu - SendSAMLIdPChangedEmail notif -> Intra.sendSAMLIdPChangedEmail notif diff --git a/services/spar/src/Spar/Sem/GalleyAccess.hs b/services/spar/src/Spar/Sem/GalleyAccess.hs deleted file mode 100644 index 545395af4cd..00000000000 --- a/services/spar/src/Spar/Sem/GalleyAccess.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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 Spar.Sem.GalleyAccess - ( GalleyAccess (..), - getTeamMembers, - getTeamMember, - assertHasPermission, - assertSSOEnabled, - isEmailValidationEnabledTeam, - updateTeamMember, - ) -where - -import Data.Id (TeamId, UserId) -import Imports -import Polysemy -import Wire.API.Team.Member -import Wire.API.Team.Role - -data GalleyAccess m a where - GetTeamMembers :: TeamId -> GalleyAccess m [TeamMember] - GetTeamMember :: TeamId -> UserId -> GalleyAccess m (Maybe TeamMember) - AssertHasPermission :: (Show perm, IsPerm TeamMember perm) => TeamId -> perm -> UserId -> GalleyAccess m () - AssertSSOEnabled :: TeamId -> GalleyAccess m () - IsEmailValidationEnabledTeam :: TeamId -> GalleyAccess m Bool - UpdateTeamMember :: UserId -> TeamId -> Role -> GalleyAccess m () - -makeSem ''GalleyAccess diff --git a/services/spar/src/Spar/Sem/GalleyAccess/Http.hs b/services/spar/src/Spar/Sem/GalleyAccess/Http.hs deleted file mode 100644 index 793bac9c276..00000000000 --- a/services/spar/src/Spar/Sem/GalleyAccess/Http.hs +++ /dev/null @@ -1,53 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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 Spar.Sem.GalleyAccess.Http - ( RunHttpEnv (..), - viaRunHttp, - galleyAccessToHttp, - ) -where - -import Bilge -import Imports hiding (log) -import Polysemy -import Polysemy.Error -import Spar.Error (SparError) -import qualified Spar.Intra.Galley as Intra -import Spar.Sem.GalleyAccess -import Spar.Sem.Utils -import qualified System.Logger as TinyLog -import Wire.Sem.Logger (Logger) - -galleyAccessToHttp :: - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Error SparError) r, - Member (Embed IO) r - ) => - Bilge.Manager -> - Bilge.Request -> - Sem (GalleyAccess ': r) a -> - Sem r a -galleyAccessToHttp mgr req = - interpret $ - viaRunHttp (RunHttpEnv mgr req) . \case - GetTeamMembers itlt -> Intra.getTeamMembers itlt - GetTeamMember tid uid -> Intra.getTeamMember tid uid - AssertHasPermission itlt perm itlu -> Intra.assertHasPermission itlt perm itlu - AssertSSOEnabled itlt -> Intra.assertSSOEnabled itlt - IsEmailValidationEnabledTeam itlt -> Intra.isEmailValidationEnabledTeam itlt - UpdateTeamMember uid tid role -> Intra.updateTeamMember uid tid role diff --git a/services/spar/src/Spar/Sem/Utils.hs b/services/spar/src/Spar/Sem/Utils.hs index 0cac0ec9db4..11789114fa2 100644 --- a/services/spar/src/Spar/Sem/Utils.hs +++ b/services/spar/src/Spar/Sem/Utils.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -18,33 +16,24 @@ -- with this program. If not, see . module Spar.Sem.Utils - ( viaRunHttp, - RunHttpEnv (..), - interpretClientToIO, + ( interpretClientToIO, ttlErrorToSparError, + rpcExceptionToSparError, idpDbErrorToSparError, ) where -import Bilge import Cassandra as Cas import qualified Control.Monad.Catch as Catch -import Control.Monad.Except (ExceptT (..), MonadError, runExceptT) import qualified Data.Text.Lazy as LText -import Imports hiding (log) +import Imports import Polysemy import Polysemy.Error import Polysemy.Final import qualified SAML2.WebSSO as SAML import Spar.Error -import Spar.Intra.Brig (MonadSparToBrig (..)) -import Spar.Intra.Galley (MonadSparToGalley) -import qualified Spar.Intra.Galley as Intra -import qualified System.Logger as TinyLog -import qualified System.Logger.Class as TinyLog import Wire.API.User.Saml -import Wire.Sem.Logger (Logger) -import qualified Wire.Sem.Logger as Logger +import Wire.RpcException -- | Run an embedded Cassandra 'Client' in @Final IO@. interpretClientToIO :: @@ -70,62 +59,8 @@ interpretClientToIO ctx = interpret $ \case ttlErrorToSparError :: (Member (Error SparError) r) => Sem (Error TTLError ': r) a -> Sem r a ttlErrorToSparError = mapError (SAML.CustomError . SparCassandraTTLError) +rpcExceptionToSparError :: (Member (Error SparError) r) => Sem (Error RpcException ': r) a -> Sem r a +rpcExceptionToSparError = mapError (SAML.CustomError . SparRpcException) + idpDbErrorToSparError :: (Member (Error SparError) r) => Sem (Error IdpDbError ': r) a -> Sem r a idpDbErrorToSparError = mapError (SAML.CustomError . IdpDbError) - -data RunHttpEnv r = RunHttpEnv - { rheManager :: Bilge.Manager, - rheRequest :: Bilge.Request - } - -newtype RunHttp r a = RunHttp - { unRunHttp :: ReaderT (RunHttpEnv r) (ExceptT SparError (HttpT (Sem r))) a - } - deriving newtype (Functor, Applicative, Monad, MonadError SparError, MonadReader (RunHttpEnv r)) - -instance (Member (Embed IO) r) => MonadIO (RunHttp r) where - liftIO = semToRunHttp . embed - -instance (Member (Embed IO) r) => MonadHttp (RunHttp r) where - handleRequestWithCont r fribia = - RunHttp $ - lift $ - lift $ - handleRequestWithCont r fribia - -semToRunHttp :: Sem r a -> RunHttp r a -semToRunHttp = RunHttp . lift . lift . lift - -viaRunHttp :: - (Member (Error SparError) r) => - RunHttpEnv r -> - RunHttp r a -> - Sem r a -viaRunHttp env m = do - ma <- runHttpT (rheManager env) $ runExceptT $ flip runReaderT env $ unRunHttp m - case ma of - Left err -> throw err - Right a -> pure a - -instance (Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r) => TinyLog.MonadLogger (RunHttp r) where - log lvl msg = semToRunHttp $ Logger.log lvl msg - -instance - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Embed IO) r - ) => - MonadSparToGalley (RunHttp r) - where - call modreq = do - req <- asks rheRequest - httpLbs req modreq - -instance - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Embed IO) r - ) => - MonadSparToBrig (RunHttp r) - where - call modreq = do - req <- asks rheRequest - httpLbs req modreq diff --git a/services/spar/test-integration/Main.hs b/services/spar/test-integration/Main.hs index f1a42c99847..b2c219c6147 100644 --- a/services/spar/test-integration/Main.hs +++ b/services/spar/test-integration/Main.hs @@ -47,7 +47,6 @@ import qualified Test.MetricsSpec import qualified Test.Spar.APISpec import qualified Test.Spar.AppSpec import qualified Test.Spar.DataSpec -import qualified Test.Spar.Intra.BrigSpec import qualified Test.Spar.Scim.AuthSpec import qualified Test.Spar.Scim.UserSpec import Util @@ -107,7 +106,6 @@ mkspecSaml = do describe "Spar.API" Test.Spar.APISpec.spec describe "Spar.App" Test.Spar.AppSpec.spec describe "Spar.Data" Test.Spar.DataSpec.spec - describe "Spar.Intra.Brig" Test.Spar.Intra.BrigSpec.spec mkspecScim :: SpecWith TestEnv mkspecScim = do diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index ec2fff5242f..315d798378c 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -25,6 +25,7 @@ import Bilge.Assert import Cassandra as Cas hiding (Client, Value) import Control.Lens hiding ((.=)) import Control.Monad.Catch (MonadThrow) +import Control.Monad.Error.Class import Control.Monad.Random.Class (getRandomR) import Data.Aeson as Aeson import Data.Aeson.Lens @@ -37,8 +38,9 @@ import Data.Misc import Data.Proxy import Data.String.Conversions import qualified Data.Text as ST -import qualified Data.Text as T import Data.Text.Ascii (decodeBase64, validateBase64) +import qualified Data.Text.Lazy as LT +import Data.Typeable (typeRep) import qualified Data.UUID as UUID hiding (fromByteString, null) import qualified Data.UUID.V4 as UUID (nextRandom) import qualified Data.Vector as Vec @@ -70,10 +72,10 @@ import SAML2.WebSSO.API.Example (SimpleSP) import SAML2.WebSSO.Test.Lenses import SAML2.WebSSO.Test.MockResponse import SAML2.WebSSO.Test.Util -import qualified Spar.Intra.BrigApp as Intra +import Spar.Error +import qualified Spar.Intra.RpcApp as Intra import Spar.Options import qualified Spar.Sem.AReqIDStore as AReqIDStore -import qualified Spar.Sem.BrigAccess as BrigAccess import Text.XML.DSig (SignPrivCreds, mkSignCredsWithCert) import qualified URI.ByteString as URI import URI.ByteString.QQ (uri) @@ -95,6 +97,7 @@ import Wire.API.User.Client import Wire.API.User.Client.Prekey import Wire.API.User.IdentityProvider import Wire.API.User.Scim hiding (handle) +import qualified Wire.BrigAPIAccess as BrigAPIAccess import qualified Wire.IdPConfigStore as IdPEffect spec :: SpecWith TestEnv @@ -419,7 +422,7 @@ specFinalizeLogin = do subj <- createEmailSubject randEmail mbId1 <- loginWithSubject subj - subjUpper <- createEmailSubject (T.toUpper randEmail) + subjUpper <- createEmailSubject (ST.toUpper randEmail) mbId2 <- loginWithSubject subjUpper liftIO $ do @@ -1267,7 +1270,7 @@ specDeleteCornerCases = describe "delete corner cases" $ do brig <- view teBrig resp <- call . delete $ brig . paths ["i", "users", toByteString' uid] liftIO $ responseStatus resp `shouldBe` status202 - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Deleted) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Deleted) specScimAndSAML :: SpecWith TestEnv specScimAndSAML = do @@ -1431,8 +1434,20 @@ specAux = do . header "Z-User" (toByteString' $ if tryowner then owner else newmember) . expect2xx ) - parsedResp <- either (error . show) (pure . selfUser) (Intra.parseResponse @SelfProfile "brig" rawResp) + parsedResp <- either (error . show) (pure . selfUser) (parseResponse @SelfProfile "brig" rawResp) liftIO $ userTeam parsedResp `shouldSatisfy` isJust + + parseResponse :: forall a m. (FromJSON a, MonadError SparError m, Typeable a) => LText -> ResponseLBS -> m a + parseResponse serviceName resp = do + let typeinfo :: LText + typeinfo = LT.pack $ show (typeRep ([] @a)) <> ": " + + err :: forall a'. LText -> m a' + err = throwSpar . SparCouldNotParseRfcResponse serviceName . (typeinfo <>) + + bdy <- maybe (err "no body") pure $ responseBody resp + either (err . LT.pack) pure $ eitherDecode' bdy + permses :: [Permissions] permses = [ fullPermissions, diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index 7d809b979f8..4251a61c859 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -29,7 +29,7 @@ import Imports import SAML2.WebSSO as SAML import Spar.App as App import Spar.Error (IdpDbError (IdpNotFound), SparCustomError (IdpDbError)) -import Spar.Intra.BrigApp (veidFromUserSSOId) +import Spar.Intra.RpcApp (veidFromUserSSOId) import Spar.Options import qualified Spar.Sem.AReqIDStore as AReqIDStore import qualified Spar.Sem.AssIDStore as AssIDStore diff --git a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs b/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs deleted file mode 100644 index c97ad084a90..00000000000 --- a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs +++ /dev/null @@ -1,65 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 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 Test.Spar.Intra.BrigSpec - ( spec, - ) -where - -import Control.Lens ((^.)) -import Data.Id (Id (Id), UserId) -import qualified Data.UUID as UUID -import Imports hiding (head) -import qualified Spar.Intra.BrigApp as Intra -import Spar.Sem.BrigAccess (getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess -import Test.QuickCheck -import Util -import qualified Web.Scim.Schema.User as Scim.User -import Wire.API.User (DeleteUserResult (..), fromEmail) - -spec :: SpecWith TestEnv -spec = do - describe "user deletion between brig and spar" $ do - it "if a user gets deleted on brig, it will be deleted on spar as well." $ do - pending - it "if a user gets deleted on spar, it will be deleted on brig as well." $ do - pendingWith "or deactivated? we should decide what we want here." - - describe "deleteBrigUserInternal" $ do - it "does not throw for non-existing users" $ do - uid :: UserId <- liftIO $ generate arbitrary - r <- runSpar $ BrigAccess.deleteUser uid - liftIO $ r `shouldBe` NoUser - - describe "getAccount" $ do - it "return Nothing if n/a" $ do - musr <- runSpar $ getAccount Intra.WithPendingInvitations (Id . fromJust $ UUID.fromText "29546d9e-ed5b-11ea-8228-c324b1ea1030") - liftIO $ musr `shouldSatisfy` isNothing - - it "return Just if /a" $ do - let setup = do - env <- ask - email <- randomEmail - scimUser <- randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email} - (_, tid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) - tok <- registerScimToken tid Nothing - scimUserId <$> createUser tok scimUser - - uid <- setup - musr <- runSpar $ getAccount Intra.WithPendingInvitations uid - liftIO $ musr `shouldSatisfy` isJust diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index fa651962ee1..97b7c036430 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -63,12 +63,11 @@ import qualified SAML2.WebSSO as SAML import qualified SAML2.WebSSO.Test.MockResponse as SAML import SAML2.WebSSO.Test.Util.TestSP (makeSampleIdPMetadata) import qualified SAML2.WebSSO.Test.Util.Types as SAML -import qualified Spar.Intra.BrigApp as Intra +import qualified Spar.Intra.RpcApp as Intra import Spar.Options import Spar.Scim import Spar.Scim.Types (normalizeLikeStored) import qualified Spar.Scim.User as SU -import qualified Spar.Sem.BrigAccess as BrigAccess import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import qualified Spar.Sem.ScimUserTimesStore as ScimUserTimesStore @@ -96,6 +95,7 @@ import qualified Wire.API.User.IdentityProvider as User import Wire.API.User.RichInfo import qualified Wire.API.User.Scim as Spar.Types import qualified Wire.API.User.Search as Search +import qualified Wire.BrigAPIAccess as BrigAPIAccess -- | Tests for @\/scim\/v2\/Users@. spec :: SpecWith TestEnv @@ -150,7 +150,7 @@ specImportToScimFromSAML = pure (uref, uid) let handle = fromRight undefined . parseHandleEither $ Scim.User.userName usr - runSpar (BrigAccess.setHandle uid handle) + runSpar (BrigAPIAccess.setHandle uid handle) assertSparCassandraUref (uref, Just uid) assertSparCassandraScim ((teamid, email), Nothing) @@ -219,7 +219,7 @@ specImportToScimFromSAML = -- the "get" has already changed the ssoid in brig: no more idp assertSparCassandraUref (uref, Nothing) - runSpar (BrigAccess.getAccount NoPendingInvitations uid) >>= \(Just acc) -> liftIO $ do + runSpar (BrigAPIAccess.getAccount NoPendingInvitations uid) >>= \(Just acc) -> liftIO $ do userIdentity acc `shouldBe` let emailText :: Text = decodeUtf8 $ toStrict $ toByteString email in Just (SSOIdentity (UserScimExternalId emailText) (Just email)) @@ -446,7 +446,7 @@ assertBrigCassandra :: ManagedBy -> TestSpar () assertBrigCassandra uid uref usr (valemail, emailValidated) managedBy = do - runSpar (BrigAccess.getAccount NoPendingInvitations uid) >>= \(Just acc) -> liftIO $ do + runSpar (BrigAPIAccess.getAccount NoPendingInvitations uid) >>= \(Just acc) -> liftIO $ do let handle = fromRight errmsg . parseHandleEither $ Scim.User.userName usr where errmsg = error . show . Scim.User.userName $ usr @@ -481,9 +481,9 @@ specSuspend = do -- NOTE: once SCIM is enabled, SSO Auto-provisioning is disabled tok <- registerScimToken teamid (Just (idp ^. SAML.idpId)) handle <- nextHandle - runSpar $ BrigAccess.setHandle member handle + runSpar $ BrigAPIAccess.setHandle member handle unless isActive $ do - runSpar $ BrigAccess.setStatus member Suspended + runSpar $ BrigAPIAccess.setStatus member Suspended [user] <- listUsers tok (Just (filterBy "userName" (fromHandle handle))) lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ user) `shouldBe` Just isActive it "pre-existing suspended users are inactive" $ do @@ -502,19 +502,19 @@ specSuspend = do -- Once we get rid of the `scim` table and make scim serve brig records directly, this is -- not an issue anymore. lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUserBlah) `shouldBe` Just True - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user False lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just False - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Suspended) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Suspended) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) it "PUT will change state from active to inactive and back" $ do void . activeInactiveAndBack $ \tok uid user active -> @@ -553,10 +553,10 @@ specSuspend = do (tok, _) <- registerIdPAndScimToken scimStoredUserBlah <- createUser tok user let uid = Scim.id . Scim.thing $ scimStoredUserBlah - runSpar $ BrigAccess.setStatus uid Suspended - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Suspended) + runSpar $ BrigAPIAccess.setStatus uid Suspended + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Suspended) void $ patchUser tok uid $ PatchOp.PatchOp [deleteAttrib "active"] - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) ---------------------------------------------------------------------------- -- User creation @@ -743,10 +743,10 @@ testCreateUserNoIdP = do -- get account from brig, status should be PendingInvitation do - aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (pure ()) (error "pending user in brig is visible, even though it should not be") brigUser <- - aFewTimes (runSpar $ BrigAccess.getAccount Intra.WithPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.WithPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser liftIO $ brigUser.userStatus `shouldBe` PendingInvitation @@ -790,7 +790,7 @@ testCreateUserNoIdP = do -- user should now be active do brigUser <- - aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure liftIO $ brigUser.userStatus `shouldBe` Active liftIO $ userManagedBy brigUser `shouldBe` ManagedByScim @@ -873,7 +873,7 @@ testCreateUserWithSamlIdP = do . expect2xx ) brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser - accStatus <- aFewTimes (runSpar $ BrigAccess.getStatus (userId brigUser)) (== Active) + accStatus <- aFewTimes (runSpar $ BrigAPIAccess.getStatus (userId brigUser)) (== Active) liftIO $ accStatus `shouldBe` Active liftIO $ userManagedBy brigUser `shouldBe` ManagedByScim @@ -1321,9 +1321,9 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do -- auto-provision user via saml memberWithSSO <- do uid <- loginSsoUserFirstTime idp privCreds - Just usr <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations uid + Just usr <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations uid handle <- nextHandle - runSpar $ BrigAccess.setHandle uid handle + runSpar $ BrigAPIAccess.setHandle uid handle pure usr let memberIdWithSSO = userId memberWithSSO idpIssuer = idp ^. SAML.idpMetadata . SAML.edIssuer @@ -1335,7 +1335,7 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do liftIO $ userManagedBy memberWithSSO `shouldBe` ManagedByWire users <- listUsers tok (Just (filterBy "externalId" externalId)) liftIO $ (scimUserId <$> users) `shouldContain` [memberIdWithSSO] - Just brigUser' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations memberIdWithSSO + Just brigUser' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations memberIdWithSSO liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim where veidToText :: (MonadError String m) => ValidScimId -> m Text @@ -1357,7 +1357,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSO = do users' <- listUsers tok (Just (filterBy "externalId" emailInvited)) liftIO $ (scimUserId <$> users') `shouldContain` [memberIdInvited] - Just brigUserInvited' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations memberIdInvited + Just brigUserInvited' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations memberIdInvited liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId :: TestSpar () @@ -1370,7 +1370,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId = do let memberIdInvited = userId memberInvited _ <- getUser tok memberIdInvited - Just brigUserInvited' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations memberIdInvited + Just brigUserInvited' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations memberIdInvited liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindProvisionedUserNoIdP :: TestSpar () @@ -1390,8 +1390,8 @@ testFindNonProvisionedUserNoIdP findBy = do email <- randomEmail uid <- userId <$> call (inviteAndRegisterUser (env ^. teBrig) owner teamid email) handle <- nextHandle - runSpar $ BrigAccess.setHandle uid handle - Just brigUser <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations uid + runSpar $ BrigAPIAccess.setHandle uid handle + Just brigUser <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations uid do -- inspect brig user @@ -1405,7 +1405,7 @@ testFindNonProvisionedUserNoIdP findBy = do do liftIO $ users `shouldBe` [uid] - Just brigUser' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations uid + Just brigUser' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations uid liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim liftIO $ brigUser' `shouldBe` scimifyBrigUserHack brigUser email @@ -1420,7 +1420,7 @@ testListNoDeletedUsers = do -- Delete the user _ <- deleteUser tok userid -- Make sure it is deleted in brig before pulling via SCIM (which would recreate it!) - Nothing <- aFewTimes (runSpar (BrigAccess.getAccount Intra.WithPendingInvitations userid)) isNothing + Nothing <- aFewTimes (runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations userid)) isNothing -- Get all users users <- listUsers tok (Just (filterForStoredUser storedUser)) -- Check that the user is absent @@ -1492,7 +1492,7 @@ testGetUser = do shouldBeManagedBy :: (HasCallStack) => UserId -> ManagedBy -> TestSpar () shouldBeManagedBy uid flag = do - managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (BrigAccess.getAccount Intra.WithPendingInvitations uid) + managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations uid) liftIO $ managedBy `shouldBe` flag -- | This is (roughly) the behavior on develop as well as on the branch where this test was @@ -1551,12 +1551,12 @@ testGetUserWithNoHandle = do uid <- loginSsoUserFirstTime idp privcreds tok <- registerScimToken tid (Just (idp ^. SAML.idpId)) - mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (BrigAccess.getAccount Intra.WithPendingInvitations uid) + mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations uid) liftIO $ mhandle `shouldSatisfy` isNothing storedUser <- getUser tok uid liftIO $ (Scim.User.displayName . Scim.value . Scim.thing) storedUser `shouldSatisfy` isJust - mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (BrigAccess.getAccount Intra.WithPendingInvitations uid)) isJust + mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations uid)) isJust liftIO $ mhandle' `shouldSatisfy` isJust liftIO $ (fromHandle <$> mhandle') `shouldBe` (Just . Scim.User.userName . Scim.value . Scim.thing $ storedUser) @@ -1945,7 +1945,7 @@ testBrigSideIsUpdated = do validScimUser <- runSpar . runScimErrorUnsafe $ validateScimUser' "testBrigSideIsUpdated" (Just idp) 999999 user' - brigUser <- maybe (error "no brig user") pure =<< runSpar (BrigAccess.getAccount Intra.WithPendingInvitations userid) + brigUser <- maybe (error "no brig user") pure =<< runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations userid) let scimUserWithDefLocale = validScimUser {Spar.Types.locale = Spar.Types.locale validScimUser <|> Just (Locale (Language EN) Nothing)} brigUser `userShouldMatch` scimUserWithDefLocale @@ -2236,7 +2236,7 @@ specDeleteUser = do storedUser <- createUser tok user let uid :: UserId = scimUserId storedUser uref :: SAML.UserRef <- do - mUsr <- runSpar $ BrigAccess.getAccount Intra.WithPendingInvitations uid + mUsr <- runSpar $ BrigAPIAccess.getAccount Intra.WithPendingInvitations uid let cond usr = Intra.newVeidFromBrigUser usr (Just (idp ^. SAML.idpMetadata . SAML.edIssuer)) good bad = runValidScimIdEither pure (const $ err bad) err bad = error $ "brig user without UserRef: " <> show (bad, user) @@ -2247,7 +2247,7 @@ specDeleteUser = do deleteUser_ (Just tok) (Just uid) spar !!! const 204 === statusCode brigUser :: Maybe User <- - aFewTimes (runSpar $ BrigAccess.getAccount Intra.WithPendingInvitations uid) isNothing + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.WithPendingInvitations uid) isNothing samlUser :: Maybe UserId <- aFewTimes (getUserIdViaRef' uref) isNothing scimUser <- diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index ce8f9cfb0f5..b172bac74b1 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -182,10 +182,9 @@ import qualified Spar.App as IdpConfigStire import qualified Spar.App as Spar import Spar.CanonicalInterpreter import Spar.Error (SparError) -import qualified Spar.Intra.BrigApp as Intra +import qualified Spar.Intra.RpcApp as Intra import Spar.Options import Spar.Run -import Spar.Sem.BrigAccess (getAccount) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import qualified System.Logger.Extended as Log @@ -217,6 +216,7 @@ import qualified Wire.API.User as User import Wire.API.User.Auth hiding (Cookie) import Wire.API.User.IdentityProvider import Wire.API.User.Scim +import Wire.BrigAPIAccess (getAccount) import qualified Wire.IdPConfigStore as IdPConfigStore -- | Call 'mkEnv' with options from config files. diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index 02fb3bae4e0..9f8d1b1c023 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -42,7 +42,7 @@ import qualified Network.Wai.Utilities as Error import Polysemy.Error (runError) import qualified SAML2.WebSSO as SAML import SAML2.WebSSO.Types (IdPId, idpId) -import qualified Spar.Intra.BrigApp as Intra +import qualified Spar.Intra.RpcApp as Intra import Spar.Scim.User (synthesizeScimUser, validateScimUser') import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import Test.QuickCheck (arbitrary, generate) diff --git a/services/spar/test/Test/Spar/Intra/BrigSpec.hs b/services/spar/test/Test/Spar/Intra/BrigSpec.hs index 002a915528b..771ecf8968f 100644 --- a/services/spar/test/Test/Spar/Intra/BrigSpec.hs +++ b/services/spar/test/Test/Spar/Intra/BrigSpec.hs @@ -25,7 +25,7 @@ import Data.These import Data.These.Combinators import Imports import SAML2.WebSSO as SAML -import Spar.Intra.BrigApp +import Spar.Intra.RpcApp import Test.Hspec import Test.QuickCheck import URI.ByteString (URI, laxURIParserOptions, parseURI) diff --git a/services/spar/test/Test/Spar/Saml/IdPSpec.hs b/services/spar/test/Test/Spar/Saml/IdPSpec.hs index 31de2e30574..db2a588498f 100644 --- a/services/spar/test/Test/Spar/Saml/IdPSpec.hs +++ b/services/spar/test/Test/Spar/Saml/IdPSpec.hs @@ -1,6 +1,7 @@ module Test.Spar.Saml.IdPSpec where import Arbitrary () +import Data.Default (Default (..)) import Data.Domain import Data.Id (idToText, parseIdFromText) import qualified Data.List.NonEmpty as NonEmptyL @@ -18,8 +19,6 @@ import SAML2.WebSSO import qualified SAML2.WebSSO as SAML import Spar.API (idpCreate, idpCreateV7, idpDelete, idpUpdate) import Spar.Error -import Spar.Sem.BrigAccess -import Spar.Sem.GalleyAccess import Spar.Sem.IdPRawMetadataStore import Spar.Sem.IdPRawMetadataStore.Mem import Spar.Sem.SAMLUserStore @@ -35,8 +34,15 @@ import qualified Text.XML.DSig as DSig import URI.ByteString (parseURI, strictURIParserOptions) import URI.ByteString.QQ (uri) import Wire.API.Routes.Internal.Brig (IdpChangedNotification (..)) +import Wire.API.Team.Feature (FeatureStatus (FeatureStatusEnabled), LockableFeature (..)) +import Wire.API.Team.Member (mkNewTeamMember, ntmNewTeamMember, rolePermissions) +import Wire.API.Team.Role (Role (RoleOwner)) import Wire.API.User (User (..)) import Wire.API.User.IdentityProvider (IdPMetadataInfo (..), WireIdPAPIVersion (..)) +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import qualified Wire.GalleyAPIAccess import Wire.IdPConfigStore import Wire.IdPConfigStore.Mem import Wire.Sem.Logger.TinyLog (LogRecorder (..), newLogRecorder, recordLogs) @@ -519,41 +525,18 @@ interpretWithLoggingMock mbAccount action = do let (notifs, res) = either (error . show) id a pure (logs, notifs, res) -galleyAccessMock :: Sem (GalleyAccess ': r) a -> Sem r a +galleyAccessMock :: Sem (GalleyAPIAccess ': r) a -> Sem r a galleyAccessMock = interpret $ \case - GetTeamMembers _teamId -> undefined - GetTeamMember _teamId _userId -> undefined - AssertHasPermission _teamId _perm _userId -> pure () - AssertSSOEnabled _teamId -> pure () - IsEmailValidationEnabledTeam _teamId -> undefined - UpdateTeamMember _userId _teamId _role -> undefined - -brigAccessMock :: Maybe User -> Sem (BrigAccess ': r) a -> Sem r ([IdpChangedNotification], a) + Wire.GalleyAPIAccess.GetTeamMember uid _teamId -> pure (Just $ ntmNewTeamMember $ mkNewTeamMember uid (rolePermissions RoleOwner) Nothing) + Wire.GalleyAPIAccess.GetFeatureConfigForTeam _teamId -> pure (def {status = FeatureStatusEnabled}) + _ -> undefined + +brigAccessMock :: Maybe User -> Sem (BrigAPIAccess ': r) a -> Sem r ([IdpChangedNotification], a) brigAccessMock mbAccount = (runState @([IdpChangedNotification]) mempty .) $ reinterpret $ \case - CreateSAML _userRef _userId _teamId _name _managedBy _mHandle _mRichInfo _mLocale _role -> undefined - CreateNoSAML _txt _email _userId _teamId _name _mLocale _role -> undefined - UpdateEmail _userId _email _activation -> undefined - GetAccount _havePendingInvitations _userId -> pure mbAccount - GetByHandle _handle -> undefined - GetByEmail _email -> undefined - SetName _userId _name -> undefined - SetHandle _userId _handle -> undefined - SetManagedBy _userId _managedBy -> undefined - SetSSOId _userId _ssoId -> undefined - SetRichInfo _userId _richInfo -> undefined - SetLocale _userId _mLocale -> undefined - GetRichInfo _userId -> undefined - CheckHandleAvailable _handle -> undefined - DeleteUser _userId -> undefined - EnsureReAuthorised _mUserId _mPassword _mCode _mAction -> undefined - SsoLogin _userId _label -> undefined - GetStatus _userId -> undefined - GetStatusMaybe _userId -> undefined - SetStatus _userId _status -> undefined - GetDefaultUserLocale -> undefined - CheckAdminGetTeamId _userId -> undefined - SendSAMLIdPChangedEmail notif -> modify (notif :) + Wire.BrigAPIAccess.GetAccount _havePendingInvitations _userId -> pure mbAccount + Wire.BrigAPIAccess.SendSAMLIdPChangedEmail notif -> modify (notif :) + _ -> undefined ignoringState :: (Functor f) => (a -> f (c, b)) -> a -> f b ignoringState f = fmap snd . f @@ -561,8 +544,8 @@ ignoringState f = fmap snd . f type Effs = '[ Random, SAMLUserStore, - GalleyAccess, - BrigAccess, + GalleyAPIAccess, + BrigAPIAccess, ScimTokenStore, IdPConfigStore, IdPRawMetadataStore, diff --git a/services/spar/test/Test/Spar/Scim/UserSpec.hs b/services/spar/test/Test/Spar/Scim/UserSpec.hs index f28ed144925..5088a8fde7d 100644 --- a/services/spar/test/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test/Test/Spar/Scim/UserSpec.hs @@ -26,7 +26,6 @@ import Imports import Polysemy import Polysemy.TinyLog import Spar.Scim.User (deleteScimUser) -import Spar.Sem.BrigAccess import Spar.Sem.SAMLUserStore import Spar.Sem.SAMLUserStore.Mem (samlUserStoreToMem) import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore @@ -39,6 +38,7 @@ import Test.QuickCheck import Web.Scim.Schema.Error import Wire.API.User import Wire.API.User.Scim +import Wire.BrigAPIAccess import Wire.IdPConfigStore import Wire.IdPConfigStore.Mem (idPToMem) import Wire.IdPConfigStore.Orphans () @@ -50,32 +50,32 @@ spec = describe "deleteScimUser" $ do tokenInfo <- generate arbitrary acc <- someActiveUser tokenInfo r <- - interpretWithBrigAccessMock - (mockBrig (withActiveUser acc) AccountDeleted) + interpretWithBrigAPIAccessMock + (mockBrig (withActiveUser acc)) (deleteUserAndAssertDeletionInSpar acc tokenInfo) r `shouldBe` Right () it "is idempotent" $ do tokenInfo <- generate arbitrary acc <- someActiveUser tokenInfo r <- - interpretWithBrigAccessMock - (mockBrig (withActiveUser acc) AccountAlreadyDeleted) + interpretWithBrigAPIAccessMock + (mockBrig (withActiveUser acc)) (deleteUserAndAssertDeletionInSpar acc tokenInfo) r `shouldBe` Right () it "works if there never was an account" $ do uid <- generate arbitrary tokenInfo <- generate arbitrary r <- - interpretWithBrigAccessMock - (mockBrig (const Nothing) NoUser) + interpretWithBrigAPIAccessMock + (mockBrig (const Nothing)) (runExceptT $ deleteScimUser tokenInfo uid) r `shouldBe` Right () it "returns no error when there was a partially deleted account" $ do uid <- generate arbitrary tokenInfo <- generate arbitrary r <- - interpretWithBrigAccessMock - (mockBrig (const Nothing) AccountDeleted) + interpretWithBrigAPIAccessMock + (mockBrig (const Nothing)) (runExceptT $ deleteScimUser tokenInfo uid) r `shouldBe` Right () @@ -83,7 +83,7 @@ deleteUserAndAssertDeletionInSpar :: forall (r :: EffectRow). ( Members '[ Logger (Msg -> Msg), - BrigAccess, + BrigAPIAccess, ScimExternalIdStore.ScimExternalIdStore, ScimUserTimesStore, SAMLUserStore, @@ -105,7 +105,7 @@ deleteUserAndAssertDeletionInSpar acc tokenInfo = do liftIO $ lr `shouldBe` Nothing pure r -type EffsWithoutBrigAccess = +type EffsWithoutBrigAPIAccess = '[ IdPConfigStore, SAMLUserStore, ScimUserTimesStore, @@ -115,13 +115,13 @@ type EffsWithoutBrigAccess = Final IO ] -interpretWithBrigAccessMock :: - ( Sem (BrigAccess ': EffsWithoutBrigAccess) a -> - Sem EffsWithoutBrigAccess a +interpretWithBrigAPIAccessMock :: + ( Sem (BrigAPIAccess ': EffsWithoutBrigAPIAccess) a -> + Sem EffsWithoutBrigAPIAccess a ) -> - Sem (BrigAccess ': EffsWithoutBrigAccess) a -> + Sem (BrigAPIAccess ': EffsWithoutBrigAPIAccess) a -> IO a -interpretWithBrigAccessMock mock = +interpretWithBrigAPIAccessMock mock = runFinal . embedToFinal @IO . discardTinyLogs @@ -138,12 +138,11 @@ mockBrig :: forall (r :: EffectRow) a. (Member (Embed IO) r) => (UserId -> Maybe User) -> - DeleteUserResult -> - Sem (BrigAccess ': r) a -> + Sem (BrigAPIAccess ': r) a -> Sem r a -mockBrig lookup_user delete_response = interpret $ \case +mockBrig lookup_user = interpret $ \case (GetAccount WithPendingInvitations uid) -> pure $ lookup_user uid - (Spar.Sem.BrigAccess.DeleteUser _) -> pure delete_response + (Wire.BrigAPIAccess.DeleteUser _) -> pure () _ -> do liftIO $ expectationFailure $ "Unexpected effect (call to brig)" error "Throw error here to avoid implementation of all cases." diff --git a/tools/mlsstats/src/MlsStats/Run.hs b/tools/mlsstats/src/MlsStats/Run.hs index 3523b8252a9..4ee5d0f9367 100644 --- a/tools/mlsstats/src/MlsStats/Run.hs +++ b/tools/mlsstats/src/MlsStats/Run.hs @@ -197,7 +197,7 @@ uploadStream env bucket key stream = do runConduit $ stream .| chunksOfE chunkSize - .| uploadParts env bucket key uploadId' 0 + .| uploadParts env bucket key uploadId' 1 .| mapC (uncurry newCompletedPart) .| sinkList void $