diff --git a/.envrc b/.envrc index 18a26cfccf..02c85a3c19 100644 --- a/.envrc +++ b/.envrc @@ -37,3 +37,7 @@ path_add "PYTHONPATH" "./hack/python" # Locale export LC_ALL=en_US.UTF-8 export LANG=en_US.UTF-8 + +# RabbitMQ +export RABBITMQ_USERNAME=guest +export RABBITMQ_PASSWORD=alpaca-grapefruit \ No newline at end of file diff --git a/Makefile b/Makefile index ae8718f88a..3645956ad5 100644 --- a/Makefile +++ b/Makefile @@ -99,11 +99,11 @@ endif ci: c db-migrate ifeq ("$(package)", "all") ifneq ("$(suite)", "new") - echo ./hack/bin/cabal-run-integration.sh all + ./hack/bin/cabal-run-integration.sh all endif ifneq ("$(suite)", "old") make c package=integration - echo ./hack/bin/cabal-run-integration.sh integration + ./hack/bin/cabal-run-integration.sh integration endif else ifeq ("$(package)", "integration") @@ -306,17 +306,13 @@ ifeq ($(package), all) ./dist/galley-schema --keyspace galley_test --replication-factor 1 --reset ./dist/gundeck-schema --keyspace gundeck_test --replication-factor 1 --reset ./dist/spar-schema --keyspace spar_test --replication-factor 1 --reset -ifeq ($(INTEGRATION_FEDERATION_TESTS), 1) ./dist/brig-schema --keyspace brig_test2 --replication-factor 1 --reset ./dist/galley-schema --keyspace galley_test2 --replication-factor 1 --reset ./dist/gundeck-schema --keyspace gundeck_test2 --replication-factor 1 --reset ./dist/spar-schema --keyspace spar_test2 --replication-factor 1 --reset -endif else $(EXE_SCHEMA) --keyspace $(package)_test --replication-factor 1 --reset -ifeq ($(INTEGRATION_FEDERATION_TESTS), 1) $(EXE_SCHEMA) --keyspace $(package)_test2 --replication-factor 1 --reset -endif endif ./dist/brig-index reset --elasticsearch-index-prefix directory --elasticsearch-server http://localhost:9200 > /dev/null ./dist/brig-index reset --elasticsearch-index-prefix directory2 --elasticsearch-server http://localhost:9200 > /dev/null @@ -334,12 +330,10 @@ db-migrate: c ./dist/galley-schema --keyspace galley_test --replication-factor 1 > /dev/null ./dist/gundeck-schema --keyspace gundeck_test --replication-factor 1 > /dev/null ./dist/spar-schema --keyspace spar_test --replication-factor 1 > /dev/null -ifeq ($(INTEGRATION_FEDERATION_TESTS), 1) ./dist/brig-schema --keyspace brig_test2 --replication-factor 1 > /dev/null ./dist/galley-schema --keyspace galley_test2 --replication-factor 1 > /dev/null ./dist/gundeck-schema --keyspace gundeck_test2 --replication-factor 1 > /dev/null ./dist/spar-schema --keyspace spar_test2 --replication-factor 1 > /dev/null -endif ./dist/brig-index reset --elasticsearch-index-prefix directory --elasticsearch-server http://localhost:9200 > /dev/null ./dist/brig-index reset --elasticsearch-index-prefix directory2 --elasticsearch-server http://localhost:9200 > /dev/null @@ -402,16 +396,6 @@ kube-integration-teardown: kube-integration-e2e-telepresence: ./services/brig/federation-tests.sh $(NAMESPACE) -.PHONY: kube-integration-setup-sans-federation -kube-integration-setup-sans-federation: guard-tag charts-integration - # by default "test- is used as namespace - # you can override the default by setting the NAMESPACE environment variable - export NAMESPACE=$(NAMESPACE); ./hack/bin/integration-setup.sh - -.PHONY: kube-integration-teardown-sans-federation -kube-integration-teardown-sans-federation: - export NAMESPACE=$(NAMESPACE); ./hack/bin/integration-teardown.sh - .PHONY: kube-restart-% kube-restart-%: kubectl delete pod -n $(NAMESPACE) -l app=$(*) diff --git a/README.md b/README.md index 8c8c7fcdb7..fcfe538460 100644 --- a/README.md +++ b/README.md @@ -85,7 +85,7 @@ will, eventually, have built a range of docker images. Make sure to [give Docker See the `Makefile`s and `Dockerfile`s, as well as [build/ubuntu/README.md](build/ubuntu/README.md) for details. -#### 2. Use nix-provided build environment +#### 2. Use nix-provided build environment This is suitable only for local development and testing. See [build instructions](./docs/src/developer/developer/building.md) in the developer documentation. diff --git a/cabal.project b/cabal.project index 7c6a372b95..66ba354eeb 100644 --- a/cabal.project +++ b/cabal.project @@ -31,6 +31,7 @@ packages: , libs/wire-api-federation/ , libs/wire-message-proto-lens/ , libs/zauth/ + , services/background-worker/ , services/brig/ , services/cannon/ , services/cargohold/ @@ -66,6 +67,8 @@ package assets ghc-options: -Werror package auto-whitelist ghc-options: -Werror +package background-worker + ghc-options: -Werror package bilge ghc-options: -Werror package billing-team-member-backfill diff --git a/changelog.d/0-release-notes/background-worker b/changelog.d/0-release-notes/background-worker new file mode 100644 index 0000000000..34c3cf7ee5 --- /dev/null +++ b/changelog.d/0-release-notes/background-worker @@ -0,0 +1,38 @@ +This release introduces a new component: background-worker. This is currently +only used to forward notifications to federated backends. Enabling federation in +the wire-server helm chart automatically installs this component. + +When federation is enabled, wire-server will require running RabbitMQ. The helm +chart in `rabbitmq` can be used to install RabbitMQ. Please refer to the +documentation at https://docs.wire.com to install RabbitMQ in Kubernetes. These +new configurations are required: + +```yaml +brig: + config: + rabbitmq: + host: rabbitmq + port: 5672 + vHost: / + secrets: + rabbitmq: + username: + password: +background-worker: + config: + rabbitmq: + host: rabbitmq + port: 5672 + vHost: / + remoteDomains: [] + secrets: + rabbitmq: + username: + password: +``` + +The above are the default values (except for secrets, which do not have +defaults), if they work they are not required to be configured. +`background-worker.config.remoteDomains` should contain all the remote domains +with which the wire-server instance allows federating. This change is +incompatible with open-federation. \ No newline at end of file diff --git a/changelog.d/1-api-changes/FS-1467 b/changelog.d/1-api-changes/FS-1467 new file mode 100644 index 0000000000..d7eff3eeb9 --- /dev/null +++ b/changelog.d/1-api-changes/FS-1467 @@ -0,0 +1 @@ +Updating conversation meta-data APIs to be fault tolerant of unavailable federation servers. \ No newline at end of file diff --git a/changelog.d/2-features/coturn-federation-dtls-helm-chart b/changelog.d/2-features/coturn-federation-dtls-helm-chart new file mode 100644 index 0000000000..7802dd7fe7 --- /dev/null +++ b/changelog.d/2-features/coturn-federation-dtls-helm-chart @@ -0,0 +1 @@ +Add federation options to the `coturn` Helm chart including DTLS support. The options themselves are strongly inspired by the `restund` Helm chart. diff --git a/changelog.d/3-bug-fixes/pr-3281 b/changelog.d/3-bug-fixes/pr-3281 new file mode 100644 index 0000000000..da3054c620 --- /dev/null +++ b/changelog.d/3-bug-fixes/pr-3281 @@ -0,0 +1 @@ +Fixed `/i/user/meta-info` in backoffice/stern diff --git a/changelog.d/5-internal/feature-singletons b/changelog.d/5-internal/feature-singletons new file mode 100644 index 0000000000..656feededd --- /dev/null +++ b/changelog.d/5-internal/feature-singletons @@ -0,0 +1,2 @@ +Use feature singletons in TeamFeatureStore + diff --git a/changelog.d/5-internal/integration-qol b/changelog.d/5-internal/integration-qol new file mode 100644 index 0000000000..2165b18538 --- /dev/null +++ b/changelog.d/5-internal/integration-qol @@ -0,0 +1,4 @@ +- Add convenience getJSON and getBody functions +- baseRequest now adds Z headers automatically +- Add liftIO versions of putStrLn etc +- Add Show instances for MLSState diff --git a/changelog.d/5-internal/list-tests b/changelog.d/5-internal/list-tests new file mode 100644 index 0000000000..c1f80d14c8 --- /dev/null +++ b/changelog.d/5-internal/list-tests @@ -0,0 +1 @@ +Implement test listing diff --git a/changelog.d/5-internal/mls-integration b/changelog.d/5-internal/mls-integration new file mode 100644 index 0000000000..721c32f4e1 --- /dev/null +++ b/changelog.d/5-internal/mls-integration @@ -0,0 +1 @@ +Port MLS test framework to new integration suite diff --git a/changelog.d/5-internal/pr-3305 b/changelog.d/5-internal/pr-3305 new file mode 100644 index 0000000000..88ca47e731 --- /dev/null +++ b/changelog.d/5-internal/pr-3305 @@ -0,0 +1 @@ +Register/Update OAuth client via backoffice/stern diff --git a/changelog.d/5-internal/ptests b/changelog.d/5-internal/ptests new file mode 100644 index 0000000000..55443d72a3 --- /dev/null +++ b/changelog.d/5-internal/ptests @@ -0,0 +1 @@ +Add parametrised tests diff --git a/changelog.d/6-federation/failed-to-process b/changelog.d/6-federation/failed-to-process new file mode 100644 index 0000000000..e9a94f54b8 --- /dev/null +++ b/changelog.d/6-federation/failed-to-process @@ -0,0 +1 @@ +Several federation Galley endpoints have a breaking change in their response types: "leave-conversation", "update-conversation" and "send-mls-message". They have been extended with information related to unreachable users. diff --git a/charts/background-worker/templates/deployment.yaml b/charts/background-worker/templates/deployment.yaml index 5ea3f8d8d6..4891ba0fdf 100644 --- a/charts/background-worker/templates/deployment.yaml +++ b/charts/background-worker/templates/deployment.yaml @@ -9,12 +9,11 @@ metadata: heritage: {{ .Release.Service }} spec: replicas: {{ .Values.replicaCount }} - # TODO(elland): Review this strategy: - type: RollingUpdate - rollingUpdate: - maxUnavailable: 0 - maxSurge: {{ .Values.replicaCount }} + # Ensures only one version of the background worker is running at any given + # moment. This means small downtime, but the background workers should be + # able to catch up. + type: Recreate selector: matchLabels: app: background-worker diff --git a/charts/background-worker/values.yaml b/charts/background-worker/values.yaml index 92ecda1665..dee71178f2 100644 --- a/charts/background-worker/values.yaml +++ b/charts/background-worker/values.yaml @@ -9,12 +9,11 @@ resources: cpu: "100m" limits: memory: "512Mi" -# TODO(elland): Create issue for a metrics endpoint +# FUTUREWORK: Implement metrics # metrics: # serviceMonitor: # enabled: false config: - # TODO(elland): Proper logging logLevel: Info logFormat: StructuredJSON rabbitmq: diff --git a/charts/brig/templates/tests/brig-integration.yaml b/charts/brig/templates/tests/brig-integration.yaml index 49f777bf2b..6a064c7619 100644 --- a/charts/brig/templates/tests/brig-integration.yaml +++ b/charts/brig/templates/tests/brig-integration.yaml @@ -80,10 +80,6 @@ spec: value: "dummy" - name: AWS_REGION value: "eu-west-1" - {{- if .Values.tests.enableFederationTests }} - - name: INTEGRATION_FEDERATION_TESTS - value: "1" - {{- end }} {{- if .Values.config.enableFederation }} - name: RABBITMQ_USERNAME value: "guest" diff --git a/charts/brig/values.yaml b/charts/brig/values.yaml index 3e7c89d0c7..0139760f28 100644 --- a/charts/brig/values.yaml +++ b/charts/brig/values.yaml @@ -123,8 +123,6 @@ turn: # baseDomain: turn.example.com # Must be configured if serversSource is dns discoveryIntervalSeconds: 10 # Used only if serversSource is dns -tests: - enableFederationTests: false serviceAccount: # When setting this to 'false', either make sure that a service account named # 'brig' exists or change the 'name' field to 'default' diff --git a/charts/coturn/Chart.yaml b/charts/coturn/Chart.yaml index 57176f6a46..ae35753e9d 100644 --- a/charts/coturn/Chart.yaml +++ b/charts/coturn/Chart.yaml @@ -11,4 +11,4 @@ version: 0.0.42 # This is the version number of the application being deployed. This version number should be # incremented each time you make changes to the application. Versions are not expected to # follow Semantic Versioning. They should reflect the version the application is using. -appVersion: 4.6.2-wireapp.2 +appVersion: 4.6.2-federation-wireapp.10 diff --git a/charts/coturn/templates/_helpers.tpl b/charts/coturn/templates/_helpers.tpl new file mode 100644 index 0000000000..32fea22520 --- /dev/null +++ b/charts/coturn/templates/_helpers.tpl @@ -0,0 +1,45 @@ +{{- define "coturn.name" -}} +{{- default .Chart.Name .Values.nameOverride | trunc 63 | trimSuffix "-" }} +{{- end }} + +{{/* +Create chart name and version as used by the chart label. +*/}} +{{- define "coturn.chart" -}} +{{- printf "%s-%s" .Chart.Name .Chart.Version | replace "+" "_" | trunc 63 | trimSuffix "-" }} +{{- end }} + +{{/* +Common labels +*/}} +{{- define "coturn.labels" -}} +helm.sh/chart: {{ include "coturn.chart" . }} +{{ include "coturn.selectorLabels" . }} +{{- if .Chart.AppVersion }} +app.kubernetes.io/version: {{ .Values.image.tag | default .Chart.AppVersion | quote }} +{{- end }} +app.kubernetes.io/managed-by: {{ .Release.Service }} +{{- end }} + +{{/* +Create a default fully qualified app name. +We truncate at 63 chars because some Kubernetes name fields are limited to this (by the DNS naming spec). +If release name contains chart name it will be used as a full name. +*/}} +{{- define "coturn.fullname" -}} +{{- if .Values.fullnameOverride }} +{{- .Values.fullnameOverride | trunc 63 | trimSuffix "-" }} +{{- else }} +{{- $name := default .Chart.Name .Values.nameOverride }} +{{- if contains $name .Release.Name }} +{{- .Release.Name | trunc 63 | trimSuffix "-" }} +{{- else }} +{{- printf "%s-%s" .Release.Name $name | trunc 63 | trimSuffix "-" }} +{{- end }} +{{- end }} +{{- end }} + +{{- define "coturn.selectorLabels" -}} +app.kubernetes.io/name: {{ include "coturn.name" . }} +app.kubernetes.io/instance: {{ .Release.Name }} +{{- end }} diff --git a/charts/coturn/templates/configmap-coturn-conf-template.yaml b/charts/coturn/templates/configmap-coturn-conf-template.yaml index 4988275b9d..cc458f7db6 100644 --- a/charts/coturn/templates/configmap-coturn-conf-template.yaml +++ b/charts/coturn/templates/configmap-coturn-conf-template.yaml @@ -20,13 +20,15 @@ data: no-tls {{- end }} + # This is mandatory for federated DTLS + CA-file=/etc/ssl/certs/ca-certificates.crt + ## don't turn on coturn's cli. no-cli ## turn, stun. listening-ip=__COTURN_EXT_IP__ listening-port={{ .Values.coturnTurnListenPort }} - max-allocate-lifetime=3600 relay-ip=__COTURN_EXT_IP__ realm=dummy.io no-stun-backward-compatibility @@ -82,3 +84,24 @@ data: zrest ## static authentication secrets will be added below this line when the ## runtime configuration is generated. + + {{- if .Values.federate.enabled }} + ### federation setup + federation-listening-ip=__COTURN_EXT_IP__ + federation-listening-port={{ .Values.federate.port }} + federation-no-dtls={{ not .Values.federate.dtls.enabled }} + {{- if .Values.federate.dtls.enabled }} + federation-cert=/coturn-dtls-certificate/tls.crt + federation-pkey=/coturn-dtls-certificate/tls.key + {{ if hasKey .Values.federate.dtls.tls "privateKeyPassword" }} + federation-pkey-pwd={{ .Values.federate.dtls.tls.privateKeyPassword }} + {{ end }} + # list of host/ip/cert common names / subject alt names, and optional issuer + # names to accept DTLS connections from. There can be multiple entries, each + # entry is formated as: + # [,] + {{ range $entry := .Values.federate.dtls.remoteWhitelist }} + federation-remote-whitelist={{ $entry.host }}{{ if hasKey $entry "issuer" }},{{ $entry.issuer }}{{end}} + {{ end }} + {{ end }} + {{ end }} diff --git a/charts/coturn/templates/secret-or-certificate.yaml b/charts/coturn/templates/secret-or-certificate.yaml new file mode 100644 index 0000000000..a48eba9b49 --- /dev/null +++ b/charts/coturn/templates/secret-or-certificate.yaml @@ -0,0 +1,41 @@ +{{- if .Values.federate.dtls.enabled -}} + +{{- if .Values.federate.dtls.tls.issuerRef -}} +{{- if or .Values.federate.dtls.tls.key .Values.federate.dtls.tls.crt }} +{{- fail "issuerRef and {crt,key} are mutually exclusive" -}} +{{- end -}} +apiVersion: cert-manager.io/v1 +kind: Certificate +metadata: + name: "{{ include "coturn.fullname" . }}" + labels: + {{- include "coturn.labels" . | nindent 4 }} + {{- if .Values.federate.dtls.tls.certificate.labels }} + {{- toYaml .Values.federate.dtls.tls.certificate.labels | nindent 4}} + {{- end }} +spec: + dnsNames: + {{- toYaml .Values.federate.dtls.tls.certificate.dnsNames | nindent 4 }} + secretName: coturn-dtls-certificate + issuerRef: + {{- toYaml .Values.federate.dtls.tls.issuerRef | nindent 4 }} + privateKey: + rotationPolicy: Always + algorithm: ECDSA + size: 384 +{{- else if and .Values.federate.dtls.tls.key .Values.federate.dtls.tls.crt }} +apiVersion: v1 +kind: Secret +metadata: + name: coturn-dtls-certificate + labels: + {{- include "coturn.labels" . | nindent 4 }} +type: Opaque +data: + tls.key: {{ .Values.federate.dtls.tls.key | b64enc }} + tls.crt: {{ .Values.federate.dtls.tls.crt | b64enc }} +{{- else -}} +{{- fail "must specify tls.key and tls.crt , or tls.issuerRef" -}} +{{- end -}} + +{{- end -}} diff --git a/charts/coturn/templates/statefulset.yaml b/charts/coturn/templates/statefulset.yaml index 93550eb97f..8fa0d5f0ed 100644 --- a/charts/coturn/templates/statefulset.yaml +++ b/charts/coturn/templates/statefulset.yaml @@ -58,6 +58,11 @@ spec: secret: secretName: {{ .Values.tls.secretRef }} {{- end }} + {{- if .Values.federate.dtls.enabled }} + - name: coturn-dtls-certificate + secret: + secretName: coturn-dtls-certificate + {{- end }} initContainers: - name: get-external-ip image: bitnami/kubectl:1.24.12 @@ -116,6 +121,11 @@ spec: mountPath: /secrets-tls/ readOnly: true {{- end }} + {{- if .Values.federate.dtls.enabled }} + - name: coturn-dtls-certificate + mountPath: /coturn-dtls-certificate/ + readOnly: true + {{- end }} command: - /bin/sh - -c diff --git a/charts/coturn/values.yaml b/charts/coturn/values.yaml index 2b02df64a8..683cb2501d 100644 --- a/charts/coturn/values.yaml +++ b/charts/coturn/values.yaml @@ -41,6 +41,50 @@ tls: config: verboseLogging: false +federate: + enabled: false + port: 9191 + + dtls: + enabled: false + + tls: + # Example: + # + # tls: + # key: "-----BEGIN EC PRIVATE KEY----- ..." # (ascii blob) private key + # crt: "-----BEGIN CERTIFICATE----- ..." # (ascii blob) certificate + # privateKeyPassword: "XXX" # optional, used when the key is password protected + # + # OR (mutually exclusive) + # + # tls: + # issuerRef: + # name: letsencrypt-http01 + # + # # We can reference ClusterIssuers by changing the kind here. + # # The default value is Issuer (i.e. a locally namespaced Issuer) + # # kind: Issuer + # kind: Issuer + # + # # This is optional since cert-manager will default to this value however + # # if you are using an external issuer, change this to that issuer group. + # group: cert-manager.io + # + # # optional labels to attach to the cert-manager Certificate + # certificate: + # labels: .. + + # # list of host/ip/cert common names / subject alt names, and optional issuer + # # names to accept DTLS connections from. There can be multiple entries. + # remoteWhitelist: + # - host: example.com + # issuer: Issuer Common Name + # - host: another.example.com + # issuer: "DigiCert SHA2 Extended Validation Server CA" + # - host: another-host-without-issuer.example.com + remoteWhitelist: [] + metrics: serviceMonitor: enabled: false diff --git a/charts/integration/templates/integration-integration.yaml b/charts/integration/templates/integration-integration.yaml index 58876020c3..98a0f3df7e 100644 --- a/charts/integration/templates/integration-integration.yaml +++ b/charts/integration/templates/integration-integration.yaml @@ -71,6 +71,12 @@ spec: - name: AWS_REGION value: "eu-west-1" - name: RABBITMQ_USERNAME - value: "guest" + valueFrom: + secretKeyRef: + name: brig + key: rabbitmqUsername - name: RABBITMQ_PASSWORD - value: "guest" + valueFrom: + secretKeyRef: + name: brig + key: rabbitmqPassword diff --git a/charts/wire-server/requirements.yaml b/charts/wire-server/requirements.yaml index 8a1da9b06a..9a2ff8649b 100644 --- a/charts/wire-server/requirements.yaml +++ b/charts/wire-server/requirements.yaml @@ -111,6 +111,14 @@ dependencies: - federation - haskellServices - services +- name: background-worker + version: "0.0.42" + repository: "file://../background-worker" + tags: + - background-worker + - federation + - haskellServices + - services - name: sftd version: "0.0.42" repository: "file://../sftd" diff --git a/deploy/dockerephemeral/init.sh b/deploy/dockerephemeral/init.sh index eec9c37226..659dc656be 100755 --- a/deploy/dockerephemeral/init.sh +++ b/deploy/dockerephemeral/init.sh @@ -16,35 +16,42 @@ while (! aws --endpoint-url=http://dynamodb:8000 --cli-connect-timeout=1 dynamod sleep 1; done echo " [ok!]" -aws --endpoint-url=http://dynamodb:8000 dynamodb delete-table --table-name integration-brig-userkey-blacklist || true -aws --endpoint-url=http://dynamodb:8000 dynamodb delete-table --table-name integration-brig-prekeys || true - -# Create Dynamo/SQS resources -exec_until_ready "aws --endpoint-url=http://dynamodb:8000 dynamodb create-table --table-name integration-brig-userkey-blacklist --attribute-definitions AttributeName=key,AttributeType=S --key-schema AttributeName=key,KeyType=HASH --provisioned-throughput ReadCapacityUnits=5,WriteCapacityUnits=5" -exec_until_ready "aws --endpoint-url=http://dynamodb:8000 dynamodb create-table --table-name integration-brig-prekeys --attribute-definitions AttributeName=client,AttributeType=S --key-schema AttributeName=client,KeyType=HASH --provisioned-throughput ReadCapacityUnits=5,WriteCapacityUnits=5" -exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs create-queue --queue-name integration-brig-events" -exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs set-queue-attributes --queue-url http://sqs:4568/integration-brig-events --attributes VisibilityTimeout=1" -exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs create-queue --queue-name integration-brig-events-internal" -exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs set-queue-attributes --queue-url http://sqs:4568/integration-brig-events-internal --attributes VisibilityTimeout=1" -exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs create-queue --queue-name integration-user-events.fifo" -exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs set-queue-attributes --queue-url http://sqs:4568/integration-user-events.fifo --attributes VisibilityTimeout=1" -# Gundeck's feedback queue -exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs create-queue --queue-name integration-gundeck-events" -exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs set-queue-attributes --queue-url http://sqs:4568/integration-gundeck-events --attributes VisibilityTimeout=1" -# Galley's team event queue -exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs create-queue --queue-name integration-team-events.fifo" -exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs set-queue-attributes --queue-url http://sqs:4568/integration-team-events.fifo --attributes VisibilityTimeout=1" -# Verify sender's email address (ensure the sender address is in sync with the config in brig) -exec_until_ready "aws --endpoint-url=http://ses:4579 ses verify-email-identity --email-address backend-integration@wire.com" - -# Create SNS resources for gundeck's notifications -exec_until_ready "aws --endpoint-url=http://sns:4575 sns create-platform-application --name integration-test --platform GCM --attributes PlatformCredential=testkey" -exec_until_ready "aws --endpoint-url=http://sns:4575 sns create-platform-application --name integration-test --platform APNS_SANDBOX --attributes PlatformCredential=testprivatekey" -exec_until_ready "aws --endpoint-url=http://sns:4575 sns create-platform-application --name integration-com.wire.ent --platform APNS_SANDBOX --attributes PlatformCredential=testprivatekey" - -# Cargohold's bucket; creating a bucket is not idempotent so we just try once and wait until it is ready -# TODO: Lifecycle configuration for the bucket, if supported. -aws --endpoint-url=http://s3:9000 s3api create-bucket --bucket dummy-bucket -aws --endpoint-url=http://s3:9000 s3api wait bucket-exists --bucket dummy-bucket + +for suffix in "" "2"; do + aws --endpoint-url=http://dynamodb:8000 dynamodb delete-table --table-name integration-brig-userkey-blacklist$suffix || true + aws --endpoint-url=http://dynamodb:8000 dynamodb delete-table --table-name integration-brig-prekeys$suffix || true + + # Create Dynamo/SQS resources + exec_until_ready "aws --endpoint-url=http://dynamodb:8000 dynamodb create-table --table-name integration-brig-userkey-blacklist$suffix --attribute-definitions AttributeName=key,AttributeType=S --key-schema AttributeName=key,KeyType=HASH --provisioned-throughput ReadCapacityUnits=5,WriteCapacityUnits=5" + exec_until_ready "aws --endpoint-url=http://dynamodb:8000 dynamodb create-table --table-name integration-brig-prekeys$suffix --attribute-definitions AttributeName=client,AttributeType=S --key-schema AttributeName=client,KeyType=HASH --provisioned-throughput ReadCapacityUnits=5,WriteCapacityUnits=5" + + exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs create-queue --queue-name integration-brig-events$suffix" + exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs set-queue-attributes --queue-url http://sqs:4568/integration-brig-events$suffix --attributes VisibilityTimeout=1" + exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs create-queue --queue-name integration-brig-events-internal$suffix" + exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs set-queue-attributes --queue-url http://sqs:4568/integration-brig-events-internal$suffix --attributes VisibilityTimeout=1" + exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs create-queue --queue-name integration-user-events.fifo$suffix" + exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs set-queue-attributes --queue-url http://sqs:4568/integration-user-events.fifo$suffix --attributes VisibilityTimeout=1" + + # Gundeck's feedback queue + exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs create-queue --queue-name integration-gundeck-events$suffix" + exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs set-queue-attributes --queue-url http://sqs:4568/integration-gundeck-events$suffix --attributes VisibilityTimeout=1" + + # Galley's team event queue + exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs create-queue --queue-name integration-team-events.fifo$suffix" + exec_until_ready "aws --endpoint-url=http://sqs:4568 sqs set-queue-attributes --queue-url http://sqs:4568/integration-team-events.fifo$suffix --attributes VisibilityTimeout=1" + + # Verify sender's email address (ensure the sender address is in sync with the config in brig) + exec_until_ready "aws --endpoint-url=http://ses:4579 ses verify-email-identity --email-address backend-integration$suffix@wire.com" + + # Create SNS resources for gundeck's notifications + exec_until_ready "aws --endpoint-url=http://sns:4575 sns create-platform-application --name integration-test$suffix --platform GCM --attributes PlatformCredential=testkey" + exec_until_ready "aws --endpoint-url=http://sns:4575 sns create-platform-application --name integration-test$suffix --platform APNS_SANDBOX --attributes PlatformCredential=testprivatekey" + exec_until_ready "aws --endpoint-url=http://sns:4575 sns create-platform-application --name integration-com.wire.ent$suffix --platform APNS_SANDBOX --attributes PlatformCredential=testprivatekey" + + # Cargohold's bucket; creating a bucket is not idempotent so we just try once and wait until it is ready + # TODO: Lifecycle configuration for the bucket, if supported. + aws --endpoint-url=http://s3:9000 s3api create-bucket --bucket "dummy-bucket$suffix" + aws --endpoint-url=http://s3:9000 s3api wait bucket-exists --bucket "dummy-bucket$suffix" +done echo 'AWS resources created successfully!' diff --git a/docs/src/developer/developer/how-to.md b/docs/src/developer/developer/how-to.md index d202f519f4..6c7cc0e1cb 100644 --- a/docs/src/developer/developer/how-to.md +++ b/docs/src/developer/developer/how-to.md @@ -15,17 +15,14 @@ Terminal 1: * Set up backing services: `./deploy/dockerephemeral/run.sh` Terminal 2: -* Compile all services: `make c` -* Run services including nginz: `./services/run-services`. +* Build and start wire-server services: ` make c && ./services/run-services` Open your browser at: -[http://localhost:8080/api/swagger-ui](http://localhost:8080/api/swagger-ui) for -the Swagger 2.0 endpoints of the latest version. This endpoint is versioned; -i.e. the Swagger docs refer to the API version. Refer to the [Swagger API -documentation](../../understand/api-client-perspective/swagger.md) regarding -Swagger and API versioning. +[http://localhost:8080/api/swagger-ui](http://localhost:8080/api/swagger-ui) for a list of API verions. -Swagger json is available under [http://localhost:8080/api/swagger.json](http://localhost:8080/api/swagger.json) +Also check out the docs for swagger in our staging environment: +{ref}`swagger-api-docs`. Replace the staging domain by +`localhost:8080` to get to your local build. ## How to run federation tests across two backends @@ -211,6 +208,6 @@ Note: Simply deleting the namespaces is insufficient, because it leaves some res ## How to manage RabbitMQ -We support two different ways of managing the docker-compose instance of rabbitmq: -* A web console interface is available [here](http://localhost:15672) +We support two different ways of managing the docker-compose instance of rabbitmq: +* A web console interface is available [here](http://localhost:15672) * `rabbitmqadmin` CLI is made available in the dev environment diff --git a/docs/src/how-to/install/helm-prod.md b/docs/src/how-to/install/helm-prod.md index 29045f1818..e19f8ad8b3 100644 --- a/docs/src/how-to/install/helm-prod.md +++ b/docs/src/how-to/install/helm-prod.md @@ -155,6 +155,32 @@ cp values/wire-server/prod-secrets.example.yaml my-wire-server/secrets.yaml cp values/wire-server/prod-values.example.yaml my-wire-server/values.yaml ``` +## How to install RabbitMQ + +This is only required when federation needs to be enabled. + +1. Generate password for rabbitmq: + + ```shell + openssl rand -base64 64 | env LC_CTYPE=C tr -dc a-zA-Z0-9 | head -c 42 > my-wire-server/rabbitmq-password + ``` + +2. Copy example values + + ```shell + cp values/rabbitmq/prod-secrets.example.yaml values/rabbitmq/secrets.yaml + cp values/rabbitmq/prod-values.example.yaml values/rabbitmq/values.yaml + ``` + +3. Add the generated secret from `my-wire-server/rabbitmq-password` to + `values/rabbitmq/secrets.yaml` under `rabbitmq.auth.password`. + +4. Install the helm chart using: + + ```shell + helm upgrade --install rabbitmq wire/rabbitmq -f values/rabbitmq/values.yaml -f values/rabbitmq/secrets.yaml + ``` + ## How to configure real SMTP (email) services In order for users to interact with their wire account, they need to receive mail from your wire server. @@ -189,9 +215,10 @@ apt install docker-ce sudo docker run --rm quay.io/wire/alpine-intermediate /dist/zauth -m gen-keypair -i 1 > my-wire-server/zauth.txt ``` -1. Add the generated secret from my-wire-server/restund.txt to my-wire-serwer/secrets.yaml under `brig.secrets.turn.secret` -2. add **both** the public and private parts from zauth.txt to secrets.yaml under `brig.secrets.zAuth` -3. Add the public key from zauth.txt to secrets.yaml under `nginz.secrets.zAuth.publicKeys` +1. Add the generated secret from `my-wire-server/restund.txt` to `my-wire-server/secrets.yaml` under `brig.secrets.turn.secret`. +2. add **both** the public and private parts from `my-wire-server/zauth.txt` to `my-wire-server/secrets.yaml` under `brig.secrets.zAuth`. +3. Add the public key from `my-wire-server/zauth.txt` to `my-wire-server/secrets.yaml` under `nginz.secrets.zAuth.publicKeys`. +4. Add the generated secret from my-wire-server/rabbitmq-password to `my-wire-server/secerts.yaml` under `brig.secrets.rabbitmq.password` and `background-worker.secrets.rabbitmq.password`. Great, now try the installation: diff --git a/docs/src/how-to/install/post-install.md b/docs/src/how-to/install/post-install.md index f04d9157a8..316609ff45 100644 --- a/docs/src/how-to/install/post-install.md +++ b/docs/src/how-to/install/post-install.md @@ -54,7 +54,7 @@ What should you do if this is the case? Ensure that `ntp` is installed and that ## Logs and Data Protection checks -On Wire.com, we keep logs for a maximum of 72 hours as described in the [privacy whitepaper](https://wire.com/en/security/) +On Wire.com, we keep logs for a maximum of 72 hours as described in the [privacy whitepaper](https://wire-docs.wire.com/download/Wire+Privacy+Whitepaper.pdf). We recommend you do the same and limit the amount of logs kept on your servers. diff --git a/docs/src/understand/api-client-perspective/swagger.md b/docs/src/understand/api-client-perspective/swagger.md index 3c9da8b96f..02d45a7ddb 100644 --- a/docs/src/understand/api-client-perspective/swagger.md +++ b/docs/src/understand/api-client-perspective/swagger.md @@ -1,3 +1,5 @@ +(swagger-api-docs)= + # Swagger API documentation Our staging system provides [Swagger / diff --git a/hack/bin/cabal-run-integration.sh b/hack/bin/cabal-run-integration.sh index 9a808849cb..3db62ebab0 100755 --- a/hack/bin/cabal-run-integration.sh +++ b/hack/bin/cabal-run-integration.sh @@ -47,7 +47,7 @@ run_integration_tests() { then cd "$TOP_LEVEL" "$TOP_LEVEL/services/run-services" \ - "$TOP_LEVEL/dist/integration" + "$TOP_LEVEL/dist/integration" \ "${@:2}" else service_dir="$TOP_LEVEL/services/$package" diff --git a/hack/bin/create_team.sh b/hack/bin/create_team.sh new file mode 100755 index 0000000000..aa672a8594 --- /dev/null +++ b/hack/bin/create_team.sh @@ -0,0 +1,67 @@ +#!/usr/bin/env bash +# +# consider using create_team.py + +set -o pipefail +set -o errexit + +BRIG_HOST="http://localhost:8080" +OWNER_NAME="owner name n/a" +OWNER_EMAIL="owner email n/a" +OWNER_PASSWORD="owner pass n/a" +EMAIL_CODE="email code n/a" +TEAM_NAME="team name n/a" +TEAM_CURRENCY="USD" + +USAGE=" +Request a code to create a team. Call ./create_test_team_members.sh +first, then use the code you will receive by email to call this script. + +USAGE: $0 -h -o -e -p -v -t -c + -h : Base URI of brig. default: ${BRIG_HOST} + -o : user display name of the owner of the team to be created. default: ${OWNER_NAME} + -e : email address of the owner of the team to be created. default: ${OWNER_EMAIL} + -p : owner password. default: ${OWNER_PASSWORD} + -v : validation code received by email. default: ${EMAIL_CODE} + -t : default: ${TEAM_NAME} + -c : default: ${TEAM_CURRENCY} + +" + +# Option parsing: +# https://sookocheff.com/post/bash/parsing-bash-script-arguments-with-shopts/ +while getopts ":o:e:p:v:t:c:h:" opt; do + case ${opt} in + o ) OWNER_NAME="$OPTARG" + ;; + e ) OWNER_EMAIL="$OPTARG" + ;; + p ) OWNER_PASSWORD="$OPTARG" + ;; + v ) EMAIL_CODE="$OPTARG" + ;; + t ) TEAM_NAME="$OPTARG" + ;; + c ) TEAM_CURRENCY="$OPTARG" + ;; + h ) BRIG_HOST="$OPTARG" + ;; + : ) echo "-$OPTARG" requires an argument 1>&2 + exit 1 + ;; + \? ) echo "$USAGE" 1>&2 + exit 1 + ;; + esac +done +shift $((OPTIND -1)) + +if [ "$#" -ne 0 ]; then + echo "$USAGE" 1>&2 + exit 1 +fi + +curl -i -s --show-error \ + -XPOST "$BRIG_HOST/register" \ + -H'Content-type: application/json' \ + -d'{"name":"'"$OWNER_NAME"'","email":"'"$OWNER_EMAIL"'","password":"'"$OWNER_PASSWORD"'","email_code":"'"$EMAIL_CODE"'","team":{"currency":"'"$TEAM_CURRENCY"'","icon":"default","name":"'"$TEAM_NAME"'"}}' diff --git a/hack/bin/create_team_members.sh b/hack/bin/create_team_members.sh new file mode 100755 index 0000000000..42740024dc --- /dev/null +++ b/hack/bin/create_team_members.sh @@ -0,0 +1,101 @@ +#!/usr/bin/env bash +# +# consider using create_team.py + +set -e + +ADMIN_UUID="n/a" +TEAM_UUID="n/a" +BRIG_HOST="http://localhost:8080" +CSV_FILE="n/a" + +USAGE=" +This bash script can be used to invite members to a given team. Input +is a csv file with email addresses and suggested user names. + +Note that this uses internal brig endpoints. It is not exposed over +nginz and can only be used if you have direct access to brig. + +USAGE: $0 + -a : User ID of the inviting admin. default: ${ADMIN_UUID} + -t : ID of the inviting team. default: ${TEAM_UUID} + -h : Base URI of brig. default: ${BRIG_HOST} + -c : file containing info on the invitees in format 'Email,UserName,Role'. default: ${CSV_FILE} + +If role is specified, it must be one of owner, admin, member, partner. +If it is missing, default is member. + +If you tee(1) stdout, stderr of this script into a log file, you can +grep that log file for errors like this: + +$ grep code out.log | grep email-exists # the most common case +$ grep code out.log | grep -v email-exists + +If you are in a hurry, you may want to change the sleep(1) at the end +of the invite loop to less than a second. If you want to give up on +the first error, add an exit(1) where we check the $INVIDATION_ID. + +" + +# Option parsing: +# https://sookocheff.com/post/bash/parsing-bash-script-arguments-with-shopts/ +while getopts ":a:t:h:c:" opt; do + case ${opt} in + a ) ADMIN_UUID="$OPTARG" + ;; + t ) TEAM_UUID="$OPTARG" + ;; + h ) BRIG_HOST="$OPTARG" + ;; + c ) CSV_FILE="$OPTARG" + ;; + : ) echo "-$OPTARG" requires an argument 1>&2 + exit 1 + ;; + \? ) echo "$USAGE" 1>&2 + exit 1 + ;; + esac +done +shift $((OPTIND -1)) + +if [ "$#" -ne 0 ]; then + echo "$USAGE" 1>&2 + exit 1 +fi + +if [ ! -e "$CSV_FILE" ]; then + echo -e "\n\n*** I need the name of an existing csv file.\n\n" + echo "$USAGE" 1>&2 + exit 1 +fi + +# Generate users +while IFS=, read -r EMAIL USER_NAME ROLE +do + if ( echo "$ROLE" | grep -vq "\(owner\|admin\|member\|partner\)" ); then + export ROLE=member + fi + + echo "inviting $USER_NAME <$EMAIL> with role $ROLE..." 1>&2 + + # Generate the invitation + CURL_OUT_INVITATION=$(curl -i -s --show-error \ + -XPOST "$BRIG_HOST/teams/$TEAM_UUID/invitations" \ + -H'Content-type: application/json' \ + -H'Z-User: '"$ADMIN_UUID"'' \ + -d'{"email":"'"$EMAIL"'","name":"'"$USER_NAME"'","role":"'"$ROLE"'"}') + + INVITATION_ID=$(echo "$CURL_OUT_INVITATION" | tail -1 | sed 's/.*\"id\":\"\([a-z0-9-]*\)\".*/\1/') + + echo "Created the invitation, sleeping 1 second..." 1>&2 + sleep 1 + + if ( ( echo "$INVITATION_ID" | grep -q '"code"' ) && + ( echo "$INVITATION_ID" | grep -q '"label"' ) ) ; then + echo "failed inviting $USER_NAME <$EMAIL>: $INVITATION_ID" + fi + + echo "Sleeping 1 second..." 1>&2 + sleep 1 +done < "$CSV_FILE" diff --git a/hack/bin/create_team_request_code.sh b/hack/bin/create_team_request_code.sh new file mode 100755 index 0000000000..6e6d85d1d1 --- /dev/null +++ b/hack/bin/create_team_request_code.sh @@ -0,0 +1,46 @@ +#!/usr/bin/env bash +# +# consider using create_team.py + +set -o pipefail +set -o errexit + +BRIG_HOST="http://localhost:8080" +OWNER_EMAIL="owner email n/a" + +USAGE=" +Request a code to create a team. Call this script first, then use the +code you will receive by email to call ./create_team.sh + +USAGE: $0 -h -e + -h : Base URI of brig. default: ${BRIG_HOST} + -e : email address of the owner of the team to be created. default: ${OWNER_EMAIL} + +" + +# Option parsing: +while getopts ":e:h:" opt; do + case ${opt} in + e ) OWNER_EMAIL="$OPTARG" + ;; + h ) BRIG_HOST="$OPTARG" + ;; + : ) echo "-$OPTARG" requires an argument 1>&2 + exit 1 + ;; + \? ) echo "$USAGE" 1>&2 + exit 1 + ;; + esac +done +shift $((OPTIND -1)) + +if [ "$#" -ne 0 ]; then + echo "$USAGE" 1>&2 + exit 1 +fi + +curl -i -s --show-error \ + -XPOST "$BRIG_HOST/activate/send" \ + -H'Content-type: application/json' \ + -d'{"email":"'"$OWNER_EMAIL"'"}' diff --git a/hack/bin/create_test_team_admins.sh b/hack/bin/create_test_team_admins.sh new file mode 100755 index 0000000000..e6af495131 --- /dev/null +++ b/hack/bin/create_test_team_admins.sh @@ -0,0 +1,68 @@ +#!/usr/bin/env bash +# +# consider using create_team.py + +set -e + +COUNT="1" +BRIG_HOST="http://localhost:8082" +CSV="false" + +USAGE=" +This bash script can be used to create active team admin users and +their teams. + +Note that this uses an internal brig endpoint. It is not exposed over +nginz and can only be used if you have direct access to brig. + +USAGE: $0 + -n : Create users. default: ${COUNT} + -h : Base URI of brig. default: ${BRIG_HOST} + -c: Output as headerless CSV in format 'User-Id,Email,Password'. default: ${CSV} +" + +# Option parsing: +# https://sookocheff.com/post/bash/parsing-bash-script-arguments-with-shopts/ +while getopts ":n:h:c" opt; do + case ${opt} in + n ) COUNT="$OPTARG" + ;; + h ) BRIG_HOST="$OPTARG" + ;; + c ) CSV="true" + ;; + : ) echo "-$OPTARG" requires an argument 1>&2 + exit 1 + ;; + \? ) echo "$USAGE" 1>&2 + exit 1 + ;; + esac +done +shift $((OPTIND -1)) + +if [ "$#" -ne 0 ]; then + echo "$USAGE" 1>&2 + exit 1 +fi + +# Generate users + +for i in $(seq 1 "$COUNT") +do + EMAIL=$(cat /dev/urandom | env LC_CTYPE=C tr -dc a-zA-Z0-9 | head -c 8)"@example.com" + PASSWORD=$(cat /dev/urandom | env LC_CTYPE=C tr -dc a-zA-Z0-9 | head -c 8) + + CURL_OUT=$(curl -i -s --show-error \ + -XPOST "$BRIG_HOST/i/users" \ + -H'Content-type: application/json' \ + -d'{"email":"'"$EMAIL"'","password":"'"$PASSWORD"'","name":"demo","team":{"name":"Wire team","icon":"default"}}') + + UUID=$(echo "$CURL_OUT" | tail -1 | sed 's/.*\"id\":\"\([a-z0-9-]*\)\".*/\1/') + TEAM=$(echo "$CURL_OUT" | tail -1 | sed 's/.*\"team\":\"\([a-z0-9-]*\)\".*/\1/') + + if [ "$CSV" == "false" ] + then echo -e "Succesfully created a team admin user: $UUID on team: $TEAM with email: $EMAIL and password: $PASSWORD" + else echo -e "$UUID,$EMAIL,$PASSWORD" + fi +done diff --git a/hack/bin/create_test_team_members.sh b/hack/bin/create_test_team_members.sh new file mode 100755 index 0000000000..6a55f4a1b0 --- /dev/null +++ b/hack/bin/create_test_team_members.sh @@ -0,0 +1,139 @@ +#!/usr/bin/env bash +# +# consider using create_team.py (you'll have to evolve it a little further to cover this use case, though) + +set -e + +ADMIN_UUID="a09e9521-e14e-4285-ad71-47caa97f4a16" +TEAM_UUID="9e57a378-0dca-468f-9661-7872f5f1c910" +BRIG_HOST="http://localhost:8082" +START="1" +COUNT="1" +CSV="false" +TARGET_EMAIL_DOMAIN="" + +USAGE="This bash script can be used to create active members in a +given team. Every member will have an email address of the form +'w@${TARGET_EMAIL_DOMAIN}', and will have to change that +(after logging in with the password provided to the user from the +output of this script). + +Note that this uses internal brig endpoints. It is not exposed over +nginz and can only be used if you have direct access to brig. + +USAGE: $0 -d [OPTIONS...] + -d : Domain part of the emails that the bogus + invitations are sent to. No default, you need + to provide that. Consider 'example.com', or an + internal domain you control. + + WARNING: This may boost your reputation as a + spammer. Use with care! + + -a : User ID of the inviting admin. default: ${ADMIN_UUID} + -t : ID of the inviting team. default: ${TEAM_UUID} + -s : Start at offset. default: ${START} + -n : Create users. default: ${COUNT} + -h : Base URI of brig. default: ${BRIG_HOST} + -c: Output as headerless CSV in format 'User-Id,Email,Password'. default: ${CSV} +" + +# Option parsing: +# https://sookocheff.com/post/bash/parsing-bash-script-arguments-with-shopts/ +while getopts ":a:t:s:n:h:d:c" opt; do + case ${opt} in + a ) ADMIN_UUID="$OPTARG" + ;; + t ) TEAM_UUID="$OPTARG" + ;; + s ) START="$OPTARG" + ;; + n ) COUNT="$OPTARG" + ;; + h ) BRIG_HOST="$OPTARG" + ;; + d ) TARGET_EMAIL_DOMAIN="$OPTARG" + ;; + c ) CSV="true" + ;; + : ) echo "-$OPTARG" requires an argument 1>&2 + exit 1 + ;; + \? ) echo "$USAGE" 1>&2 + exit 1 + ;; + esac +done +shift $((OPTIND -1)) + +if [ "$#" -ne 0 ]; then + echo "$USAGE" 1>&2 + exit 1 +fi + +# Warn about sending emails + +if [ "$TARGET_EMAIL_DOMAIN" == "" ]; then + echo -e "\n\n*** Please provide an email domain if you want to run this script.\n\n" + echo "$USAGE" 1>&2 + exit 1 +fi + +# Generate users +END=$((COUNT + START - 1)) +for i in $(seq "$START" "$END") +do + EMAIL='w'$(printf "%03d" "$i")"@$TARGET_EMAIL_DOMAIN" + PASSWORD=$(cat /dev/urandom | env LC_CTYPE=C tr -dc a-zA-Z0-9 | head -c 8) + + # Generate the invitation + + CURL_OUT_INVITATION=$(curl -i -s --show-error \ + -XPOST "$BRIG_HOST/teams/$TEAM_UUID/invitations" \ + -H'Content-type: application/json' \ + -H'Z-User: '"$ADMIN_UUID"'' \ + -d'{"email":"'"$EMAIL"'","name":"Replace with name","inviter_name":"Team admin"}') + + INVITATION_ID=$(echo "$CURL_OUT_INVITATION" | tail -1 | sed 's/.*\"id\":\"\([a-z0-9-]*\)\".*/\1/') + + echo "Created the invitation, sleeping 1 second..." 1>&2 + sleep 1 + + if ( ( echo "$INVITATION_ID" | grep -q '"code"' ) && + ( echo "$INVITATION_ID" | grep -q '"label"' ) ) ; then + echo "Got an error while creating $EMAIL, aborting: $INVITATION_ID" + exit 1 + fi + + # Get the code + CURL_OUT_INVITATION_CODE=$(curl -i -s --show-error \ + -XGET "$BRIG_HOST/i/teams/invitation-code?team=$TEAM_UUID&invitation_id=$INVITATION_ID") + + INVITATION_CODE=$(echo "$CURL_OUT_INVITATION_CODE" | tail -1 | sed -n -e '/"code":/ s/^.*"\(.*\)".*/\1/p') + + echo "Got the code, sleeping 1 second..." 1>&2 + sleep 1 + + # Create the user using that code + CURL_OUT=$(curl -i -s --show-error \ + -XPOST "$BRIG_HOST/i/users" \ + -H'Content-type: application/json' \ + -d'{"email":"'"$EMAIL"'","password":"'"$PASSWORD"'","name":"demo","team_code":"'"$INVITATION_CODE"'"}') + + TEAM_MEMBER_UUID=$(echo "$CURL_OUT" | tail -1 | sed 's/.*\"id\":\"\([a-z0-9-]*\)\".*/\1/') + TEAM=$(echo "$CURL_OUT" | tail -1 | sed 's/.*\"team\":\"\([a-z0-9-]*\)\".*/\1/') + + if [ "$TEAM" != "$TEAM_UUID" ]; then + echo "unexpected error: user got assigned to no / the wrong team?!" + echo ${CURL_OUT} + exit 1 + fi + + if [ "$CSV" == "false" ] + then echo -e "Succesfully created a team member: $TEAM_MEMBER_UUID on team: $TEAM_UUID with email: $EMAIL and password: $PASSWORD" + else echo -e "$UUID,$EMAIL,$PASSWORD" + fi + + echo "Sleeping 1 second..." 1>&2 + sleep 1 +done diff --git a/hack/bin/create_test_user.sh b/hack/bin/create_test_user.sh new file mode 100755 index 0000000000..18d3435ad1 --- /dev/null +++ b/hack/bin/create_test_user.sh @@ -0,0 +1,66 @@ +#!/usr/bin/env bash +# +# consider using create_team.py + +set -e + +# +# This bash script can be used to create an active user by using an internal +# brig endpoint. Note that this is not exposed over nginz and can only be used +# if you have direct access to brig +# + +USAGE="USAGE: $0 + -n : Create users. default: 1 + -h : Base URI of brig. default: http://localhost:8082 + -c: Output as headerless CSV in format 'User-Id,Email,Password'. default: false +" + +BRIG_HOST="http://localhost:8082" +COUNT="1" +CSV="false" + +# Option parsing: +# https://sookocheff.com/post/bash/parsing-bash-script-arguments-with-shopts/ +while getopts ":n:h:c" opt; do + case ${opt} in + n ) COUNT="$OPTARG" + ;; + h ) BRIG_HOST="$OPTARG" + ;; + c ) CSV="true" + ;; + : ) echo "-$OPTARG" requires an argument 1>&2 + exit 1 + ;; + \? ) echo "$USAGE" 1>&2 + exit 1 + ;; + esac +done +shift $((OPTIND -1)) + +if [ "$#" -ne 0 ]; then + echo "$USAGE" 1>&2 + exit 1 +fi; + +# Generate users + +for i in `seq 1 $COUNT` +do + EMAIL=$(cat /dev/urandom | env LC_CTYPE=C tr -dc a-zA-Z0-9 | head -c 8)"@example.com" + PASSWORD=$(cat /dev/urandom | env LC_CTYPE=C tr -dc a-zA-Z0-9 | head -c 8) + + CURL_OUT=$(curl -i -s --show-error \ + -XPOST "$BRIG_HOST/i/users" \ + -H'Content-type: application/json' \ + -d'{"email":"'$EMAIL'","password":"'$PASSWORD'","name":"demo"}') + + UUID=$(echo "$CURL_OUT" | tail -1 | sed 's/.*\"id\":\"\([a-z0-9-]*\)\".*/\1/') + + if [ "$CSV" == "false" ] + then echo -e "Succesfully created a user with email: "$EMAIL" and password: "$PASSWORD + else echo -e $UUID","$EMAIL","$PASSWORD + fi +done diff --git a/hack/bin/integration-setup.sh b/hack/bin/integration-setup.sh deleted file mode 100755 index 29e3fa7c50..0000000000 --- a/hack/bin/integration-setup.sh +++ /dev/null @@ -1,52 +0,0 @@ -#!/usr/bin/env bash - -set -euo pipefail - -DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" -TOP_LEVEL="$DIR/../.." -export NAMESPACE=${NAMESPACE:-test-integration} -HELMFILE_ENV=${HELMFILE_ENV:-default} -CHARTS_DIR="${TOP_LEVEL}/.local/charts" -HELM_PARALLELISM=${HELM_PARALLELISM:-1} - -. "$DIR/helm_overrides.sh" - -"${DIR}/integration-cleanup.sh" - -echo "updating recursive dependencies ..." -charts=(fake-aws databases-ephemeral redis-cluster rabbitmq wire-server ingress-nginx-controller nginx-ingress-controller nginx-ingress-services) -mkdir -p ~/.parallel && touch ~/.parallel/will-cite -printf '%s\n' "${charts[@]}" | parallel -P "${HELM_PARALLELISM}" "$DIR/update.sh" "$CHARTS_DIR/{}" - -KUBERNETES_VERSION_MAJOR="$(kubectl version -o json | jq -r .serverVersion.major)" -KUBERNETES_VERSION_MINOR="$(kubectl version -o json | jq -r .serverVersion.minor)" -KUBERNETES_VERSION_MINOR="${KUBERNETES_VERSION_MINOR//[!0-9]/}" # some clusters report minor versions as a string like '27+'. Strip any non-digit characters. -export KUBERNETES_VERSION="$KUBERNETES_VERSION_MAJOR.$KUBERNETES_VERSION_MINOR" -if (( KUBERNETES_VERSION_MAJOR > 1 || KUBERNETES_VERSION_MAJOR == 1 && KUBERNETES_VERSION_MINOR >= 23 )); then - export INGRESS_CHART="ingress-nginx-controller" -else - export INGRESS_CHART="nginx-ingress-controller" -fi -echo "kubeVersion: $KUBERNETES_VERSION and ingress controller=$INGRESS_CHART" -echo "Generating self-signed certificates..." -export FEDERATION_DOMAIN_BASE="$NAMESPACE.svc.cluster.local" -export FEDERATION_DOMAIN="federation-test-helper.$FEDERATION_DOMAIN_BASE" -"$DIR/selfsigned-kubernetes.sh" namespace1 - -echo "Installing charts..." - -helmfile --environment "$HELMFILE_ENV" --file "${TOP_LEVEL}/hack/helmfile-single.yaml" sync - -# wait for fakeSNS to create resources. TODO, cleaner: make initiate-fake-aws-sns a post hook. See cassandra-migrations chart for an example. -resourcesReady() { - SNS_POD=$(kubectl -n "${NAMESPACE}" get pods | grep fake-aws-sns | grep Running | awk '{print $1}') - kubectl -n "${NAMESPACE}" logs "$SNS_POD" -c initiate-fake-aws-sns | grep created -} -until resourcesReady; do - echo 'waiting for SNS resources' - sleep 1 -done - -kubectl -n "${NAMESPACE}" get pods - -echo "done" diff --git a/hack/bin/integration-teardown.sh b/hack/bin/integration-teardown.sh deleted file mode 100755 index ec5b708f74..0000000000 --- a/hack/bin/integration-teardown.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env bash - -DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)" -TOP_LEVEL="$DIR/../.." - -NAMESPACE=${NAMESPACE:-test-integration} -# doesn't matter for destruction but needs to be set -export FEDERATION_DOMAIN="." -KUBERNETES_VERSION_MAJOR="$(kubectl version -o json | jq -r .serverVersion.major)" -KUBERNETES_VERSION_MINOR="$(kubectl version -o json | jq -r .serverVersion.minor)" -KUBERNETES_VERSION_MINOR="${KUBERNETES_VERSION_MINOR//[!0-9]/}" # some clusters report minor versions as a string like '27+'. Strip any non-digit characters. -if (( KUBERNETES_VERSION_MAJOR > 1 || KUBERNETES_VERSION_MAJOR == 1 && KUBERNETES_VERSION_MINOR >= 23 )); then - export INGRESS_CHART="ingress-nginx-controller" -else - export INGRESS_CHART="nginx-ingress-controller" -fi - -set -ex - -. "$DIR/helm_overrides.sh" -helmfile --file "${TOP_LEVEL}/hack/helmfile-single.yaml" destroy diff --git a/hack/bin/set-wire-server-image-version.sh b/hack/bin/set-wire-server-image-version.sh index a471a7cb39..5277b69927 100755 --- a/hack/bin/set-wire-server-image-version.sh +++ b/hack/bin/set-wire-server-image-version.sh @@ -6,7 +6,7 @@ target_version=${1?$USAGE} TOP_LEVEL="$( cd "$( dirname "${BASH_SOURCE[0]}" )/../.." && pwd )" CHARTS_DIR="$TOP_LEVEL/.local/charts" -charts=(brig cannon galley gundeck spar cargohold proxy cassandra-migrations elasticsearch-index federator backoffice integration) +charts=(brig cannon galley gundeck spar cargohold proxy cassandra-migrations elasticsearch-index federator backoffice background-worker integration) for chart in "${charts[@]}"; do sed -i "s/^ tag: .*/ tag: $target_version/g" "$CHARTS_DIR/$chart/values.yaml" diff --git a/hack/helm_vars/nginx-ingress-services/values.yaml.gotmpl b/hack/helm_vars/nginx-ingress-services/values.yaml.gotmpl index fd80c5ca43..47f5d5cd30 100644 --- a/hack/helm_vars/nginx-ingress-services/values.yaml.gotmpl +++ b/hack/helm_vars/nginx-ingress-services/values.yaml.gotmpl @@ -17,7 +17,7 @@ config: fakeS3: assets.integration.example.com teamSettings: teams.integration.example.com accountPages: account.integration.example.com - # federator: dynamically set by hack/bin/integration-setup.sh + # federator: dynamically set by hack/helmfile.yaml # secrets/tlsWildcardCert, secrets/tlsWildcardKey and secrets/tlsClientCA # are dynamically generated by hack/bin/selfsigned-kubernetes.sh diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index bb92bc56e0..458dcea435 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -300,3 +300,16 @@ federator: federationStrategy: allowAll: true useSystemCAStore: false + +background-worker: + replicaCount: 1 + resources: + requests: {} + imagePullPolicy: {{ .Values.imagePullPolicy }} + config: + # See helmfile for the real value + remoteDomains: [] + secrets: + rabbitmq: + username: {{ .Values.rabbitmqUsername }} + password: {{ .Values.rabbitmqPassword }} diff --git a/hack/helmfile-single.yaml b/hack/helmfile-single.yaml deleted file mode 100644 index bb9f4f5b2f..0000000000 --- a/hack/helmfile-single.yaml +++ /dev/null @@ -1,81 +0,0 @@ -# This helmfile is similar to the 'helmfile.yaml', but only spawns up components for a single backend. -# In some situations (when not testing anything federation specific), use of a single backend is sufficient. -# -# The 'make kube-integration-setup-sans-federation' target uses this helmfile. - -helmDefaults: - wait: true - timeout: 600 - devel: true - -environments: - default: - values: - - namespace: {{ requiredEnv "NAMESPACE" }} - - federationDomain: {{ requiredEnv "FEDERATION_DOMAIN" }} - - ingressChart: {{ requiredEnv "INGRESS_CHART" }} - - imagePullPolicy: Always - - redisStorageClass: hcloud-volumes - -repositories: - - name: stable - url: 'https://charts.helm.sh/stable' - - - name: bitnami - url: 'https://charts.bitnami.com/bitnami' - -releases: - - name: '{{ .Values.namespace }}-fake-aws' - namespace: '{{ .Values.namespace }}' - chart: '../.local/charts/fake-aws' - values: - - './helm_vars/fake-aws/values.yaml' - - - name: '{{ .Values.namespace }}-databases-ephemeral' - namespace: '{{ .Values.namespace }}' - chart: '../.local/charts/databases-ephemeral' - - - name: '{{ .Values.namespace }}-redis-cluster' - namespace: '{{ .Values.namespace }}' - chart: '../.local/charts/redis-cluster' - values: - - './helm_vars/redis-cluster/values.yaml.gotmpl' - - - name: '{{ .Values.namespace }}-ic' - namespace: '{{ .Values.namespace }}' - chart: '../.local/charts/{{ .Values.ingressChart }}' - values: - - './helm_vars/{{ .Values.ingressChart }}/values.yaml.gotmpl' - - - name: '{{ .Values.namespace }}-i' - namespace: '{{ .Values.namespace }}' - chart: '../.local/charts/nginx-ingress-services' - values: - - './helm_vars/nginx-ingress-services/values.yaml.gotmpl' - - './helm_vars/nginx-ingress-services/certificates-namespace1.yaml' - set: - # Federation domain is also the SRV record created by the - # federation-test-helper service. Maybe we can find a way to make these - # differ, so we don't make any silly assumptions in the code. - - name: config.dns.federator - value: {{ .Values.federationDomain }} - needs: - - '{{ .Values.namespace }}-ic' - - # Note that wire-server depends on databases-ephemeral being up; and in some - # cases on nginx-ingress also being up. If installing helm charts in a - # parallel way, it's expected to see some wire-server pods (namely the - # cassandra-migration one) fail and get restarted a few times) - - name: '{{ .Values.namespace }}-wire-server' - namespace: '{{ .Values.namespace }}' - chart: '../.local/charts/wire-server' - values: - - './helm_vars/wire-server/values.yaml.gotmpl' - - './helm_vars/wire-server/certificates-namespace1.yaml' - set: - - name: brig.config.optSettings.setFederationDomain - value: {{ .Values.federationDomain }} - - name: galley.config.settings.federationDomain - value: {{ .Values.federationDomain }} - - name: cargohold.config.settings.federationDomain - value: {{ .Values.federationDomain }} diff --git a/hack/helmfile.yaml b/hack/helmfile.yaml index 444bfa031d..d54d67d436 100644 --- a/hack/helmfile.yaml +++ b/hack/helmfile.yaml @@ -141,6 +141,9 @@ releases: value: {{ .Values.federationDomain1 }} - name: brig.config.optSettings.setFederationDomainConfigs[0].domain value: {{ .Values.federationDomain2 }} + - name: background-worker.config.remoteDomains + values: + - {{ .Values.federationDomain2 }} needs: - 'databases-ephemeral' @@ -159,5 +162,8 @@ releases: value: {{ .Values.federationDomain2 }} - name: brig.config.optSettings.setFederationDomainConfigs[0].domain value: {{ .Values.federationDomain1 }} + - name: background-worker.config.remoteDomains + values: + - {{ .Values.federationDomain1 }} needs: - 'databases-ephemeral' diff --git a/integration/Setup.hs b/integration/Setup.hs index 33276dca90..cfb2d5327d 100644 --- a/integration/Setup.hs +++ b/integration/Setup.hs @@ -71,7 +71,7 @@ collectDescription revLines = let comments = reverse (map stripHaddock (takeWhile isComment revLines)) in case uncons comments of Nothing -> ("", "") - Just (summary, _) -> (summary, unlines comments) + Just (summary, rest) -> (summary, unlines (dropWhile null rest)) isComment :: String -> Bool isComment ('-' : '-' : _) = True @@ -111,14 +111,12 @@ testHooks hooks = dest ( unlines [ "module RunAllTests where", - "import Testlib.Types", + "import Testlib.PTest", "import Prelude", unlines (map ("import qualified " <>) modules), - "allTests :: [(String, String, String, String, App ())]", + "allTests :: [Test]", "allTests =", - " [", - " " <> intercalate ",\n " (map (\(m, n, s, f) -> "(" <> intercalate ", " [show m, show n, show s, show f, m <> "." <> n] <> ")") tests), - " ]" + " " <> intercalate " <>\n " (map (\(m, n, s, f) -> "mkTests " <> unwords [show m, show n, show s, show f, m <> "." <> n]) tests) ] ) pure () diff --git a/integration/default.nix b/integration/default.nix index 6ada6449f7..ceec8be2ed 100644 --- a/integration/default.nix +++ b/integration/default.nix @@ -8,6 +8,7 @@ , array , async , base +, base64-bytestring , bytestring , bytestring-conversion , Cabal @@ -18,8 +19,10 @@ , exceptions , filepath , gitignoreSource +, hex , http-client , http-types +, kan-extensions , lib , mtl , network @@ -34,10 +37,13 @@ , stm , string-conversions , tagged +, temporary , text , time , transformers +, unix , unliftio +, uuid , websockets , yaml }: @@ -54,6 +60,7 @@ mkDerivation { array async base + base64-bytestring bytestring bytestring-conversion case-insensitive @@ -62,8 +69,10 @@ mkDerivation { directory exceptions filepath + hex http-client http-types + kan-extensions mtl network network-uri @@ -77,10 +86,13 @@ mkDerivation { stm string-conversions tagged + temporary text time transformers + unix unliftio + uuid websockets yaml ]; diff --git a/integration/integration.cabal b/integration/integration.cabal index b363f1e341..7f44a07840 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -25,6 +25,7 @@ common common-all -optP-Wno-nonportable-include-path default-extensions: + NoImplicitPrelude AllowAmbiguousTypes BangPatterns ConstraintKinds @@ -84,6 +85,7 @@ library API.Common API.Galley API.GalleyInternal + MLS.Util RunAllTests SetupHelpers Test.B2B @@ -101,6 +103,7 @@ library Testlib.Prekeys Testlib.Prelude Testlib.Printing + Testlib.PTest Testlib.Run Testlib.Types @@ -110,6 +113,7 @@ library , array , async , base + , base64-bytestring , bytestring , bytestring-conversion , case-insensitive @@ -118,8 +122,10 @@ library , directory , exceptions , filepath + , hex , http-client , http-types + , kan-extensions , mtl , network , network-uri @@ -133,9 +139,12 @@ library , stm , string-conversions , tagged + , temporary , text , time , transformers + , unix , unliftio + , uuid , websockets , yaml diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index 2163a22060..9a1adb1f0f 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -1,8 +1,10 @@ module API.Brig where import API.Common +import qualified Data.ByteString.Base64 as Base64 +import Data.Foldable import Data.Function -import Data.Maybe +import qualified Data.Text.Encoding as T import GHC.Stack import Testlib.Prelude @@ -49,21 +51,51 @@ addClient user args = do "password" .= args.password ] +data UpdateClient = UpdateClient + { prekeys :: [Value], + lastPrekey :: Maybe Value, + label :: Maybe String, + capabilities :: Maybe [Value], + mlsPublicKeys :: Maybe Value + } + +instance Default UpdateClient where + def = + UpdateClient + { prekeys = [], + lastPrekey = Nothing, + label = Nothing, + capabilities = Nothing, + mlsPublicKeys = Nothing + } + +updateClient :: + HasCallStack => + ClientIdentity -> + UpdateClient -> + App Response +updateClient cid args = do + req <- baseRequest cid Brig Versioned $ "/clients/" <> cid.client + submit "PUT" $ + req + & addJSONObject + ( ["prekeys" .= args.prekeys] + <> ["lastkey" .= k | k <- toList args.lastPrekey] + <> ["label" .= l | l <- toList args.label] + <> ["capabilities" .= c | c <- toList args.capabilities] + <> ["mls_public_keys" .= k | k <- toList args.mlsPublicKeys] + ) + deleteClient :: (HasCallStack, MakesValue user, MakesValue client) => user -> - Maybe String -> client -> App Response -deleteClient user mconn client = do - let conn = fromMaybe "0" mconn - uid <- objId user +deleteClient user client = do cid <- objId client req <- baseRequest user Brig Versioned $ "/clients/" <> cid submit "DELETE" $ req - & zUser uid - & zConnection conn & addJSONObject [ "password" .= defPassword ] @@ -78,13 +110,7 @@ searchContacts :: searchContacts searchingUserId searchTerm = do req <- baseRequest searchingUserId Brig Versioned "/search/contacts" q <- asString searchTerm - uid <- objId searchingUserId - submit - "GET" - ( req - & addQueryParams [("q", q)] - & zUser uid - ) + submit "GET" (req & addQueryParams [("q", q)]) getAPIVersion :: (HasCallStack, MakesValue domain) => domain -> App Response getAPIVersion domain = do @@ -100,17 +126,11 @@ postConnection :: userTo -> App Response postConnection userFrom userTo = do - uidFrom <- objId userFrom (userToDomain, userToId) <- objQid userTo req <- baseRequest userFrom Brig Versioned $ joinHttpPath ["/connections", userToDomain, userToId] - submit - "POST" - ( req - & zUser uidFrom - & zConnection "conn" - ) + submit "POST" req putConnection :: ( HasCallStack, @@ -123,17 +143,28 @@ putConnection :: status -> App Response putConnection userFrom userTo status = do - uidFrom <- objId userFrom (userToDomain, userToId) <- objQid userTo req <- baseRequest userFrom Brig Versioned $ joinHttpPath ["/connections", userToDomain, userToId] statusS <- asString status + submit "POST" (req & addJSONObject ["status" .= statusS]) + +uploadKeyPackage :: ClientIdentity -> ByteString -> App Response +uploadKeyPackage cid kp = do + req <- + baseRequest cid Brig Versioned $ + "/mls/key-packages/self/" <> cid.client submit "POST" ( req - & zUser uidFrom - & zConnection "conn" - & contentTypeJSON - & addJSONObject ["status" .= statusS] + & addJSONObject ["key_packages" .= [T.decodeUtf8 (Base64.encode kp)]] ) + +claimKeyPackages :: (MakesValue u, MakesValue v) => u -> v -> App Response +claimKeyPackages u v = do + (targetDom, targetUid) <- objQid v + req <- + baseRequest u Brig Versioned $ + "/mls/key-packages/claim/" <> targetDom <> "/" <> targetUid + submit "POST" req diff --git a/integration/test/API/BrigInternal.hs b/integration/test/API/BrigInternal.hs index 1e73f4366c..77201aa09d 100644 --- a/integration/test/API/BrigInternal.hs +++ b/integration/test/API/BrigInternal.hs @@ -43,3 +43,30 @@ createUser domain cu = do | cu.team ] ) + +registerOAuthClient :: (HasCallStack, MakesValue user, MakesValue name, MakesValue url) => user -> name -> url -> App Response +registerOAuthClient user name url = do + req <- baseRequest user Brig Unversioned "i/oauth/clients" + applicationName <- asString name + redirectUrl <- asString url + submit "POST" (req & addJSONObject ["application_name" .= applicationName, "redirect_url" .= redirectUrl]) + +getOAuthClient :: (HasCallStack, MakesValue user, MakesValue cid) => user -> cid -> App Response +getOAuthClient user cid = do + clientId <- objId cid + req <- baseRequest user Brig Unversioned $ "i/oauth/clients/" <> clientId + submit "GET" req + +updateOAuthClient :: (HasCallStack, MakesValue user, MakesValue cid, MakesValue name, MakesValue url) => user -> cid -> name -> url -> App Response +updateOAuthClient user cid name url = do + clientId <- objId cid + req <- baseRequest user Brig Unversioned $ "i/oauth/clients/" <> clientId + applicationName <- asString name + redirectUrl <- asString url + submit "PUT" (req & addJSONObject ["application_name" .= applicationName, "redirect_url" .= redirectUrl]) + +deleteOAuthClient :: (HasCallStack, MakesValue user, MakesValue cid) => user -> cid -> App Response +deleteOAuthClient user cid = do + clientId <- objId cid + req <- baseRequest user Brig Unversioned $ "i/oauth/clients/" <> clientId + submit "DELETE" req diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 355e0eefe0..6937210b53 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -53,25 +53,15 @@ instance MakesValue CreateConv where postConversation :: ( HasCallStack, - MakesValue user, - MakesValue client + MakesValue user ) => user -> - Maybe client -> CreateConv -> App Response -postConversation user mclient cc = do - uid <- objId user - domain <- objDomain user - mcid <- for mclient objId - req <- baseRequest domain Galley Versioned "/conversations" +postConversation user cc = do + req <- baseRequest user Galley Versioned "/conversations" ccv <- make cc - submit "POST" $ - req - & zUser uid - & maybe id zClient mcid - & zConnection "conn" - & addJSON ccv + submit "POST" $ req & addJSON ccv putConversationProtocol :: ( HasCallStack, @@ -89,13 +79,10 @@ putConversationProtocol user qcnv mclient protocol = do mclientId <- for mclient objId (domain, cnv) <- objQid qcnv p <- asString protocol - uid <- objId user req <- baseRequest user Galley Versioned (joinHttpPath ["conversations", domain, cnv, "protocol"]) submit "PUT" ( req - & zUser uid - & zConnection "conn" & maybe id zClient mclientId & addJSONObject ["protocol" .= p] ) @@ -110,10 +97,78 @@ getConversation :: App Response getConversation user qcnv = do (domain, cnv) <- objQid qcnv - uid <- objId user req <- baseRequest user Galley Versioned (joinHttpPath ["conversations", domain, cnv]) - submit - "GET" - ( req - & zUser uid - ) + submit "GET" req + +getSubConversation :: + ( HasCallStack, + MakesValue user, + MakesValue conv + ) => + user -> + conv -> + String -> + App Response +getSubConversation user conv sub = do + (cnvDomain, cnvId) <- objQid conv + req <- + baseRequest user Galley Versioned $ + joinHttpPath + [ "conversations", + cnvDomain, + cnvId, + "subconversations", + sub + ] + submit "GET" req + +getSelfConversation :: (HasCallStack, MakesValue user) => user -> App Response +getSelfConversation user = do + req <- baseRequest user Galley Versioned "/conversations/mls-self" + submit "GET" $ req + +data ListConversationIds = ListConversationIds {pagingState :: Maybe String, size :: Maybe Int} + +instance Default ListConversationIds where + def = ListConversationIds Nothing Nothing + +listConversationIds :: MakesValue user => user -> ListConversationIds -> App Response +listConversationIds user args = do + req <- baseRequest user Galley Versioned "/conversations/list-ids" + submit "POST" $ + req + & addJSONObject + ( ["paging_state" .= s | s <- toList args.pagingState] + <> ["size" .= s | s <- toList args.size] + ) + +listConversations :: MakesValue user => user -> [Value] -> App Response +listConversations user cnvs = do + req <- baseRequest user Galley Versioned "/conversations/list" + submit "POST" $ + req + & addJSONObject ["qualified_ids" .= cnvs] + +postMLSMessage :: HasCallStack => ClientIdentity -> ByteString -> App Response +postMLSMessage cid msg = do + req <- baseRequest cid Galley Versioned "/mls/messages" + submit "POST" (addMLS msg req) + +postMLSCommitBundle :: HasCallStack => ClientIdentity -> ByteString -> App Response +postMLSCommitBundle cid msg = do + req <- baseRequest cid Galley Versioned "/mls/commit-bundles" + submit "POST" (addMLS msg req) + +getGroupInfo :: + (HasCallStack, MakesValue user, MakesValue conv) => + user -> + conv -> + App Response +getGroupInfo user conv = do + (qcnv, mSub) <- objSubConv conv + (convDomain, convId) <- objQid qcnv + let path = joinHttpPath $ case mSub of + Nothing -> ["conversations", convDomain, convId, "groupinfo"] + Just sub -> ["conversations", convDomain, convId, "subconversations", sub, "groupinfo"] + req <- baseRequest user Galley Versioned path + submit "GET" req diff --git a/integration/test/API/GalleyInternal.hs b/integration/test/API/GalleyInternal.hs index 56e811626a..62b265fa9c 100644 --- a/integration/test/API/GalleyInternal.hs +++ b/integration/test/API/GalleyInternal.hs @@ -9,7 +9,7 @@ putTeamMember user team perms = do tid <- asString team req <- baseRequest - ownDomain + OwnDomain Galley Unversioned ("/i/teams/" <> tid <> "/members") @@ -31,5 +31,5 @@ putTeamMember user team perms = do getTeamFeature :: HasCallStack => String -> String -> App Response getTeamFeature featureName tid = do - req <- baseRequest ownDomain Galley Unversioned $ joinHttpPath ["i", "teams", tid, "features", featureName] + req <- baseRequest OwnDomain Galley Unversioned $ joinHttpPath ["i", "teams", tid, "features", featureName] submit "GET" $ req diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs new file mode 100644 index 0000000000..606914e3f4 --- /dev/null +++ b/integration/test/MLS/Util.hs @@ -0,0 +1,507 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + +module MLS.Util where + +import API.Brig +import API.Galley +import Control.Concurrent.Async hiding (link) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Cont +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as B8 +import Data.Default +import Data.Foldable +import Data.Function +import Data.Hex +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.Text.Encoding as T +import Data.Traversable +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUIDV4 +import GHC.Stack +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.IO.Temp +import System.Posix.Files +import System.Process +import Testlib.App +import Testlib.Assertions +import Testlib.Env +import Testlib.HTTP +import Testlib.JSON +import Testlib.Prelude + +mkClientIdentity :: (MakesValue u, MakesValue c) => u -> c -> App ClientIdentity +mkClientIdentity u c = do + (domain, user) <- objQid u + client <- c %. "id" & asString + pure $ ClientIdentity {domain = domain, user = user, client = client} + +cid2Str :: ClientIdentity -> String +cid2Str cid = cid.user <> ":" <> cid.client <> "@" <> cid.domain + +data MessagePackage = MessagePackage + { sender :: ClientIdentity, + message :: ByteString, + welcome :: Maybe ByteString, + groupInfo :: Maybe ByteString + } + +getConv :: App Value +getConv = do + mls <- getMLSState + case mls.convId of + Nothing -> assertFailure "Uninitialised test conversation" + Just convId -> pure convId + +toRandomFile :: ByteString -> App FilePath +toRandomFile bs = do + p <- randomFileName + liftIO $ BS.writeFile p bs + pure p + +randomFileName :: App FilePath +randomFileName = do + bd <- getBaseDir + (bd ) . UUID.toString <$> liftIO UUIDV4.nextRandom + +mlscli :: HasCallStack => ClientIdentity -> [String] -> Maybe ByteString -> App ByteString +mlscli cid args mbstdin = do + bd <- getBaseDir + let cdir = bd cid2Str cid + + groupOut <- randomFileName + let substOut = argSubst "" groupOut + + hasState <- hasClientGroupState cid + substIn <- + if hasState + then do + gs <- getClientGroupState cid + fn <- toRandomFile gs + pure (argSubst "" fn) + else pure id + + out <- + spawn + ( proc + "mls-test-cli" + ( ["--store", cdir "store"] + <> map (substIn . substOut) args + ) + ) + mbstdin + + groupOutWritten <- liftIO $ doesFileExist groupOut + when groupOutWritten $ do + gs <- liftIO (BS.readFile groupOut) + setClientGroupState cid gs + pure out + +argSubst :: String -> String -> String -> String +argSubst from to_ s = + if s == from then to_ else s + +createWireClient :: (MakesValue u, HasCallStack) => u -> App ClientIdentity +createWireClient u = do + lpk <- getLastPrekey + c <- addClient u def {lastPrekey = Just lpk} >>= getJSON 201 + mkClientIdentity u c + +initMLSClient :: HasCallStack => ClientIdentity -> App () +initMLSClient cid = do + bd <- getBaseDir + liftIO $ createDirectory (bd cid2Str cid) + void $ mlscli cid ["init", cid2Str cid] Nothing + +-- | Create new mls client and register with backend. +createMLSClient :: (MakesValue u, HasCallStack) => u -> App ClientIdentity +createMLSClient u = do + cid <- createWireClient u + initMLSClient cid + + -- set public key + pkey <- mlscli cid ["public-key"] Nothing + bindResponse + ( updateClient + cid + def + { mlsPublicKeys = + Just (object ["ed25519" .= T.decodeUtf8 (Base64.encode pkey)]) + } + ) + $ \resp -> resp.status `shouldMatchInt` 200 + pure cid + +-- | create and upload to backend +uploadNewKeyPackage :: HasCallStack => ClientIdentity -> App String +uploadNewKeyPackage cid = do + (kp, ref) <- generateKeyPackage cid + + -- upload key package + bindResponse (uploadKeyPackage cid kp) $ \resp -> + resp.status `shouldMatchInt` 201 + + pure ref + +generateKeyPackage :: HasCallStack => ClientIdentity -> App (ByteString, String) +generateKeyPackage cid = do + kp <- mlscli cid ["key-package", "create"] Nothing + ref <- B8.unpack . hex <$> mlscli cid ["key-package", "ref", "-"] (Just kp) + fp <- keyPackageFile cid ref + liftIO $ BS.writeFile fp kp + pure (kp, ref) + +-- | Create conversation and corresponding group. +setupMLSGroup :: HasCallStack => ClientIdentity -> App (String, Value) +setupMLSGroup cid = do + conv <- postConversation cid defMLS >>= getJSON 201 + groupId <- conv %. "group_id" & asString + convId <- conv %. "qualified_id" + createGroup cid conv + pure (groupId, convId) + +-- | Retrieve self conversation and create the corresponding group. +setupMLSSelfGroup :: HasCallStack => ClientIdentity -> App (String, Value) +setupMLSSelfGroup cid = do + conv <- getSelfConversation cid >>= getJSON 200 + conv %. "epoch" `shouldMatchInt` 0 + groupId <- conv %. "group_id" & asString + convId <- conv %. "qualified_id" + createGroup cid conv + pure (groupId, convId) + +createGroup :: MakesValue conv => ClientIdentity -> conv -> App () +createGroup cid conv = do + mls <- getMLSState + case mls.groupId of + Just _ -> assertFailure "only one group can be created" + Nothing -> pure () + resetGroup cid conv + +resetGroup :: MakesValue conv => ClientIdentity -> conv -> App () +resetGroup cid conv = do + convId <- make conv + groupId <- conv %. "group_id" & asString + modifyMLSState $ \s -> + s + { groupId = Just groupId, + convId = Just convId, + members = Set.singleton cid, + epoch = 0, + newMembers = mempty + } + resetClientGroup cid groupId + +resetClientGroup :: ClientIdentity -> String -> App () +resetClientGroup cid gid = do + removalKeyPath <- asks (.removalKeyPath) + groupJSON <- + mlscli + cid + [ "group", + "create", + "--removal-key", + removalKeyPath, + gid + ] + Nothing + setClientGroupState cid groupJSON + +keyPackageFile :: HasCallStack => ClientIdentity -> String -> App FilePath +keyPackageFile cid ref = do + bd <- getBaseDir + pure $ bd cid2Str cid ref + +unbundleKeyPackages :: Value -> App [(ClientIdentity, ByteString)] +unbundleKeyPackages bundle = do + let entryIdentity be = do + d <- be %. "domain" & asString + u <- be %. "user" & asString + c <- be %. "client" & asString + pure $ ClientIdentity {domain = d, user = u, client = c} + + bundleEntries <- bundle %. "key_packages" & asList + for bundleEntries $ \be -> do + kp64 <- be %. "key_package" & asString + kp <- assertOne . toList . Base64.decode . B8.pack $ kp64 + cid <- entryIdentity be + pure (cid, kp) + +-- | Claim keypackages and create a commit/welcome pair on a given client. +-- Note that this alters the state of the group immediately. If we want to test +-- a scenario where the commit is rejected by the backend, we can restore the +-- group to the previous state by using an older version of the group file. +createAddCommit :: HasCallStack => ClientIdentity -> [Value] -> App MessagePackage +createAddCommit cid users = do + kps <- fmap concat . for users $ \user -> do + bundle <- claimKeyPackages cid user >>= getJSON 200 + unbundleKeyPackages bundle + createAddCommitWithKeyPackages cid kps + +withTempKeyPackageFile :: ByteString -> ContT a App FilePath +withTempKeyPackageFile bs = do + bd <- lift getBaseDir + ContT $ \k -> + bracket + (liftIO (openBinaryTempFile bd "kp")) + (\(fp, _) -> liftIO (removeFile fp)) + $ \(fp, h) -> do + liftIO $ BS.hPut h bs `finally` hClose h + k fp + +createAddCommitWithKeyPackages :: + ClientIdentity -> + [(ClientIdentity, ByteString)] -> + App MessagePackage +createAddCommitWithKeyPackages cid clientsAndKeyPackages = do + bd <- getBaseDir + welcomeFile <- liftIO $ emptyTempFile bd "welcome" + giFile <- liftIO $ emptyTempFile bd "gi" + + commit <- runContT (traverse (withTempKeyPackageFile . snd) clientsAndKeyPackages) $ \kpFiles -> + mlscli + cid + ( [ "member", + "add", + "--group", + "", + "--welcome-out", + welcomeFile, + "--group-info-out", + giFile, + "--group-out", + "" + ] + <> kpFiles + ) + Nothing + + modifyMLSState $ \mls -> + mls + { newMembers = Set.fromList (map fst clientsAndKeyPackages) + } + + welcome <- liftIO $ BS.readFile welcomeFile + gi <- liftIO $ BS.readFile giFile + pure $ + MessagePackage + { sender = cid, + message = commit, + welcome = Just welcome, + groupInfo = Just gi + } + +createAddProposals :: HasCallStack => ClientIdentity -> [Value] -> App [MessagePackage] +createAddProposals cid users = do + bundles <- for users $ (claimKeyPackages cid >=> getJSON 200) + kps <- concat <$> traverse unbundleKeyPackages bundles + traverse (createAddProposalWithKeyPackage cid) kps + +createAddProposalWithKeyPackage :: + ClientIdentity -> + (ClientIdentity, ByteString) -> + App MessagePackage +createAddProposalWithKeyPackage cid (_, kp) = do + prop <- runContT (withTempKeyPackageFile kp) $ \kpFile -> + mlscli + cid + ["proposal", "--group-in", "", "--group-out", "", "add", kpFile] + Nothing + pure + MessagePackage + { sender = cid, + message = prop, + welcome = Nothing, + groupInfo = Nothing + } + +createPendingProposalCommit :: HasCallStack => ClientIdentity -> App MessagePackage +createPendingProposalCommit cid = do + bd <- getBaseDir + welcomeFile <- liftIO $ emptyTempFile bd "welcome" + pgsFile <- liftIO $ emptyTempFile bd "pgs" + commit <- + mlscli + cid + [ "commit", + "--group", + "", + "--group-out", + "", + "--welcome-out", + welcomeFile, + "--group-info-out", + pgsFile + ] + Nothing + + welcome <- liftIO $ readWelcome welcomeFile + pgs <- liftIO $ BS.readFile pgsFile + pure + MessagePackage + { sender = cid, + message = commit, + welcome = welcome, + groupInfo = Just pgs + } + +createExternalCommit :: + HasCallStack => + ClientIdentity -> + Maybe ByteString -> + App MessagePackage +createExternalCommit cid mgi = do + bd <- getBaseDir + giFile <- liftIO $ emptyTempFile bd "gi" + conv <- getConv + gi <- case mgi of + Nothing -> getGroupInfo cid conv >>= getBody 200 + Just v -> pure v + commit <- + mlscli + cid + [ "external-commit", + "--group-info-in", + "-", + "--group-info-out", + giFile, + "--group-out", + "" + ] + (Just gi) + + modifyMLSState $ \mls -> + mls + { newMembers = Set.singleton cid + -- This might be a different client than those that have been in the + -- group from before. + } + + newPgs <- liftIO $ BS.readFile giFile + pure $ + MessagePackage + { sender = cid, + message = commit, + welcome = Nothing, + groupInfo = Just newPgs + } + +-- | Make all member clients consume a given message. +consumeMessage :: HasCallStack => MessagePackage -> App () +consumeMessage msg = do + mls <- getMLSState + for_ (Set.delete msg.sender mls.members) $ \cid -> + consumeMessage1 cid msg.message + +consumeMessage1 :: HasCallStack => ClientIdentity -> ByteString -> App () +consumeMessage1 cid msg = + void $ + mlscli + cid + [ "consume", + "--group", + "", + "--group-out", + "", + "-" + ] + (Just msg) + +-- | Send an MLS message and simulate clients receiving it. If the message is a +-- commit, the 'sendAndConsumeCommit' function should be used instead. +sendAndConsumeMessage :: HasCallStack => MessagePackage -> App Value +sendAndConsumeMessage mp = do + r <- postMLSMessage mp.sender mp.message >>= getJSON 201 + consumeMessage mp + pure r + +-- | Send an MLS commit bundle, simulate clients receiving it, and update the +-- test state accordingly. +sendAndConsumeCommitBundle :: HasCallStack => MessagePackage -> App Value +sendAndConsumeCommitBundle mp = do + resp <- postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 201 + consumeMessage mp + traverse_ consumeWelcome mp.welcome + + -- increment epoch and add new clients + modifyMLSState $ \mls -> + mls + { epoch = epoch mls + 1, + members = members mls <> newMembers mls, + newMembers = mempty + } + + pure resp + +consumeWelcome :: HasCallStack => ByteString -> App () +consumeWelcome welcome = do + mls <- getMLSState + for_ mls.newMembers $ \cid -> do + hasState <- hasClientGroupState cid + assertBool "Existing clients in a conversation should not consume welcomes" (not hasState) + void $ + mlscli + cid + [ "group", + "from-welcome", + "--group-out", + "", + "-" + ] + (Just welcome) + +readWelcome :: FilePath -> IO (Maybe ByteString) +readWelcome fp = runMaybeT $ do + liftIO (doesFileExist fp) >>= guard + stat <- liftIO $ getFileStatus fp + guard $ fileSize stat > 0 + liftIO $ BS.readFile fp + +mkBundle :: MessagePackage -> ByteString +mkBundle mp = mp.message <> foldMap mkGroupInfoMessage mp.groupInfo <> fold mp.welcome + +mkGroupInfoMessage :: ByteString -> ByteString +mkGroupInfoMessage gi = BS.pack [0x00, 0x01, 0x00, 0x04] <> gi + +spawn :: HasCallStack => CreateProcess -> Maybe ByteString -> App ByteString +spawn cp minput = do + (mout, ex) <- liftIO + $ withCreateProcess + cp + { std_out = CreatePipe, + std_in = if isJust minput then CreatePipe else Inherit + } + $ \minh mouth _ ph -> + let writeInput = for_ ((,) <$> minput <*> minh) $ \(input, inh) -> + BS.hPutStr inh input >> hClose inh + readOutput = (,) <$> traverse BS.hGetContents mouth <*> waitForProcess ph + in snd <$> concurrently writeInput readOutput + case (mout, ex) of + (Just out, ExitSuccess) -> pure out + _ -> assertFailure "Failed spawning process" + +hasClientGroupState :: HasCallStack => ClientIdentity -> App Bool +hasClientGroupState cid = do + mls <- getMLSState + pure $ Map.member cid mls.clientGroupState + +getClientGroupState :: HasCallStack => ClientIdentity -> App ByteString +getClientGroupState cid = do + mls <- getMLSState + case Map.lookup cid mls.clientGroupState of + Nothing -> assertFailure ("Attempted to get non-existing group state for client " <> cid2Str cid) + Just g -> pure g + +setClientGroupState :: HasCallStack => ClientIdentity -> ByteString -> App () +setClientGroupState cid g = + modifyMLSState $ \s -> + s {clientGroupState = Map.insert cid g (clientGroupState s)} diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index bec59fb6ad..a46e8e8cc5 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -2,6 +2,7 @@ module SetupHelpers where import qualified API.Brig as Public import qualified API.BrigInternal as Internal +import API.Galley import Data.Aeson import Data.Default import Data.Function @@ -46,3 +47,14 @@ createAndConnectUsers domains = do pure (a, b) for_ userPairs (uncurry connectUsers) pure users + +getAllConvs :: (HasCallStack, MakesValue u) => u -> App [Value] +getAllConvs u = do + page <- bindResponse (listConversationIds u def) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json + ids <- page %. "qualified_conversations" & asList + result <- bindResponse (listConversations u ids) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json + result %. "found" & asList diff --git a/integration/test/Test/B2B.hs b/integration/test/Test/B2B.hs index 48267add7e..ba9df150f5 100644 --- a/integration/test/Test/B2B.hs +++ b/integration/test/Test/B2B.hs @@ -6,5 +6,5 @@ import Testlib.Prelude testConnectUsers :: App () testConnectUsers = do - _alice <- randomUser ownDomain def + _alice <- randomUser OwnDomain def pure () diff --git a/integration/test/Test/Brig.hs b/integration/test/Test/Brig.hs index 170017c8f8..e74d0e9157 100644 --- a/integration/test/Test/Brig.hs +++ b/integration/test/Test/Brig.hs @@ -10,11 +10,34 @@ import Testlib.Prelude testSearchContactForExternalUsers :: HasCallStack => App () testSearchContactForExternalUsers = do - owner <- randomUser ownDomain def {Internal.team = True} - partner <- randomUser ownDomain def {Internal.team = True} + owner <- randomUser OwnDomain def {Internal.team = True} + partner <- randomUser OwnDomain def {Internal.team = True} bindResponse (Internal.putTeamMember partner (partner %. "team") (API.teamRole "partner")) $ \resp -> resp.status `shouldMatchInt` 200 bindResponse (Public.searchContacts partner (owner %. "name")) $ \resp -> resp.status `shouldMatchInt` 403 + +testCrudOAuthClient :: HasCallStack => App () +testCrudOAuthClient = do + user <- randomUser OwnDomain def + let appName = "foobar" + let url = "https://example.com/callback.html" + clientId <- bindResponse (Internal.registerOAuthClient user appName url) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "client_id" + bindResponse (Internal.getOAuthClient user clientId) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "application_name" `shouldMatch` appName + resp.json %. "redirect_url" `shouldMatch` url + let newName = "barfoo" + let newUrl = "https://example.com/callback2.html" + bindResponse (Internal.updateOAuthClient user clientId newName newUrl) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "application_name" `shouldMatch` newName + resp.json %. "redirect_url" `shouldMatch` newUrl + bindResponse (Internal.deleteOAuthClient user clientId) $ \resp -> do + resp.status `shouldMatchInt` 200 + bindResponse (Internal.getOAuthClient user clientId) $ \resp -> do + resp.status `shouldMatchInt` 404 diff --git a/integration/test/Test/Demo.hs b/integration/test/Test/Demo.hs index f8a1bffa08..dbdc984f4a 100644 --- a/integration/test/Test/Demo.hs +++ b/integration/test/Test/Demo.hs @@ -7,36 +7,39 @@ import GHC.Stack import SetupHelpers import Testlib.Prelude +-- | Legalhold clients cannot be deleted. testCantDeleteLHClient :: HasCallStack => App () testCantDeleteLHClient = do - user <- randomUser ownDomain def - client <- bindResponseR (Public.addClient user def {Public.ctype = "legalhold", Public.internal = True}) $ \resp -> do - resp.status `shouldMatchInt` 201 + user <- randomUser OwnDomain def + client <- + Public.addClient user def {Public.ctype = "legalhold", Public.internal = True} + >>= getJSON 201 - bindResponse (Public.deleteClient user Nothing client) $ \resp -> do + bindResponse (Public.deleteClient user client) $ \resp -> do resp.status `shouldMatchInt` 400 +-- | Deleting unknown clients should fail with 404. testDeleteUnknownClient :: HasCallStack => App () testDeleteUnknownClient = do - user <- randomUser ownDomain def + user <- randomUser OwnDomain def let fakeClientId = "deadbeefdeadbeef" - bindResponse (Public.deleteClient user Nothing fakeClientId) $ \resp -> do + bindResponse (Public.deleteClient user fakeClientId) $ \resp -> do resp.status `shouldMatchInt` 404 - resp %. "label" `shouldMatch` "client-not-found" + resp.json %. "label" `shouldMatch` "client-not-found" testModifiedBrig :: HasCallStack => App () testModifiedBrig = do withModifiedService Brig (setField "optSettings.setFederationDomain" "overridden.example.com") - $ bindResponse (Public.getAPIVersion ownDomain) - $ ( \resp -> - (resp %. "domain") `shouldMatch` "overridden.example.com" - ) + $ bindResponse (Public.getAPIVersion OwnDomain) + $ \resp -> do + resp.status `shouldMatchInt` 200 + (resp.json %. "domain") `shouldMatch` "overridden.example.com" testModifiedGalley :: HasCallStack => App () testModifiedGalley = do - (_user, tid) <- createTeam ownDomain + (_user, tid) <- createTeam OwnDomain let getFeatureStatus = do bindResponse (Internal.getTeamFeature "searchVisibility" tid) $ \res -> do @@ -54,17 +57,26 @@ testModifiedGalley = do testWebSockets :: HasCallStack => App () testWebSockets = do - user <- randomUser ownDomain def + user <- randomUser OwnDomain def withWebSocket user $ \ws -> do - client <- bindResponseR (Public.addClient user def) $ \resp -> do - resp.status `shouldMatchInt` 201 + client <- Public.addClient user def >>= getJSON 201 n <- awaitMatch 3 (\n -> nPayload n %. "type" `isEqual` "user.client-add") ws nPayload n %. "client.id" `shouldMatch` (client %. "id") testMultipleBackends :: App () testMultipleBackends = do - ownDomainRes <- bindResponse (Public.getAPIVersion ownDomain) (%. "domain") - otherDomainRes <- bindResponse (Public.getAPIVersion otherDomain) (%. "domain") - ownDomainRes `shouldMatch` ownDomain - otherDomainRes `shouldMatch` otherDomain - ownDomain `shouldNotMatch` otherDomain + ownDomainRes <- (Public.getAPIVersion OwnDomain >>= getJSON 200) %. "domain" + otherDomainRes <- (Public.getAPIVersion OtherDomain >>= getJSON 200) %. "domain" + ownDomainRes `shouldMatch` OwnDomain + otherDomainRes `shouldMatch` OtherDomain + OwnDomain `shouldNotMatch` OtherDomain + +testUnrace :: App () +testUnrace = do + {- + -- the following would retry for ~30s and only then fail + unrace $ do + True `shouldMatch` True + True `shouldMatch` False + -} + unrace $ True `shouldMatch` True diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index 02f28df8f8..5606aecaa5 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -9,27 +9,26 @@ import Testlib.Prelude testMixedProtocolUpgrade :: HasCallStack => App () testMixedProtocolUpgrade = do - [alice, bob] <- createAndConnectUsers [ownDomain, ownDomain] + [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain] bobClient <- bindResponse (Public.addClient bob def {Public.ctype = "legalhold", Public.internal = True}) $ \resp -> do resp.status `shouldMatchInt` 201 resp.json - qcnv <- bindResponseR (Public.postConversation alice noValue Public.defProteus {Public.qualifiedUsers = [bob]}) $ \resp -> do - resp.status `shouldMatchInt` 201 + qcnv <- Public.postConversation alice Public.defProteus {Public.qualifiedUsers = [bob]} >>= getJSON 201 withWebSocket alice $ \wsAlice -> do bindResponse (Public.putConversationProtocol bob qcnv (Just bobClient) "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 - resp %. "conversation" `shouldMatch` (qcnv %. "id") - resp %. "data.protocol" `shouldMatch` "mixed" + resp.json %. "conversation" `shouldMatch` (qcnv %. "id") + resp.json %. "data.protocol" `shouldMatch` "mixed" n <- awaitMatch 3 (\value -> nPayload value %. "type" `isEqual` "conversation.protocol-update") wsAlice nPayload n %. "data.protocol" `shouldMatch` "mixed" bindResponse (Public.getConversation alice qcnv) $ \resp -> do resp.status `shouldMatchInt` 200 - resp %. "protocol" `shouldMatch` "mixed" + resp.json %. "protocol" `shouldMatch` "mixed" bindResponse (Public.putConversationProtocol bob qcnv (Just bobClient) "mixed") $ \resp -> do resp.status `shouldMatchInt` 204 diff --git a/integration/test/Testlib/App.hs b/integration/test/Testlib/App.hs index ab88325489..e3dcbed544 100644 --- a/integration/test/Testlib/App.hs +++ b/integration/test/Testlib/App.hs @@ -1,14 +1,17 @@ module Testlib.App where import Control.Monad.Reader +import qualified Control.Retry as Retry import Data.Aeson hiding ((.=)) import Data.IORef +import qualified Data.Text as T import qualified Data.Yaml as Yaml import GHC.Exception import System.FilePath import Testlib.Env import Testlib.JSON import Testlib.Types +import Prelude failApp :: String -> App a failApp msg = throw (AppFailure msg) @@ -44,8 +47,17 @@ readServiceConfig srv = do Left err -> failApp ("Error while parsing " <> cfgFile <> ": " <> Yaml.prettyPrintParseException err) Right value -> pure value -ownDomain :: App String -ownDomain = asks (.domain1) +data Domain = OwnDomain | OtherDomain -otherDomain :: App String -otherDomain = asks (.domain2) +instance MakesValue Domain where + make OwnDomain = asks (String . T.pack . (.domain1)) + make OtherDomain = asks (String . T.pack . (.domain2)) + +-- | Run an action, `recoverAll`ing with exponential backoff (min step 8ms, total timeout +-- ~15s). Search this package for examples how to use it. +-- +-- Ideally, this will be the only thing you'll ever need from the retry package when writing +-- integration tests. If you are unhappy with it,, please consider fixing it so everybody can +-- benefit. +unrace :: App a -> App a +unrace action = Retry.recoverAll (Retry.exponentialBackoff 8000 <> Retry.limitRetries 10) (const action) diff --git a/integration/test/Testlib/Assertions.hs b/integration/test/Testlib/Assertions.hs index d8457855f4..c056fe1c8d 100644 --- a/integration/test/Testlib/Assertions.hs +++ b/integration/test/Testlib/Assertions.hs @@ -14,6 +14,7 @@ import System.FilePath import Testlib.JSON import Testlib.Printing import Testlib.Types +import Prelude assertBool :: HasCallStack => String -> Bool -> App () assertBool _ True = pure () @@ -46,7 +47,7 @@ a `shouldMatch` b = do unless (xa == xb) $ do pa <- prettyJSON xa pb <- prettyJSON xb - assertFailure $ "Expected:\n" <> pb <> "\n" <> "Actual:\n" <> pa + assertFailure $ "Actual:\n" <> pa <> "\nExpected:\n" <> pb shouldNotMatch :: (MakesValue a, MakesValue b, HasCallStack) => @@ -62,7 +63,12 @@ a `shouldNotMatch` b = do unless (jsonType xa == jsonType xb) $ do pa <- prettyJSON xa pb <- prettyJSON xb - assertFailure $ "Compared values are not of the same type:\n" <> "Left side:\n" <> pa <> "Right side:\n" <> pb + assertFailure $ + "Compared values are not of the same type:\n" + <> "Left side:\n" + <> pa + <> "\nRight side:\n" + <> pb when (xa == xb) $ do pa <- prettyJSON xa @@ -103,6 +109,13 @@ printFailureDetails (AssertionFailure stack mbResponse msg) = do : "\n" <> s : toList (fmap prettyResponse mbResponse) +printExceptionDetails :: SomeException -> IO String +printExceptionDetails e = do + pure . unlines $ + [ colored yellow "exception:", + colored red (displayException e) + ] + prettierCallStack :: CallStack -> IO String prettierCallStack cstack = do sl <- diff --git a/integration/test/Testlib/Cannon.hs b/integration/test/Testlib/Cannon.hs index caebbdeb54..78d19c0904 100644 --- a/integration/test/Testlib/Cannon.hs +++ b/integration/test/Testlib/Cannon.hs @@ -61,6 +61,7 @@ import Testlib.HTTP import Testlib.JSON import Testlib.Printing import Testlib.Types +import Prelude data WebSocket = WebSocket { wsChan :: TChan Value, @@ -82,10 +83,12 @@ class ToWSConnect a where instance {-# OVERLAPPING #-} ToWSConnect WSConnect where toWSConnect = pure -instance {-# OVERLAPPABLE #-} (MakesValue user) => ToWSConnect user where +instance {-# OVERLAPPABLE #-} MakesValue user => ToWSConnect user where toWSConnect u = do uid <- objId u & asString - pure (WSConnect uid Nothing Nothing) + mc <- lookupField u "client_id" + c <- traverse asString mc + pure (WSConnect uid c Nothing) instance (MakesValue user, MakesValue conn) => ToWSConnect (user, conn) where toWSConnect (u, c) = do @@ -126,7 +129,7 @@ clientApp wsChan latch conn = do -- for the connection to register with Gundeck, and return the 'Async' thread. run :: HasCallStack => WSConnect -> WS.ClientApp () -> App (Async ()) run wsConnect app = do - domain <- ownDomain + domain <- asString OwnDomain serviceMap <- getServiceMap domain let HostPort caHost caPort = serviceHostPort serviceMap Cannon @@ -138,7 +141,7 @@ run wsConnect app = do let path = "/await" - <> ( case client wsConnect of + <> ( case wsConnect.client of Nothing -> "" Just client -> fromJust . fromByteString $ Http.queryString (Http.setQueryString [("client", Just (toByteString' client))] Http.defaultRequest) ) @@ -161,22 +164,17 @@ run wsConnect app = do ) `onException` tryPutMVar latch () - let waitForRegistry :: HasCallStack => Int -> App () - waitForRegistry (0 :: Int) = failApp "Cannon: failed to register presence" - waitForRegistry n = do - request <- baseRequest ownDomain Cannon Unversioned ("/i/presences/" <> wsConnect.user <> "/" <> connId) + let waitForRegistry :: HasCallStack => App () + waitForRegistry = unrace $ do + request <- baseRequest OwnDomain Cannon Unversioned ("/i/presences/" <> wsConnect.user <> "/" <> connId) response <- submit "HEAD" request - unless (status response == 200) $ do - liftIO $ threadDelay $ 100 * 1000 - waitForRegistry (n - 1) + status response `shouldMatchInt` 200 liftIO $ takeMVar latch stat <- liftIO $ poll wsapp case stat of Just (Left ex) -> liftIO $ throwIO ex - _ -> waitForRegistry numRetries >> pure wsapp - where - numRetries = 30 + _ -> waitForRegistry >> pure wsapp close :: MonadIO m => WebSocket -> m () close ws = liftIO $ do @@ -188,7 +186,7 @@ withWebSocket w k = do wsConnect <- toWSConnect w Catch.bracket (connect wsConnect) close k -withWebSockets :: forall a w. (HasCallStack, (ToWSConnect w)) => [w] -> ([WebSocket] -> App a) -> App a +withWebSockets :: forall a w. (HasCallStack, ToWSConnect w) => [w] -> ([WebSocket] -> App a) -> App a withWebSockets twcs k = do wcs <- for twcs toWSConnect go wcs [] diff --git a/integration/test/Testlib/Env.hs b/integration/test/Testlib/Env.hs index cfd77a79e7..a361d9f10e 100644 --- a/integration/test/Testlib/Env.hs +++ b/integration/test/Testlib/Env.hs @@ -1,12 +1,16 @@ module Testlib.Env where +import Control.Monad.Codensity +import Control.Monad.IO.Class import Data.Aeson hiding ((.=)) import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) import Data.Char import Data.Functor import Data.IORef import Data.Map (Map) import qualified Data.Map as Map +import Data.Set (Set) import Data.String import Data.Word import qualified Data.Yaml as Yaml @@ -15,7 +19,9 @@ import qualified Network.HTTP.Client as HTTP import System.Exit import System.FilePath import System.IO +import System.IO.Temp import Testlib.Prekeys +import Prelude -- | Initialised once per test. data Env = Env @@ -26,8 +32,10 @@ data Env = Env manager :: HTTP.Manager, serviceConfigsDir :: FilePath, servicesCwdBase :: Maybe FilePath, + removalKeyPath :: FilePath, prekeys :: IORef [(Int, String)], - lastPrekeys :: IORef [String] + lastPrekeys :: IORef [String], + mls :: IORef MLSState } -- | Initialised once per testsuite. @@ -38,7 +46,8 @@ data GlobalEnv = GlobalEnv gDefaultAPIVersion :: Int, gManager :: HTTP.Manager, gServiceConfigsDir :: FilePath, - gServicesCwdBase :: Maybe FilePath + gServicesCwdBase :: Maybe FilePath, + gRemovalKeyPath :: FilePath } data IntegrationConfig = IntegrationConfig @@ -132,13 +141,15 @@ mkGlobalEnv cfgFile = do gDefaultAPIVersion = 4, gManager = manager, gServiceConfigsDir = configsDir, - gServicesCwdBase = devEnvProjectRoot <&> ( "services") + gServicesCwdBase = devEnvProjectRoot <&> ( "services"), + gRemovalKeyPath = error "Uninitialised removal key path" } -mkEnv :: GlobalEnv -> IO Env +mkEnv :: GlobalEnv -> Codensity IO Env mkEnv ge = do - pks <- newIORef (zip [1 ..] somePrekeys) - lpks <- newIORef someLastPrekeys + pks <- liftIO $ newIORef (zip [1 ..] somePrekeys) + lpks <- liftIO $ newIORef someLastPrekeys + mls <- liftIO . newIORef =<< mkMLSState pure Env { serviceMap = gServiceMap ge, @@ -148,6 +159,41 @@ mkEnv ge = do manager = gManager ge, serviceConfigsDir = gServiceConfigsDir ge, servicesCwdBase = gServicesCwdBase ge, + removalKeyPath = gRemovalKeyPath ge, prekeys = pks, - lastPrekeys = lpks + lastPrekeys = lpks, + mls = mls } + +data MLSState = MLSState + { baseDir :: FilePath, + members :: Set ClientIdentity, + -- | users expected to receive a welcome message after the next commit + newMembers :: Set ClientIdentity, + groupId :: Maybe String, + convId :: Maybe Value, + clientGroupState :: Map ClientIdentity ByteString, + epoch :: Word64 + } + deriving (Show) + +mkMLSState :: Codensity IO MLSState +mkMLSState = Codensity $ \k -> + withSystemTempDirectory "mls" $ \tmp -> do + k + MLSState + { baseDir = tmp, + members = mempty, + newMembers = mempty, + groupId = Nothing, + convId = Nothing, + clientGroupState = mempty, + epoch = 0 + } + +data ClientIdentity = ClientIdentity + { domain :: String, + user :: String, + client :: String + } + deriving (Show, Eq, Ord) diff --git a/integration/test/Testlib/HTTP.hs b/integration/test/Testlib/HTTP.hs index 1a5d73c437..f1d57f1e22 100644 --- a/integration/test/Testlib/HTTP.hs +++ b/integration/test/Testlib/HTTP.hs @@ -4,9 +4,11 @@ import qualified Control.Exception as E import Control.Monad.Reader import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import qualified Data.CaseInsensitive as CI +import Data.Function import Data.List import Data.List.Split (splitOn) import Data.String @@ -16,9 +18,11 @@ import qualified Data.Text.Encoding as T import GHC.Stack import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Types as HTTP +import Testlib.Assertions import Testlib.Env import Testlib.JSON import Testlib.Types +import Prelude splitHttpPath :: String -> [String] splitHttpPath path = filter (not . null) (splitOn "/" path) @@ -38,6 +42,15 @@ addJSON obj req = : HTTP.requestHeaders req } +addMLS :: ByteString -> HTTP.Request -> HTTP.Request +addMLS bytes req = + req + { HTTP.requestBody = HTTP.RequestBodyLBS (L.fromStrict bytes), + HTTP.requestHeaders = + (fromString "Content-Type", fromString "message/mls") + : HTTP.requestHeaders req + } + addHeader :: String -> String -> HTTP.Request -> HTTP.Request addHeader name value req = req {HTTP.requestHeaders = (CI.mk . C8.pack $ name, C8.pack value) : HTTP.requestHeaders req} @@ -46,15 +59,6 @@ addQueryParams :: [(String, String)] -> HTTP.Request -> HTTP.Request addQueryParams params req = HTTP.setQueryString (map (\(k, v) -> (cs k, Just (cs v))) params) req -zUser :: String -> HTTP.Request -> HTTP.Request -zUser = addHeader "Z-User" - -zConnection :: String -> HTTP.Request -> HTTP.Request -zConnection = addHeader "Z-Connection" - -zClient :: String -> HTTP.Request -> HTTP.Request -zClient = addHeader "Z-Client" - zType :: String -> HTTP.Request -> HTTP.Request zType = addHeader "Z-Type" @@ -64,12 +68,21 @@ contentTypeJSON = addHeader "Content-Type" "application/json" bindResponse :: HasCallStack => App Response -> (Response -> App a) -> App a bindResponse m k = m >>= \r -> withResponse r k -bindResponseR :: HasCallStack => App Response -> (Response -> App a) -> App Response -bindResponseR m k = m >>= \r -> withResponse r k >> pure r - withResponse :: HasCallStack => Response -> (Response -> App a) -> App a withResponse r k = onFailureAddResponse r (k r) +-- | Check response status code, then return body. +getBody :: Int -> Response -> App ByteString +getBody status resp = withResponse resp $ \r -> do + r.status `shouldMatch` status + pure r.body + +-- | Check response status code, then return JSON body. +getJSON :: Int -> Response -> App Aeson.Value +getJSON status resp = withResponse resp $ \r -> do + r.status `shouldMatch` status + r.json + onFailureAddResponse :: Response -> App a -> App a onFailureAddResponse r m = App $ do e <- ask @@ -78,8 +91,8 @@ onFailureAddResponse r m = App $ do data Versioned = Versioned | Unversioned | ExplicitVersion Int -baseRequest :: (HasCallStack, MakesValue domain) => domain -> Service -> Versioned -> String -> App HTTP.Request -baseRequest domain service versioned path = do +rawBaseRequest :: (HasCallStack, MakesValue domain) => domain -> Service -> Versioned -> String -> App HTTP.Request +rawBaseRequest domain service versioned path = do pathSegsPrefix <- case versioned of Versioned -> do v <- asks (.defaultAPIVersion) @@ -95,6 +108,27 @@ baseRequest domain service versioned path = do let HostPort h p = serviceHostPort serviceMap service in "http://" <> h <> ":" <> show p <> ("/" <> joinHttpPath (pathSegsPrefix <> splitHttpPath path)) +baseRequest :: (HasCallStack, MakesValue user) => user -> Service -> Versioned -> String -> App HTTP.Request +baseRequest user service versioned path = do + req <- rawBaseRequest user service versioned path + uid <- objId user + cli <- + make user >>= \case + Aeson.Object _ -> do + c <- lookupField user "client_id" + traverse asString c + _ -> pure Nothing + pure $ req & zUser uid & maybe id zClient cli & zConnection "conn" + +zUser :: String -> HTTP.Request -> HTTP.Request +zUser = addHeader "Z-User" + +zConnection :: String -> HTTP.Request -> HTTP.Request +zConnection = addHeader "Z-Connection" + +zClient :: String -> HTTP.Request -> HTTP.Request +zClient = addHeader "Z-Client" + submit :: String -> HTTP.Request -> App Response submit method req0 = do let req = req0 {HTTP.method = T.encodeUtf8 (T.pack method)} diff --git a/integration/test/Testlib/JSON.hs b/integration/test/Testlib/JSON.hs index cc7f0270e2..fc4360a6e0 100644 --- a/integration/test/Testlib/JSON.hs +++ b/integration/test/Testlib/JSON.hs @@ -18,7 +18,9 @@ import qualified Data.Scientific as Sci import Data.String import qualified Data.Text as T import GHC.Stack +import Testlib.Env import Testlib.Types +import Prelude -- | All library functions should use this typeclass for all untyped value -- arguments wherever possible. This design choice has advantages: @@ -53,9 +55,6 @@ instance {-# OVERLAPPABLE #-} ToJSON a => MakesValue a where instance {-# OVERLAPPING #-} ToJSON a => MakesValue (App a) where make m = m <&> toJSON -instance MakesValue Response where - make r = r.json - -- use this to provide Nothing for MakesValue a => (Maybe a) values. noValue :: Maybe Value noValue = Nothing @@ -263,13 +262,13 @@ objQid ob = do Nothing -> firstSuccess xs Just y -> pure (Just y) --- Get "qualified_id" field as {"id": _, "domain": _} object or - if already is a qualified id object - return that +-- | Get "qualified_id" field as {"id": _, "domain": _} object or - if already is a qualified id object - return that. objQidObject :: HasCallStack => MakesValue a => a -> App Value objQidObject o = do (domain, id_) <- objQid o pure $ object ["domain" .= domain, "id" .= id_] --- Get "domain" field or - if already string-like return String +-- Get "domain" field or - if already string-like - return String. objDomain :: (HasCallStack, MakesValue a) => a -> App String objDomain x = do v <- make x @@ -277,3 +276,59 @@ objDomain x = do Object _ob -> fst <$> objQid v String t -> pure (T.unpack t) other -> assertFailureWithJSON other (typeWasExpectedButGot "Object or String" other) + +-- | Get conversation ID and optional subconversation ID. +-- +-- This accepts subconversation objects in the format: +-- @ +-- { "parent_qualified_id": { +-- "domain": "example.com", +-- "id": "7b6c21d1-322d-4be6-a923-85225691f398" +-- }, +-- "subconv_id": "conference" +-- } +-- @ +-- +-- as well as conversation objects in the general format supported by 'objQid'. +-- Conversation objects can optionally contain a @subconv_id@ field. So, in +-- particular, a flat subconversation format, like +-- @ +-- { "domain": "example.com", +-- "id": "7b6c21d1-322d-4be6-a923-85225691f398", +-- "subconv_id": "conference" +-- } +-- @ +-- is also supported. +objSubConv :: (HasCallStack, MakesValue a) => a -> App (Value, Maybe String) +objSubConv x = do + mParent <- lookupField x "parent_qualified_id" + case mParent of + Nothing -> do + obj <- objQidObject x + subValue <- lookupField x "subconv_id" + sub <- traverse asString subValue + pure (obj, sub) + Just parent -> do + obj <- objQidObject parent + sub <- x %. "subconv_id" & asString + pure (obj, Just sub) + +-- | Turn an object parseable by 'objSubConv' into a canonical flat representation. +objSubConvObject :: (HasCallStack, MakesValue a) => a -> App Value +objSubConvObject x = do + (convId, mSubConvId) <- objSubConv x + (domain, id_) <- objQid convId + pure . object $ + [ "domain" .= domain, + "id" .= id_ + ] + <> ["subconv_id" .= sub | sub <- toList mSubConvId] + +instance MakesValue ClientIdentity where + make cid = + pure $ + object + [ "domain" .= cid.domain, + "id" .= cid.user, + "client_id" .= cid.client + ] diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 7cca72171c..ed9fab6eae 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -26,6 +26,7 @@ import Testlib.Env import Testlib.HTTP import Testlib.JSON import Testlib.Types +import Prelude withModifiedService :: Service -> @@ -129,13 +130,12 @@ withModifiedServices services k = do waitUntilServiceUp :: HasCallStack => Service -> App () waitUntilServiceUp srv = do - d <- ownDomain isUp <- retrying (limitRetriesByCumulativeDelay (4 * 1000 * 1000) (fibonacciBackoff (200 * 1000))) (\_ isUp -> pure (not isUp)) ( \_ -> do - req <- baseRequest d srv Unversioned "/i/status" + req <- baseRequest OwnDomain srv Unversioned "/i/status" env <- ask eith <- liftIO $ diff --git a/integration/test/Testlib/Options.hs b/integration/test/Testlib/Options.hs index 28240fa8fc..2ba8fdafd9 100644 --- a/integration/test/Testlib/Options.hs +++ b/integration/test/Testlib/Options.hs @@ -3,10 +3,12 @@ module Testlib.Options (getOptions, TestOptions (..)) where import Data.List.Split (splitOn) import Options.Applicative import System.Environment (lookupEnv) +import Prelude data TestOptions = TestOptions { includeTests :: [String], excludeTests :: [String], + listTests :: Bool, configFile :: String } @@ -29,6 +31,7 @@ parser = <> help "Exclude tests matching PATTERN (simple substring match). This flag can be provided multiple times. This flag can also be provided via the TEST_EXCLUDE environment variable." ) ) + <*> switch (long "list" <> short 'l' <> help "Only list tests.") <*> strOption ( long "config" <> short 'c' diff --git a/integration/test/Testlib/PTest.hs b/integration/test/Testlib/PTest.hs new file mode 100644 index 0000000000..d2613fa214 --- /dev/null +++ b/integration/test/Testlib/PTest.hs @@ -0,0 +1,18 @@ +module Testlib.PTest where + +import Testlib.App +import Testlib.Types +import Prelude + +type Test = (String, String, String, String, App ()) + +class HasTests x where + mkTests :: String -> String -> String -> String -> x -> [Test] + +instance HasTests (App ()) where + mkTests m n s f x = [(m, n, s, f, x)] + +instance HasTests x => HasTests (Domain -> x) where + mkTests m n s f x = + mkTests m (n <> "[domain=own]") s f (x OwnDomain) + <> mkTests m (n <> "[domain=other]") s f (x OtherDomain) diff --git a/integration/test/Testlib/Prekeys.hs b/integration/test/Testlib/Prekeys.hs index 0b4c35dc50..56cff0bbb8 100644 --- a/integration/test/Testlib/Prekeys.hs +++ b/integration/test/Testlib/Prekeys.hs @@ -1,5 +1,7 @@ module Testlib.Prekeys where +import Prelude + somePrekeys :: [String] somePrekeys = [ "pQABAQECoQBYIOjl7hw0D8YRNqkkBQETCxyr7/ywE/2R5RWcUPM+GJACA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY=", diff --git a/integration/test/Testlib/Prelude.hs b/integration/test/Testlib/Prelude.hs index e7239e78ec..1187480186 100644 --- a/integration/test/Testlib/Prelude.hs +++ b/integration/test/Testlib/Prelude.hs @@ -7,7 +7,7 @@ module Testlib.Prelude module Testlib.ModService, module Testlib.HTTP, module Testlib.JSON, - module Text.RawString.QQ, + module Testlib.PTest, module Data.Aeson, module Prelude, module Control.Applicative, @@ -46,11 +46,45 @@ module Testlib.Prelude SomeException (..), SomeAsyncException (..), IOException, + + -- ** Prelude + putChar, + putStr, + putStrLn, + print, + getChar, + getLine, + getContents, + interact, + readFile, + writeFile, + appendFile, + readIO, + readLn, + + -- * Functor + (<$$>), + (<$$$>), ) where import Control.Applicative hiding (empty, many, optional, some) import Control.Monad hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_) +-- 'insert' and 'delete' are common in database modules + +-- Lazy and strict versions are the same + +-- First and Last are going to be deprecated. Use Semigroup instead + +-- conflicts with Options.Applicative.Option (should we care?) + +-- Permissions is common in Galley + +-- Handle is hidden because it's common in Brig +-- Explicitly saying what to import because some things from Prelude clash +-- with e.g. UnliftIO modules + +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson hiding ((.=)) import Data.Bifunctor hiding (first, second) import Data.Bool @@ -63,15 +97,11 @@ import Data.Function import Data.Functor import Data.Functor.Identity import Data.Int --- 'insert' and 'delete' are common in database modules import Data.List hiding (delete, insert, singleton) --- Lazy and strict versions are the same import Data.Map (Map) import Data.Maybe --- First and Last are going to be deprecated. Use Semigroup instead import Data.Monoid hiding (First (..), Last (..)) import Data.Ord --- conflicts with Options.Applicative.Option (should we care?) import Data.Semigroup hiding (diff) import Data.Set (Set) import Data.String @@ -88,13 +118,9 @@ import Testlib.Env import Testlib.HTTP import Testlib.JSON import Testlib.ModService +import Testlib.PTest import Testlib.Types -import Text.RawString.QQ --- Permissions is common in Galley import UnliftIO.Exception --- Handle is hidden because it's common in Brig --- Explicitly saying what to import because some things from Prelude clash --- with e.g. UnliftIO modules import Prelude ( Bounded (..), Double, @@ -139,3 +165,59 @@ import Prelude (^), (^^), ) +import qualified Prelude as P + +---------------------------------------------------------------------------- +-- Lifted functions from Prelude + +putChar :: MonadIO m => Char -> m () +putChar = liftIO . P.putChar + +putStr :: MonadIO m => String -> m () +putStr = liftIO . P.putStr + +putStrLn :: MonadIO m => String -> m () +putStrLn = liftIO . P.putStrLn + +print :: (Show a, MonadIO m) => a -> m () +print = liftIO . P.print + +getChar :: MonadIO m => m Char +getChar = liftIO P.getChar + +getLine :: MonadIO m => m String +getLine = liftIO P.getLine + +getContents :: MonadIO m => m String +getContents = liftIO P.getContents + +interact :: MonadIO m => (String -> String) -> m () +interact = liftIO . P.interact + +readFile :: MonadIO m => FilePath -> m String +readFile = liftIO . P.readFile + +writeFile :: MonadIO m => FilePath -> String -> m () +writeFile = fmap liftIO . P.writeFile + +appendFile :: MonadIO m => FilePath -> String -> m () +appendFile = fmap liftIO . P.appendFile + +readIO :: (Read a, MonadIO m) => String -> m a +readIO = liftIO . P.readIO + +readLn :: (Read a, MonadIO m) => m a +readLn = liftIO P.readLn + +---------------------------------------------------------------------- +-- Functor + +(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +(<$$>) = fmap . fmap + +infix 4 <$$> + +(<$$$>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b)) +(<$$$>) = fmap . fmap . fmap + +infix 4 <$$$> diff --git a/integration/test/Testlib/Printing.hs b/integration/test/Testlib/Printing.hs index 404b0fc73a..9dcb3b60f6 100644 --- a/integration/test/Testlib/Printing.hs +++ b/integration/test/Testlib/Printing.hs @@ -1,5 +1,7 @@ module Testlib.Printing where +import Prelude + yellow :: String yellow = "\x1b[38;5;11m" @@ -18,6 +20,9 @@ red = "\x1b[38;5;9m" green :: String green = "\x1b[32m" +gray :: String +gray = "\x1b[38;5;250m" + resetColor :: String resetColor = "\x1b[0m" diff --git a/integration/test/Testlib/Run.hs b/integration/test/Testlib/Run.hs index e22a998644..317c1b75e9 100644 --- a/integration/test/Testlib/Run.hs +++ b/integration/test/Testlib/Run.hs @@ -3,20 +3,28 @@ module Testlib.Run (main, mainI) where import Control.Concurrent import Control.Exception as E import Control.Monad +import Control.Monad.Codensity +import Control.Monad.IO.Class +import Control.Monad.Reader import Data.Foldable +import Data.Function import Data.Functor import Data.List import Data.Time.Clock import RunAllTests import System.Directory import System.Environment +import System.FilePath +import Testlib.App import Testlib.Assertions import Testlib.Env +import Testlib.JSON import Testlib.Options import Testlib.Printing import Testlib.Types import Text.Printf import UnliftIO.Async +import Prelude data TestReport = TestReport { count :: Int, @@ -30,20 +38,16 @@ instance Semigroup TestReport where instance Monoid TestReport where mempty = TestReport 0 mempty -runTest :: GlobalEnv -> App () -> IO (Maybe String) -runTest ge action = do +runTest :: GlobalEnv -> App a -> IO (Either String a) +runTest ge action = lowerCodensity $ do env <- mkEnv ge - (runAppWithEnv env action $> Nothing) - `E.catches` [ E.Handler - ( \(e :: AssertionFailure) -> do - Just <$> printFailureDetails e - ), - E.Handler - ( \(e :: SomeException) -> do - putStrLn "exception handler" - pure (Just (colored yellow (displayException e))) - ) - ] + liftIO $ + (Right <$> runAppWithEnv env action) + `E.catches` [ E.Handler -- AssertionFailure + (fmap Left . printFailureDetails), + E.Handler + (fmap Left . printExceptionDetails) + ] pluralise :: Int -> String -> String pluralise 1 x = x @@ -54,7 +58,9 @@ printReport report = do unless (null report.failures) $ putStrLn $ "----------" putStrLn $ show report.count <> " " <> pluralise report.count "test" <> " run." unless (null report.failures) $ do - putStrLn $ colored red "\nFailed tests: " + putStrLn "" + let numFailures = length report.failures + putStrLn $ colored red (show numFailures <> " failed " <> pluralise numFailures "test" <> ": ") for_ report.failures $ \name -> putStrLn $ " - " <> name @@ -83,14 +89,24 @@ printTime = main :: IO () main = do + opts <- getOptions + let f = testFilter opts + cfg = opts.configFile + let tests = - sortOn fst $ - allTests <&> \(module_, name, _summary, _full, action) -> + filter (\(qname, _, _, _) -> f qname) + . sortOn (\(qname, _, _, _) -> qname) + $ allTests <&> \(module_, name, summary, full, action) -> let module0 = case module_ of ('T' : 'e' : 's' : 't' : '.' : m) -> m _ -> module_ qualifiedName = module0 <> "." <> name - in (qualifiedName, action) + in (qualifiedName, summary, full, action) + + if opts.listTests then doListTests tests else runTests tests cfg + +runTests :: [(String, x, y, App ())] -> FilePath -> IO () +runTests tests cfg = do output <- newChan let displayOutput = readChan output >>= \case @@ -98,37 +114,50 @@ main = do Nothing -> pure () let writeOutput = writeChan output . Just - opts <- getOptions - let f = testFilter opts - cfg = opts.configFile + genv0 <- mkGlobalEnv cfg - env <- mkGlobalEnv cfg + -- save removal key to a file + genv <- lowerCodensity $ do + env <- mkEnv genv0 + liftIO . runAppWithEnv env $ do + config <- readServiceConfig Galley + relPath <- config %. "settings.mlsPrivateKeyPaths.removal.ed25519" & asString + path <- + asks (.servicesCwdBase) <&> \case + Nothing -> relPath + Just dir -> dir "galley" relPath + pure genv0 {gRemovalKeyPath = path} withAsync displayOutput $ \displayThread -> do - report <- fmap mconcat $ pooledForConcurrently tests $ \(name, action) -> do - if f name - then do - (mErr, tm) <- withTime (runTest env action) - case mErr of - Just err -> do - writeOutput $ - "----- " - <> name - <> colored red " FAIL" - <> " (" - <> printTime tm - <> ") -----\n" - <> err - <> "\n" - pure (TestReport 1 [name]) - Nothing -> do - writeOutput $ name <> colored green " OK" <> " (" <> printTime tm <> ")" <> "\n" - pure (TestReport 1 []) - else pure (TestReport 0 []) + report <- fmap mconcat $ pooledForConcurrently tests $ \(qname, _, _, action) -> do + do + (mErr, tm) <- withTime (runTest genv action) + case mErr of + Left err -> do + writeOutput $ + "----- " + <> qname + <> colored red " FAIL" + <> " (" + <> printTime tm + <> ") -----\n" + <> err + <> "\n" + pure (TestReport 1 [qname]) + Right _ -> do + writeOutput $ qname <> colored green " OK" <> " (" <> printTime tm <> ")" <> "\n" + pure (TestReport 1 []) writeChan output Nothing wait displayThread printReport report +doListTests :: [(String, String, String, x)] -> IO () +doListTests tests = for_ tests $ \(qname, desc, full, _) -> do + putStrLn $ qname <> " " <> colored gray desc + unless (null full) $ + putStr $ + colored gray (indent 2 full) + -- like `main` but meant to run from a repl mainI :: [String] -> IO () mainI args = do diff --git a/integration/test/Testlib/Types.hs b/integration/test/Testlib/Types.hs index eab916158c..d0d88935d9 100644 --- a/integration/test/Testlib/Types.hs +++ b/integration/test/Testlib/Types.hs @@ -11,6 +11,8 @@ import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import qualified Data.CaseInsensitive as CI import Data.Functor +import Data.Hex +import Data.IORef import Data.List import qualified Data.Map as Map import qualified Data.Text as T @@ -22,6 +24,7 @@ import qualified Network.HTTP.Types as HTTP import Network.URI import Testlib.Env import Testlib.Printing +import Prelude data Response = Response { jsonBody :: Maybe Aeson.Value, @@ -64,7 +67,7 @@ prettyResponse r = [ colored yellow "request body:", T.unpack . T.decodeUtf8 $ case Aeson.decode (L.fromStrict b) of Just v -> L.toStrict (Aeson.encodePretty (v :: Aeson.Value)) - Nothing -> b + Nothing -> hex b ], pure $ colored blue "response status: " <> show r.status, pure $ colored blue "response body:", @@ -108,6 +111,24 @@ getServiceMap fedDomain = do env <- ask assertJust ("Could not find service map for federation domain: " <> fedDomain) (Map.lookup fedDomain (env.serviceMap)) +getMLSState :: App MLSState +getMLSState = do + ref <- asks (.mls) + liftIO $ readIORef ref + +setMLSState :: MLSState -> App () +setMLSState s = do + ref <- asks (.mls) + liftIO $ writeIORef ref s + +modifyMLSState :: (MLSState -> MLSState) -> App () +modifyMLSState f = do + ref <- asks (.mls) + liftIO $ modifyIORef ref f + +getBaseDir :: App FilePath +getBaseDir = fmap (.baseDir) getMLSState + data AppFailure = AppFailure String instance Show AppFailure where @@ -133,7 +154,7 @@ assertJust _ (Just x) = pure x assertJust msg Nothing = assertFailure msg addFailureContext :: String -> App a -> App a -addFailureContext msg = modifyFailureMsg (\m -> m <> "\nThis failure happend in this context:\n" <> msg) +addFailureContext msg = modifyFailureMsg (\m -> m <> "\nThis failure happened in this context:\n" <> msg) modifyFailureMsg :: (String -> String) -> App a -> App a modifyFailureMsg modMessage = modifyFailure (\e -> e {msg = modMessage e.msg}) diff --git a/libs/extended/default.nix b/libs/extended/default.nix index f940aef369..7a70d62f53 100644 --- a/libs/extended/default.nix +++ b/libs/extended/default.nix @@ -4,6 +4,7 @@ # dependencies are added or removed. { mkDerivation , aeson +, amqp , base , bytestring , cassandra-util @@ -18,13 +19,16 @@ , imports , lib , metrics-wai +, monad-control , optparse-applicative , resourcet +, retry , servant , servant-server , servant-swagger , string-conversions , temporary +, text , tinylog , wai }: @@ -34,6 +38,7 @@ mkDerivation { src = gitignoreSource ./.; libraryHaskellDepends = [ aeson + amqp base bytestring cassandra-util @@ -44,12 +49,15 @@ mkDerivation { http-types imports metrics-wai + monad-control optparse-applicative resourcet + retry servant servant-server servant-swagger string-conversions + text tinylog wai ]; diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index bd04352e35..06c766a8f4 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -17,7 +17,9 @@ license-file: LICENSE build-type: Simple library + -- cabal-fmt: expand src exposed-modules: + Network.AMQP.Extended Options.Applicative.Extended Servant.API.Extended Servant.API.Extended.RawM @@ -74,6 +76,7 @@ library build-depends: aeson + , amqp , base , bytestring , cassandra-util @@ -84,12 +87,15 @@ library , http-types , imports , metrics-wai + , monad-control , optparse-applicative , resourcet + , retry , servant , servant-server , servant-swagger , string-conversions + , text , tinylog , wai diff --git a/libs/extended/src/Network/AMQP/Extended.hs b/libs/extended/src/Network/AMQP/Extended.hs new file mode 100644 index 0000000000..7a5665069c --- /dev/null +++ b/libs/extended/src/Network/AMQP/Extended.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE NumericUnderscores #-} + +module Network.AMQP.Extended where + +import Control.Monad.Catch +import Control.Monad.Trans.Control +import Control.Retry +import qualified Data.Text as Text +import Imports +import qualified Network.AMQP as Q +import System.Logger (Logger) +import qualified System.Logger as Log + +data RabbitMqHooks m = RabbitMqHooks + { -- | Called whenever there is a new channel. At any time there should be at + -- max 1 open channel. Perhaps this would need to change in future. + onNewChannel :: Q.Channel -> m (), + -- | Called when connection is closed. Any exceptions thrown by this would + -- be logged and ignored. + onConnectionClose :: m (), + -- | Called when the channel is closed. Any exceptions thrown by this would + -- be logged and ignored. + onChannelException :: SomeException -> m () + } + +-- | Connects with RabbitMQ and opens a channel. If the channel is closed for +-- some reasons, reopens the channel. If the connection is closed for some +-- reasons, keeps retrying to connect until it works. +openConnectionWithRetries :: + forall m. + (MonadIO m, MonadMask m, MonadBaseControl IO m) => + Logger -> + String -> + Int -> + Text -> + RabbitMqHooks m -> + m () +openConnectionWithRetries l host port vHost hooks = do + username <- liftIO $ Text.pack <$> getEnv "RABBITMQ_USERNAME" + password <- liftIO $ Text.pack <$> getEnv "RABBITMQ_PASSWORD" + connectWithRetries username password + where + connectWithRetries :: Text -> Text -> m () + connectWithRetries username password = do + -- Jittered exponential backoff with 1ms as starting delay and 5s as max + -- delay. + let policy = capDelay 5_000_000 $ fullJitterBackoff 1000 + logError willRetry e retryStatus = do + Log.err l $ + Log.msg (Log.val "Failed to connect to RabbitMQ") + . Log.field "error" (displayException @SomeException e) + . Log.field "willRetry" willRetry + . Log.field "retryCount" retryStatus.rsIterNumber + recovering + policy + [logRetries (const $ pure True) logError] + ( const $ do + Log.info l $ Log.msg (Log.val "Trying to connect to RabbitMQ") + connect username password + ) + + connect :: Text -> Text -> m () + connect username password = do + conn <- liftIO $ Q.openConnection' host (fromIntegral port) vHost username password + liftBaseWith $ \runInIO -> + Q.addConnectionClosedHandler conn True $ void $ runInIO $ do + hooks.onConnectionClose + `catch` logException l "onConnectionClose hook threw an exception, reconnecting to RabbitMQ anyway" + connectWithRetries username password + openChan conn + + openChan :: Q.Connection -> m () + openChan conn = do + Log.info l $ Log.msg (Log.val "Opening channel with RabbitMQ") + chan <- liftIO $ Q.openChannel conn + liftBaseWith $ \runInIO -> + Q.addChannelExceptionHandler chan (void . runInIO . chanExceptionHandler conn) + Log.info l $ Log.msg (Log.val "RabbitMQ channel opened") + hooks.onNewChannel chan + + chanExceptionHandler :: Q.Connection -> SomeException -> m () + chanExceptionHandler conn e = do + logException l "RabbitMQ channel closed" e + hooks.onChannelException e `catch` logException l "onChannelException hook threw an exception" + case (Q.isNormalChannelClose e, fromException e) of + (True, _) -> + Log.info l $ + Log.msg (Log.val "RabbitMQ channel is closed normally, not attempting to reopen channel") + (_, Just (Q.ConnectionClosedException {})) -> + Log.info l $ + Log.msg (Log.val "RabbitMQ connection is closed, not attempting to reopen channel") + _ -> openChan conn + +logException :: (MonadIO m) => Logger -> String -> SomeException -> m () +logException l m (SomeException e) = do + Log.err l $ + Log.msg m + . Log.field "error" (displayException e) diff --git a/libs/wire-api-federation/default.nix b/libs/wire-api-federation/default.nix index 24fcf21a48..9e3b9f2162 100644 --- a/libs/wire-api-federation/default.nix +++ b/libs/wire-api-federation/default.nix @@ -5,6 +5,7 @@ { mkDerivation , aeson , aeson-pretty +, amqp , base , bytestring , bytestring-conversion @@ -49,6 +50,7 @@ mkDerivation { src = gitignoreSource ./.; libraryHaskellDepends = [ aeson + amqp base bytestring bytestring-conversion diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index d94f1c6096..f344a80ced 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -23,6 +23,7 @@ module Wire.API.Federation.API HasFedEndpoint, HasUnsafeFedEndpoint, fedClient, + fedQueueClient, fedClientIn, unsafeFedClientIn, module Wire.API.MakesFederatedCall, @@ -41,6 +42,7 @@ import Servant.Client.Core import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Cargohold import Wire.API.Federation.API.Galley +import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Client import Wire.API.MakesFederatedCall import Wire.API.Routes.Named @@ -75,6 +77,12 @@ fedClient :: Client m api fedClient = clientIn (Proxy @api) (Proxy @m) +fedQueueClient :: + forall (comp :: Component) (name :: Symbol) m api. + (HasFedEndpoint comp api name, HasClient m api, m ~ FedQueueClient comp) => + Client m api +fedQueueClient = clientIn (Proxy @api) (Proxy @m) + fedClientIn :: forall (comp :: Component) (name :: Symbol) m api. (HasFedEndpoint comp api name, HasClient m api) => 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 6b4b0006fd..e7a52aa1c4 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 @@ -35,11 +35,11 @@ import Wire.API.Conversation.Typing import Wire.API.Error.Galley import Wire.API.Federation.API.Common import Wire.API.Federation.Endpoint -import Wire.API.MLS.Message import Wire.API.MLS.SubConversation import Wire.API.MakesFederatedCall import Wire.API.Message import Wire.API.Routes.Public.Galley.Messaging +import Wire.API.Unreachable import Wire.API.Util.Aeson (CustomEncoded (..)) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) @@ -405,11 +405,11 @@ newtype MessageSendResponse = MessageSendResponse ) newtype LeaveConversationResponse = LeaveConversationResponse - {leaveResponse :: Either RemoveFromConversationError ()} + {leaveResponse :: Either RemoveFromConversationError FailedToProcess} deriving stock (Eq, Show) deriving (ToJSON, FromJSON) - via (Either (CustomEncoded RemoveFromConversationError) ()) + via (Either (CustomEncoded RemoveFromConversationError) FailedToProcess) type UserDeletedNotificationMaxConvs = 1000 @@ -438,7 +438,7 @@ data ConversationUpdateRequest = ConversationUpdateRequest data ConversationUpdateResponse = ConversationUpdateResponseError GalleyError - | ConversationUpdateResponseUpdate ConversationUpdate + | ConversationUpdateResponseUpdate ConversationUpdate FailedToProcess | ConversationUpdateResponseNoChanges deriving stock (Eq, Show, Generic) deriving @@ -463,7 +463,7 @@ data MLSMessageResponse = MLSMessageResponseError GalleyError | MLSMessageResponseProtocolError Text | MLSMessageResponseProposalFailure Wai.Error - | MLSMessageResponseUpdates [ConversationUpdate] UnreachableUsers + | MLSMessageResponseUpdates [ConversationUpdate] (Maybe UnreachableUsers) deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON) via (CustomEncoded MLSMessageResponse) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs new file mode 100644 index 0000000000..44693f3d11 --- /dev/null +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} + +module Wire.API.Federation.BackendNotifications where + +import Control.Exception +import Control.Monad.Except +import Data.Aeson +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import Data.Domain +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import Data.Text.Encoding +import qualified Data.Text.Lazy.Encoding as TL +import Imports +import qualified Network.AMQP as Q +import qualified Network.AMQP.Types as Q +import Network.HTTP.Types +import Servant +import Servant.Client +import Servant.Client.Core +import Servant.Types.SourceT +import Wire.API.Federation.API.Common +import Wire.API.Federation.Client +import Wire.API.Federation.Component +import Wire.API.Federation.Error +import Wire.API.RawJson + +-- | NOTE: Stored in RabbitMQ, any changes to serialization of this object could cause +-- notifications to get lost. +data BackendNotification = BackendNotification + { ownDomain :: Domain, + targetComponent :: Component, + path :: Text, + -- | Using RawJson here allows the backend notification pusher to not parse + -- this body, which could be very large and completely useless to the + -- pusher. This also makes development less clunky as we don't have to + -- create a sum type here for all types of notifications that could exist. + body :: RawJson + } + deriving (Show, Eq) + +instance ToJSON BackendNotification where + toJSON notif = + object + [ "ownDomain" .= notif.ownDomain, + "targetComponent" .= notif.targetComponent, + "path" .= notif.path, + "body" .= TL.decodeUtf8 notif.body.rawJsonBytes + ] + +instance FromJSON BackendNotification where + parseJSON = withObject "BackendNotification" $ \o -> + BackendNotification + <$> o .: "ownDomain" + <*> o .: "targetComponent" + <*> o .: "path" + <*> (RawJson . TL.encodeUtf8 <$> o .: "body") + +type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse + +sendNotification :: FederatorClientEnv -> Component -> Text -> RawJson -> IO (Either FederatorClientError ()) +sendNotification env component path body = + case component of + Brig -> go @'Brig + Galley -> go @'Galley + Cargohold -> go @'Cargohold + where + withoutFirstSlash :: Text -> Text + withoutFirstSlash (Text.stripPrefix "/" -> Just t) = t + withoutFirstSlash t = t + + go :: forall c. KnownComponent c => IO (Either FederatorClientError ()) + go = + runFederatorClient env . void $ + clientIn (Proxy @BackendNotificationAPI) (Proxy @(FederatorClient c)) (withoutFirstSlash path) body + +enqueue :: Q.Channel -> Domain -> Domain -> Q.DeliveryMode -> FedQueueClient c () -> IO () +enqueue channel originDomain targetDomain deliveryMode (FedQueueClient action) = + runReaderT action FedQueueEnv {..} + +routingKey :: Domain -> Text +routingKey d = "backend-notifications." <> domainText d + +-- | If you ever change this function and modify +-- queue parameters, know that it will start failing in the +-- next release! So be prepared to write migrations. +ensureQueue :: Q.Channel -> Domain -> IO () +ensureQueue chan domain = do + let opts = + Q.QueueOpts + { Q.queueName = routingKey domain, + Q.queuePassive = False, + Q.queueDurable = True, + Q.queueExclusive = False, + Q.queueAutoDelete = False, + Q.queueHeaders = + Q.FieldTable $ + Map.fromList + [ ("x-single-active-consumer", Q.FVBool True), + ("x-queue-type", Q.FVString "quorum") + ] + } + void $ Q.declareQueue chan opts + +-- * Internal machinery + +-- | Reads a servant request and puts the information in relevant RabbitMQ +-- queue. Perhaps none of this should be servant code anymore. But it is here to +-- allow smooth transition to RabbitMQ based notification pushing. +-- +-- Use 'Wire.API.Federation.API.fedQueueClient' to create and action and pass it +-- to 'enqueue' +newtype FedQueueClient c a = FedQueueClient (ReaderT FedQueueEnv IO a) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader FedQueueEnv) + +data FedQueueEnv = FedQueueEnv + { channel :: Q.Channel, + originDomain :: Domain, + targetDomain :: Domain, + deliveryMode :: Q.DeliveryMode + } + +data EnqueueError = EnqueueError String + deriving (Show) + +instance Exception EnqueueError + +instance KnownComponent c => RunClient (FedQueueClient c) where + runRequestAcceptStatus :: Maybe [Status] -> Request -> FedQueueClient c Response + runRequestAcceptStatus _ req = do + env <- ask + bodyLBS <- case requestBody req of + Just (RequestBodyLBS lbs, _) -> pure lbs + Just (RequestBodyBS bs, _) -> pure (LBS.fromStrict bs) + Just (RequestBodySource src, _) -> liftIO $ do + errOrRes <- runExceptT $ runSourceT src + either (throwIO . EnqueueError) (pure . mconcat) errOrRes + Nothing -> pure mempty + let notif = + BackendNotification + { ownDomain = env.originDomain, + targetComponent = componentVal @c, + path = decodeUtf8 $ LBS.toStrict $ Builder.toLazyByteString req.requestPath, + body = RawJson bodyLBS + } + let msg = + Q.newMsg + { Q.msgBody = encode notif, + Q.msgDeliveryMode = Just (env.deliveryMode), + Q.msgContentType = Just "application/json" + } + -- Empty string means default exchange + exchange = "" + liftIO $ do + ensureQueue env.channel env.targetDomain + void $ Q.publishMsg env.channel exchange (routingKey env.targetDomain) msg + pure $ + Response + { responseHttpVersion = http20, + responseStatusCode = status200, + responseHeaders = Seq.singleton (hContentType, "application/json"), + responseBody = "{}" + } + throwClientError :: ClientError -> FedQueueClient c a + throwClientError = liftIO . throwIO diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 2fab754002..445c40d732 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -195,11 +195,15 @@ withHTTP2StreamingRequest successfulStatus req handleResponse = do Just (RequestBodyBS bs, _) -> pure (LBS.fromStrict bs) Just (RequestBodySource _, _) -> throwError FederatorClientStreamingNotSupported Nothing -> pure mempty - let req' = + let headers = + toList (requestHeaders req) + <> [(originDomainHeaderName, toByteString' (ceOriginDomain env))] + <> [(HTTP.hAccept, HTTP.renderHeader (toList $ req.requestAccept))] + req' = HTTP2.requestBuilder (requestMethod req) (LBS.toStrict (toLazyByteString path)) - (toList (requestHeaders req) <> [(originDomainHeaderName, toByteString' (ceOriginDomain env))]) + headers (lazyByteString body) let Endpoint (Text.encodeUtf8 -> hostname) (fromIntegral -> port) = ceFederator env resp <- diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs index 5bc03b0398..0acf15af8b 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs @@ -42,7 +42,10 @@ spec = testObjects [ (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus1, "testObject_MLSMessageSendingStatus1.json"), (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus2, "testObject_MLSMessageSendingStatus2.json"), - (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus3, "testObject_MLSMessageSendingStatus3.json") + (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus3, "testObject_MLSMessageSendingStatus3.json"), + (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus4, "testObject_MLSMessageSendingStatus4.json"), + (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus5, "testObject_MLSMessageSendingStatus5.json"), + (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus6, "testObject_MLSMessageSendingStatus6.json") ] testObjects [(LeaveConversationRequest.testObject_LeaveConversationRequest1, "testObject_LeaveConversationRequest1.json")] testObjects diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs index 05137a2713..0620028b18 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/LeaveConversationResponse.hs @@ -21,7 +21,7 @@ import Imports import Wire.API.Federation.API.Galley testObject_LeaveConversationResponse1 :: LeaveConversationResponse -testObject_LeaveConversationResponse1 = LeaveConversationResponse $ Right () +testObject_LeaveConversationResponse1 = LeaveConversationResponse $ Right mempty testObject_LeaveConversationResponse2 :: LeaveConversationResponse testObject_LeaveConversationResponse2 = LeaveConversationResponse $ Left RemoveFromConversationErrorRemovalNotAllowed diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs index 0e228bec42..16226c28cf 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/MLSMessageSendingStatus.hs @@ -24,13 +24,14 @@ import Data.Qualified import qualified Data.UUID as UUID import Imports import Wire.API.MLS.Message +import Wire.API.Unreachable testObject_MLSMessageSendingStatus1 :: MLSMessageSendingStatus testObject_MLSMessageSendingStatus1 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "1864-04-12 12:22:43.673 UTC"), - mmssUnreachableUsers = UnreachableUsers [] + mmssUnreachableUsers = mempty } testObject_MLSMessageSendingStatus2 :: MLSMessageSendingStatus @@ -38,7 +39,7 @@ testObject_MLSMessageSendingStatus2 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "2001-04-12 12:22:43.673 UTC"), - mmssUnreachableUsers = failed1 + mmssUnreachableUsers = unreachableFromList failed1 } testObject_MLSMessageSendingStatus3 :: MLSMessageSendingStatus @@ -46,18 +47,42 @@ testObject_MLSMessageSendingStatus3 = MLSMessageSendingStatus { mmssEvents = [], mmssTime = toUTCTimeMillis (read "1999-04-12 12:22:43.673 UTC"), - mmssUnreachableUsers = failed2 + mmssUnreachableUsers = unreachableFromList failed2 } -failed1 :: UnreachableUsers +testObject_MLSMessageSendingStatus4 :: MLSMessageSendingStatus +testObject_MLSMessageSendingStatus4 = + MLSMessageSendingStatus + { mmssEvents = [], + mmssTime = toUTCTimeMillis (read "2023-04-12 12:22:43.673 UTC"), + mmssUnreachableUsers = unreachableFromList failed1 + } + +testObject_MLSMessageSendingStatus5 :: MLSMessageSendingStatus +testObject_MLSMessageSendingStatus5 = + MLSMessageSendingStatus + { mmssEvents = [], + mmssTime = toUTCTimeMillis (read "1901-04-12 12:22:43.673 UTC"), + mmssUnreachableUsers = unreachableFromList failed2 + } + +testObject_MLSMessageSendingStatus6 :: MLSMessageSendingStatus +testObject_MLSMessageSendingStatus6 = + MLSMessageSendingStatus + { mmssEvents = [], + mmssTime = toUTCTimeMillis (read "1905-04-12 12:22:43.673 UTC"), + mmssUnreachableUsers = unreachableFromList failed1 <> unreachableFromList failed2 + } + +failed1 :: [Qualified UserId] failed1 = let domain = Domain "offline.example.com" - in UnreachableUsers [Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain] + in [Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain] -failed2 :: UnreachableUsers +failed2 :: [Qualified UserId] failed2 = let domain = Domain "golden.example.com" - in UnreachableUsers - [ Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000200000008") domain, - Qualified (Id . fromJust . UUID.fromString $ "00000000-0000-0000-0000-000100000007") domain - ] + in flip Qualified domain . Id . fromJust . UUID.fromString + <$> [ "00000000-0000-0000-0000-000200000008", + "00000000-0000-0000-0000-000100000007" + ] diff --git a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json b/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json index 5ce20f1d24..31e2f71f18 100644 --- a/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json +++ b/libs/wire-api-federation/test/golden/testObject_LeaveConversationResponse1.json @@ -1,3 +1,3 @@ { - "Right": [] + "Right": {} } \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json index 9323f7742e..dcd87fe946 100644 --- a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus1.json @@ -1,5 +1,4 @@ { - "events": [], - "time": "1864-04-12T12:22:43.673Z", - "failed_to_send": [] -} + "events": [], + "time": "1864-04-12T12:22:43.673Z" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json new file mode 100644 index 0000000000..ecc3d04f8a --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus4.json @@ -0,0 +1,10 @@ +{ + "events": [], + "failed_to_send": [ + { + "domain": "offline.example.com", + "id": "00000000-0000-0000-0000-000200000008" + } + ], + "time": "2023-04-12T12:22:43.673Z" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json new file mode 100644 index 0000000000..44d6fbdb7c --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus5.json @@ -0,0 +1,14 @@ +{ + "events": [], + "failed_to_send": [ + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000200000008" + }, + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100000007" + } + ], + "time": "1901-04-12T12:22:43.673Z" +} \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json new file mode 100644 index 0000000000..cad9aa0d9a --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_MLSMessageSendingStatus6.json @@ -0,0 +1,18 @@ +{ + "events": [], + "failed_to_send": [ + { + "domain": "offline.example.com", + "id": "00000000-0000-0000-0000-000200000008" + }, + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000200000008" + }, + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100000007" + } + ], + "time": "1905-04-12T12:22:43.673Z" +} \ No newline at end of file diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index abe5ab3d9c..3809ad17ff 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -21,6 +21,7 @@ library Wire.API.Federation.API.Cargohold Wire.API.Federation.API.Common Wire.API.Federation.API.Galley + Wire.API.Federation.BackendNotifications Wire.API.Federation.Client Wire.API.Federation.Component Wire.API.Federation.Domain @@ -80,6 +81,7 @@ library build-depends: aeson >=2.0.1.0 + , amqp , base >=4.6 && <5.0 , bytestring , bytestring-conversion diff --git a/libs/wire-api/src/Wire/API/MLS/Message.hs b/libs/wire-api/src/Wire/API/MLS/Message.hs index 1787ceab4b..cfeae25018 100644 --- a/libs/wire-api/src/Wire/API/MLS/Message.hs +++ b/libs/wire-api/src/Wire/API/MLS/Message.hs @@ -37,7 +37,6 @@ module Wire.API.MLS.Message MLSCipherTextSym0, MLSMessageSendingStatus (..), KnownFormatTag (..), - UnreachableUsers (..), verifyMessageSignature, mkSignedMessage, ) @@ -50,10 +49,8 @@ import Data.Binary import Data.Binary.Get import Data.Binary.Put import qualified Data.ByteArray as BA -import Data.Id import Data.Json.Util import Data.Kind -import Data.Qualified import Data.Schema import Data.Singletons.TH import qualified Data.Swagger as S @@ -67,6 +64,7 @@ import Wire.API.MLS.Group import Wire.API.MLS.KeyPackage import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation +import Wire.API.Unreachable import Wire.Arbitrary (GenericUniform (..)) data WireFormatTag = MLSPlainText | MLSCipherText @@ -318,22 +316,10 @@ instance SerialiseMLS (MessagePayload 'MLSPlainText) where -- so the next case is left as a stub serialiseMLS _ = pure () -newtype UnreachableUsers = UnreachableUsers {unreachableUsers :: [Qualified UserId]} - deriving stock (Eq, Show) - deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUsers - deriving newtype (Semigroup, Monoid) - -instance ToSchema UnreachableUsers where - schema = - named "UnreachableUsers" $ - UnreachableUsers - <$> unreachableUsers - .= array schema - data MLSMessageSendingStatus = MLSMessageSendingStatus { mmssEvents :: [Event], mmssTime :: UTCTimeMillis, - mmssUnreachableUsers :: UnreachableUsers + mmssUnreachableUsers :: Maybe UnreachableUsers } deriving (Eq, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema MLSMessageSendingStatus @@ -353,10 +339,12 @@ instance ToSchema MLSMessageSendingStatus where (description ?~ "The time of sending the message.") schema <*> mmssUnreachableUsers - .= fieldWithDocModifier - "failed_to_send" - (description ?~ "List of federated users who could not be reached and did not receive the message") - schema + .= maybe_ + ( optFieldWithDocModifier + "failed_to_send" + (description ?~ "List of federated users who could not be reached and did not receive the message") + schema + ) verifyMessageSignature :: CipherSuiteTag -> Message 'MLSPlainText -> ByteString -> Bool verifyMessageSignature cs msg pubkey = diff --git a/libs/wire-api/src/Wire/API/MakesFederatedCall.hs b/libs/wire-api/src/Wire/API/MakesFederatedCall.hs index 0e0f627db4..6edc1b6d63 100644 --- a/libs/wire-api/src/Wire/API/MakesFederatedCall.hs +++ b/libs/wire-api/src/Wire/API/MakesFederatedCall.hs @@ -31,11 +31,12 @@ module Wire.API.MakesFederatedCall ) where -import Data.Aeson (Value (..)) +import Data.Aeson import Data.Constraint import Data.Kind import Data.Metrics.Servant import Data.Proxy +import Data.Schema import Data.Swagger.Operation (addExtensions) import qualified Data.Text as T import GHC.TypeLits @@ -78,6 +79,16 @@ data Component | Cargohold deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform Component) + deriving (ToJSON, FromJSON) via (Schema Component) + +instance ToSchema Component where + schema = + enum @Text "Component" $ + mconcat + [ element "brig" Brig, + element "galley" Galley, + element "cargohold" Cargohold + ] -- | A typeclass corresponding to calls to federated services. This class has -- no methods, and exists only to automatically propagate information up to diff --git a/libs/wire-api/src/Wire/API/OAuth.hs b/libs/wire-api/src/Wire/API/OAuth.hs index 21d8b3a85e..d5c9333070 100644 --- a/libs/wire-api/src/Wire/API/OAuth.hs +++ b/libs/wire-api/src/Wire/API/OAuth.hs @@ -100,18 +100,18 @@ newtype OAuthApplicationName = OAuthApplicationName {unOAuthApplicationName :: R instance ToSchema OAuthApplicationName where schema = OAuthApplicationName <$> unOAuthApplicationName .= schema -data RegisterOAuthClientRequest = RegisterOAuthClientRequest +data OAuthClientConfig = OAuthClientConfig { applicationName :: OAuthApplicationName, redirectUrl :: RedirectUrl } deriving (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform RegisterOAuthClientRequest) - deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema RegisterOAuthClientRequest) + deriving (Arbitrary) via (GenericUniform OAuthClientConfig) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema OAuthClientConfig) -instance ToSchema RegisterOAuthClientRequest where +instance ToSchema OAuthClientConfig where schema = - object "RegisterOAuthClientRequest" $ - RegisterOAuthClientRequest + object "OAuthClientConfig" $ + OAuthClientConfig <$> applicationName .= fieldWithDocModifier "application_name" applicationNameDescription schema <*> (.redirectUrl) .= fieldWithDocModifier "redirect_url" redirectUrlDescription schema where diff --git a/libs/wire-api/src/Wire/API/RawJson.hs b/libs/wire-api/src/Wire/API/RawJson.hs index 5a3f621589..3f2d209698 100644 --- a/libs/wire-api/src/Wire/API/RawJson.hs +++ b/libs/wire-api/src/Wire/API/RawJson.hs @@ -36,6 +36,9 @@ newtype RawJson = RawJson {rawJsonBytes :: LByteString} instance {-# OVERLAPPING #-} MimeUnrender JSON RawJson where mimeUnrender _ = pure . RawJson +instance MimeRender JSON RawJson where + mimeRender _ = rawJsonBytes + instance Swagger.ToSchema RawJson where declareNamedSchema _ = pure . Swagger.NamedSchema (Just "RawJson") $ diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs index a4e24b58ec..a8a2747af7 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs @@ -17,6 +17,7 @@ module Wire.API.Routes.Internal.Brig.OAuth where +import Data.Id (OAuthClientId) import Servant (JSON) import Servant hiding (Handler, JSON, Tagged, addHeader, respond) import Servant.Swagger.Internal.Orphans () @@ -34,6 +35,37 @@ type OAuthAPI = :> CanThrow 'OAuthFeatureDisabled :> "oauth" :> "clients" - :> ReqBody '[JSON] RegisterOAuthClientRequest + :> ReqBody '[JSON] OAuthClientConfig :> Post '[JSON] OAuthClientCredentials ) + :<|> Named + "get-oauth-client" + ( Summary "Get OAuth client by id" + :> CanThrow 'OAuthFeatureDisabled + :> CanThrow 'OAuthClientNotFound + :> "oauth" + :> "clients" + :> Capture "id" OAuthClientId + :> Get '[JSON] OAuthClient + ) + :<|> Named + "update-oauth-client" + ( Summary "Update OAuth client" + :> CanThrow 'OAuthFeatureDisabled + :> CanThrow 'OAuthClientNotFound + :> "oauth" + :> "clients" + :> Capture "id" OAuthClientId + :> ReqBody '[JSON] OAuthClientConfig + :> Put '[JSON] OAuthClient + ) + :<|> Named + "delete-oauth-client" + ( Summary "Delete OAuth client" + :> CanThrow 'OAuthFeatureDisabled + :> CanThrow 'OAuthClientNotFound + :> "oauth" + :> "clients" + :> Capture "id" OAuthClientId + :> Delete '[JSON] () + ) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 10d05e8d3f..c656f810e6 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -58,6 +58,7 @@ module Wire.API.Team.Feature defFeatureStatusNoLock, computeFeatureConfigForTeamUser, IsFeatureConfig (..), + FeatureSingleton (..), FeatureTrivialConfig (..), HasDeprecatedFeatureName (..), LockStatusResponse (..), @@ -124,15 +125,16 @@ import Wire.Arbitrary (Arbitrary, GenericUniform (..)) -- 1. Add a data type for your feature's "config" part, naming convention: -- **Config**. If your feature doesn't have a config besides -- being enabled/disabled, locked/unlocked, then the config should be a unit --- type, e.g. **data MyFeatureConfig = MyFeatureConfig**. Implement type classes --- 'ToSchema', 'IsFeatureConfig' and 'Arbitrary'. If your feature doesn't have a --- config implement 'FeatureTrivialConfig'. +-- type, e.g. **data MyFeatureConfig = MyFeatureConfig**. Add a singleton for +-- the new data type. Implement type classes 'ToSchema', 'IsFeatureConfig' and +-- 'Arbitrary'. If your feature doesn't have a config implement +-- 'FeatureTrivialConfig'. -- -- 2. Add the config to to 'AllFeatureConfigs'. -- -- 3. If your feature is configurable on a per-team basis, add a schema --- migration in galley and add 'FeatureStatusCassandra' instance in --- Galley.Cassandra.TeamFeatures together with a schema migration +-- migration in galley and extend 'getFeatureStatus' and similar functions in +-- Galley.Cassandra.TeamFeatures -- -- 4. Add the feature to the config schema of galley in Galley.Types.Teams. -- and extend the Arbitrary instance of FeatureConfigs in the unit tests Test.Galley.Types @@ -167,6 +169,7 @@ import Wire.Arbitrary (Arbitrary, GenericUniform (..)) class IsFeatureConfig cfg where type FeatureSymbol cfg :: Symbol defFeatureStatus :: WithStatus cfg + featureSingleton :: FeatureSingleton cfg objectSchema :: -- | Should be "pure MyFeatureConfig" if the feature doesn't have config, @@ -174,6 +177,25 @@ class IsFeatureConfig cfg where -- omitted/ignored in the JSON encoder / parser. ObjectSchema SwaggerDoc cfg +data FeatureSingleton cfg where + FeatureSingletonGuestLinksConfig :: FeatureSingleton GuestLinksConfig + FeatureSingletonLegalholdConfig :: FeatureSingleton LegalholdConfig + FeatureSingletonSSOConfig :: FeatureSingleton SSOConfig + FeatureSingletonSearchVisibilityAvailableConfig :: FeatureSingleton SearchVisibilityAvailableConfig + FeatureSingletonValidateSAMLEmailsConfig :: FeatureSingleton ValidateSAMLEmailsConfig + FeatureSingletonDigitalSignaturesConfig :: FeatureSingleton DigitalSignaturesConfig + FeatureSingletonConferenceCallingConfig :: FeatureSingleton ConferenceCallingConfig + FeatureSingletonSndFactorPasswordChallengeConfig :: FeatureSingleton SndFactorPasswordChallengeConfig + FeatureSingletonSearchVisibilityInboundConfig :: FeatureSingleton SearchVisibilityInboundConfig + FeatureSingletonClassifiedDomainsConfig :: FeatureSingleton ClassifiedDomainsConfig + FeatureSingletonAppLockConfig :: FeatureSingleton AppLockConfig + FeatureSingletonSelfDeletingMessagesConfig :: FeatureSingleton SelfDeletingMessagesConfig + FeatureSingletonFileSharingConfig :: FeatureSingleton FileSharingConfig + FeatureSingletonMLSConfig :: FeatureSingleton MLSConfig + FeatureSingletonExposeInvitationURLsToTeamAdminConfig :: FeatureSingleton ExposeInvitationURLsToTeamAdminConfig + FeatureSingletonOutlookCalIntegrationConfig :: FeatureSingleton OutlookCalIntegrationConfig + FeatureSingletonMlsE2EIdConfig :: FeatureSingleton MlsE2EIdConfig + class FeatureTrivialConfig cfg where trivialConfig :: cfg @@ -552,6 +574,7 @@ instance ToSchema GuestLinksConfig where instance IsFeatureConfig GuestLinksConfig where type FeatureSymbol GuestLinksConfig = "conversationGuestLinks" defFeatureStatus = withStatus FeatureStatusEnabled LockStatusUnlocked GuestLinksConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonGuestLinksConfig objectSchema = pure GuestLinksConfig @@ -568,6 +591,7 @@ data LegalholdConfig = LegalholdConfig instance IsFeatureConfig LegalholdConfig where type FeatureSymbol LegalholdConfig = "legalhold" defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked LegalholdConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonLegalholdConfig objectSchema = pure LegalholdConfig instance ToSchema LegalholdConfig where @@ -586,6 +610,7 @@ data SSOConfig = SSOConfig instance IsFeatureConfig SSOConfig where type FeatureSymbol SSOConfig = "sso" defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked SSOConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonSSOConfig objectSchema = pure SSOConfig instance ToSchema SSOConfig where @@ -606,6 +631,7 @@ data SearchVisibilityAvailableConfig = SearchVisibilityAvailableConfig instance IsFeatureConfig SearchVisibilityAvailableConfig where type FeatureSymbol SearchVisibilityAvailableConfig = "searchVisibility" defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonSearchVisibilityAvailableConfig objectSchema = pure SearchVisibilityAvailableConfig instance ToSchema SearchVisibilityAvailableConfig where @@ -630,6 +656,7 @@ instance ToSchema ValidateSAMLEmailsConfig where instance IsFeatureConfig ValidateSAMLEmailsConfig where type FeatureSymbol ValidateSAMLEmailsConfig = "validateSAMLemails" defFeatureStatus = withStatus FeatureStatusEnabled LockStatusUnlocked ValidateSAMLEmailsConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonValidateSAMLEmailsConfig objectSchema = pure ValidateSAMLEmailsConfig instance HasDeprecatedFeatureName ValidateSAMLEmailsConfig where @@ -648,6 +675,7 @@ data DigitalSignaturesConfig = DigitalSignaturesConfig instance IsFeatureConfig DigitalSignaturesConfig where type FeatureSymbol DigitalSignaturesConfig = "digitalSignatures" defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked DigitalSignaturesConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonDigitalSignaturesConfig objectSchema = pure DigitalSignaturesConfig instance HasDeprecatedFeatureName DigitalSignaturesConfig where @@ -669,6 +697,7 @@ data ConferenceCallingConfig = ConferenceCallingConfig instance IsFeatureConfig ConferenceCallingConfig where type FeatureSymbol ConferenceCallingConfig = "conferenceCalling" defFeatureStatus = withStatus FeatureStatusEnabled LockStatusUnlocked ConferenceCallingConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonConferenceCallingConfig objectSchema = pure ConferenceCallingConfig instance ToSchema ConferenceCallingConfig where @@ -690,6 +719,7 @@ instance ToSchema SndFactorPasswordChallengeConfig where instance IsFeatureConfig SndFactorPasswordChallengeConfig where type FeatureSymbol SndFactorPasswordChallengeConfig = "sndFactorPasswordChallenge" defFeatureStatus = withStatus FeatureStatusDisabled LockStatusLocked SndFactorPasswordChallengeConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonSndFactorPasswordChallengeConfig objectSchema = pure SndFactorPasswordChallengeConfig instance FeatureTrivialConfig SndFactorPasswordChallengeConfig where @@ -706,6 +736,7 @@ data SearchVisibilityInboundConfig = SearchVisibilityInboundConfig instance IsFeatureConfig SearchVisibilityInboundConfig where type FeatureSymbol SearchVisibilityInboundConfig = "searchVisibilityInbound" defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityInboundConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonSearchVisibilityInboundConfig objectSchema = pure SearchVisibilityInboundConfig instance ToSchema SearchVisibilityInboundConfig where @@ -740,6 +771,7 @@ instance IsFeatureConfig ClassifiedDomainsConfig where LockStatusUnlocked (ClassifiedDomainsConfig []) FeatureTTLUnlimited + featureSingleton = FeatureSingletonClassifiedDomainsConfig objectSchema = field "config" schema ---------------------------------------------------------------------- @@ -769,6 +801,7 @@ instance IsFeatureConfig AppLockConfig where LockStatusUnlocked (AppLockConfig (EnforceAppLock False) 60) FeatureTTLUnlimited + featureSingleton = FeatureSingletonAppLockConfig objectSchema = field "config" schema newtype EnforceAppLock = EnforceAppLock Bool @@ -789,6 +822,7 @@ data FileSharingConfig = FileSharingConfig instance IsFeatureConfig FileSharingConfig where type FeatureSymbol FileSharingConfig = "fileSharing" defFeatureStatus = withStatus FeatureStatusEnabled LockStatusUnlocked FileSharingConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonFileSharingConfig objectSchema = pure FileSharingConfig instance ToSchema FileSharingConfig where @@ -821,6 +855,7 @@ instance IsFeatureConfig SelfDeletingMessagesConfig where LockStatusUnlocked (SelfDeletingMessagesConfig 0) FeatureTTLUnlimited + featureSingleton = FeatureSingletonSelfDeletingMessagesConfig objectSchema = field "config" schema ---------------------------------------------------------------------- @@ -849,6 +884,7 @@ instance IsFeatureConfig MLSConfig where defFeatureStatus = let config = MLSConfig [] ProtocolProteusTag [MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519] MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 in withStatus FeatureStatusDisabled LockStatusUnlocked config FeatureTTLUnlimited + featureSingleton = FeatureSingletonMLSConfig objectSchema = field "config" schema ---------------------------------------------------------------------- @@ -861,6 +897,7 @@ data ExposeInvitationURLsToTeamAdminConfig = ExposeInvitationURLsToTeamAdminConf instance IsFeatureConfig ExposeInvitationURLsToTeamAdminConfig where type FeatureSymbol ExposeInvitationURLsToTeamAdminConfig = "exposeInvitationURLsToTeamAdmin" defFeatureStatus = withStatus FeatureStatusDisabled LockStatusLocked ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonExposeInvitationURLsToTeamAdminConfig objectSchema = pure ExposeInvitationURLsToTeamAdminConfig instance ToSchema ExposeInvitationURLsToTeamAdminConfig where @@ -881,6 +918,7 @@ data OutlookCalIntegrationConfig = OutlookCalIntegrationConfig instance IsFeatureConfig OutlookCalIntegrationConfig where type FeatureSymbol OutlookCalIntegrationConfig = "outlookCalIntegration" defFeatureStatus = withStatus FeatureStatusDisabled LockStatusLocked OutlookCalIntegrationConfig FeatureTTLUnlimited + featureSingleton = FeatureSingletonOutlookCalIntegrationConfig objectSchema = pure OutlookCalIntegrationConfig instance ToSchema OutlookCalIntegrationConfig where @@ -938,6 +976,7 @@ instance IsFeatureConfig MlsE2EIdConfig where defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked defValue FeatureTTLUnlimited where defValue = MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing + featureSingleton = FeatureSingletonMlsE2EIdConfig objectSchema = field "config" schema ---------------------------------------------------------------------- diff --git a/libs/wire-api/src/Wire/API/Unreachable.hs b/libs/wire-api/src/Wire/API/Unreachable.hs new file mode 100644 index 0000000000..69725e53d0 --- /dev/null +++ b/libs/wire-api/src/Wire/API/Unreachable.hs @@ -0,0 +1,127 @@ +-- 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 . + +-- | Types and utilies around unreachable backends and failing to process +-- various kinds of messages. +module Wire.API.Unreachable + ( -- * Failed to process + UnreachableUsers (unreachableUsers), + unreachableFromList, + FailedToProcess (..), + failedToProcessObjectSchema, + failedToSend, + failedToSendMaybe, + failedToAdd, + failedToAddMaybe, + failedToRemove, + failedToRemoveMaybe, + ) +where + +import Control.Lens ((?~)) +import qualified Data.Aeson as A +import Data.Id +import Data.List.NonEmpty +import qualified Data.List.NonEmpty as NE +import Data.Qualified +import Data.Schema +import qualified Data.Swagger as S +import Imports + +newtype UnreachableUsers = UnreachableUsers {unreachableUsers :: NonEmpty (Qualified UserId)} + deriving stock (Eq, Show) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema UnreachableUsers + +instance Semigroup UnreachableUsers where + (UnreachableUsers m) <> (UnreachableUsers n) = UnreachableUsers . NE.nub $ m <> n + +instance ToSchema UnreachableUsers where + schema = + named "UnreachableUsers" $ + UnreachableUsers + <$> unreachableUsers + .= nonEmptyArray schema + +unreachableFromList :: [Qualified UserId] -> Maybe UnreachableUsers +unreachableFromList = fmap (UnreachableUsers . NE.nub) . nonEmpty + +-- | Lists of remote users that could not be processed in a federated action, +-- e.g., a message could not be sent to these remote users. +data FailedToProcess = FailedToProcess + { send :: Maybe UnreachableUsers, + add :: Maybe UnreachableUsers, + remove :: Maybe UnreachableUsers + } + deriving (Eq, Show) + deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema FailedToProcess + +instance Semigroup FailedToProcess where + ftp1 <> ftp2 = + FailedToProcess + { send = send ftp1 <> send ftp2, + add = add ftp1 <> add ftp2, + remove = remove ftp1 <> remove ftp2 + } + +instance Monoid FailedToProcess where + mempty = FailedToProcess mempty mempty mempty + +failedToProcessObjectSchema :: ObjectSchema SwaggerDoc FailedToProcess +failedToProcessObjectSchema = + FailedToProcess + <$> send + .= maybe_ + ( optFieldWithDocModifier + "failed_to_send" + (description ?~ "List of federated users who could not be reached and did not receive the message") + (unnamed schema) + ) + <*> add + .= maybe_ + ( optFieldWithDocModifier + "failed_to_add" + (description ?~ "List of federated users who could not be reached and be added to a conversation") + (unnamed schema) + ) + <*> remove + .= maybe_ + ( optFieldWithDocModifier + "failed_to_remove" + (description ?~ "List of federated users who could not be reached and be removed from a conversation") + (unnamed schema) + ) + +instance ToSchema FailedToProcess where + schema = object "FailedToProcess" failedToProcessObjectSchema + +failedToSend :: [Qualified UserId] -> FailedToProcess +failedToSend = failedToSendMaybe . unreachableFromList + +failedToSendMaybe :: Maybe UnreachableUsers -> FailedToProcess +failedToSendMaybe us = mempty {send = us} + +failedToAdd :: [Qualified UserId] -> FailedToProcess +failedToAdd = failedToAddMaybe . unreachableFromList + +failedToAddMaybe :: Maybe UnreachableUsers -> FailedToProcess +failedToAddMaybe us = mempty {add = us} + +failedToRemove :: [Qualified UserId] -> FailedToProcess +failedToRemove = failedToRemoveMaybe . unreachableFromList + +failedToRemoveMaybe :: Maybe UnreachableUsers -> FailedToProcess +failedToRemoveMaybe us = mempty {remove = us} diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index 23b7ebdb7d..7464f2e3b9 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -149,7 +149,7 @@ tests = testRoundTrip @Message.ClientMismatch, testRoundTrip @OAuth.RedirectUrl, testRoundTrip @OAuth.OAuthApplicationName, - testRoundTrip @OAuth.RegisterOAuthClientRequest, + testRoundTrip @OAuth.OAuthClientConfig, testRoundTrip @OAuth.OAuthClient, testRoundTrip @OAuth.CreateOAuthAuthorizationCodeRequest, testRoundTrip @OAuth.OAuthAccessTokenRequest, diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index c6502a4b0c..06d4891471 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -138,6 +138,7 @@ library Wire.API.Team.Role Wire.API.Team.SearchVisibility Wire.API.Team.Size + Wire.API.Unreachable Wire.API.User Wire.API.User.Activation Wire.API.User.Auth diff --git a/nix/local-haskell-packages.nix b/nix/local-haskell-packages.nix index 0a2fb873aa..73d30174da 100644 --- a/nix/local-haskell-packages.nix +++ b/nix/local-haskell-packages.nix @@ -35,6 +35,7 @@ wire-api = hself.callPackage ../libs/wire-api/default.nix { inherit gitignoreSource; }; wire-message-proto-lens = hself.callPackage ../libs/wire-message-proto-lens/default.nix { inherit gitignoreSource; }; zauth = hself.callPackage ../libs/zauth/default.nix { inherit gitignoreSource; }; + background-worker = hself.callPackage ../services/background-worker/default.nix { inherit gitignoreSource; }; brig = hself.callPackage ../services/brig/default.nix { inherit gitignoreSource; }; cannon = hself.callPackage ../services/cannon/default.nix { inherit gitignoreSource; }; cargohold = hself.callPackage ../services/cargohold/default.nix { inherit gitignoreSource; }; diff --git a/nix/overlay.nix b/nix/overlay.nix index 2d73416ebd..3bcd85b5a1 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -101,5 +101,5 @@ self: super: { inherit (super) stdenv fetchurl; }; - rabbitmqadmin = super.callPackage ./pkgs/rabbitmqadmin {}; + rabbitmqadmin = super.callPackage ./pkgs/rabbitmqadmin { }; } diff --git a/nix/pkgs/rabbitmqadmin/default.nix b/nix/pkgs/rabbitmqadmin/default.nix index 0aa51355b1..f659aa34f6 100644 --- a/nix/pkgs/rabbitmqadmin/default.nix +++ b/nix/pkgs/rabbitmqadmin/default.nix @@ -1,4 +1,4 @@ -{stdenv, python3, fetchgit}: +{ stdenv, python3, fetchgit }: stdenv.mkDerivation rec { name = "rabbitmqadmin"; version = "3.11.13"; @@ -9,7 +9,7 @@ stdenv.mkDerivation rec { sha256 = "sha256-lbOuxJz66xlGlgodbz8Xlb3hcaewVFMqf9R/5XlqaAY="; }; - propagatedBuildInputs = [python3]; + propagatedBuildInputs = [ python3 ]; dontBuild = true; diff --git a/nix/wire-server.nix b/nix/wire-server.nix index b39279b296..6ee3771a6b 100644 --- a/nix/wire-server.nix +++ b/nix/wire-server.nix @@ -85,6 +85,7 @@ let inconsistencies = [ "inconsistencies" ]; api-simulations = [ "api-smoketest" "api-loadtest" ]; zauth = [ "zauth" ]; + background-worker = [ "background-worker" ]; integration = [ "integration" ]; }; diff --git a/services/background-worker/LICENSE b/services/background-worker/LICENSE new file mode 100644 index 0000000000..dba13ed2dd --- /dev/null +++ b/services/background-worker/LICENSE @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU Affero General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero General Public License from time to time. Such new versions +will be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU Affero General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU Affero General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU Affero General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + 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 . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU AGPL, see +. diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal new file mode 100644 index 0000000000..bbe3e41eec --- /dev/null +++ b/services/background-worker/background-worker.cabal @@ -0,0 +1,210 @@ +cabal-version: 1.24 +name: background-worker +version: 0.1.0.0 +synopsis: Runs background work +license: AGPL-3 +license-file: LICENSE +author: Wire Swiss GmbH +maintainer: backend@wire.com +category: Network +build-type: Simple + +library + -- cabal-fmt: expand src + exposed-modules: + Wire.BackendNotificationPusher + Wire.BackgroundWorker + Wire.BackgroundWorker.Env + Wire.BackgroundWorker.Options + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -funbox-strict-fields -Wredundant-constraints -Wunused-packages + + build-depends: + aeson + , amqp + , exceptions + , extended + , HsOpenSSL + , http2-manager + , imports + , monad-control + , retry + , tinylog + , transformers-base + , types-common + , wire-api-federation + + default-extensions: + NoImplicitPrelude + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + PackageImports + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances + ViewPatterns + +executable background-worker + main-is: Main.hs + build-depends: + background-worker + , HsOpenSSL + , imports + , types-common + + hs-source-dirs: exec + default-language: Haskell2010 + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -funbox-strict-fields -Wredundant-constraints -Wunused-packages + + default-extensions: + NoImplicitPrelude + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + PackageImports + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances + ViewPatterns + +test-suite background-worker-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + ghc-options: + -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + -funbox-strict-fields -threaded -with-rtsopts=-N + -Wredundant-constraints -Wunused-packages + + -- cabal-fmt: expand test + other-modules: + Main + Test.Wire.BackendNotificationPusherSpec + + build-depends: + aeson + , amqp + , background-worker + , federator + , hspec + , imports + , QuickCheck + , tinylog + , types-common + , wire-api + , wire-api-federation + + default-extensions: + NoImplicitPrelude + AllowAmbiguousTypes + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + PackageImports + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances + ViewPatterns diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml new file mode 100644 index 0000000000..c2dd54bfb6 --- /dev/null +++ b/services/background-worker/background-worker.integration.yaml @@ -0,0 +1,13 @@ +logLevel: Info + +federatorInternal: + host: 127.0.0.1 + port: 8097 + +rabbitmq: + host: 127.0.0.1 + port: 5672 + vHost: / + +remoteDomains: + - b.example.com diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix new file mode 100644 index 0000000000..c737582585 --- /dev/null +++ b/services/background-worker/default.nix @@ -0,0 +1,63 @@ +# WARNING: GENERATED FILE, DO NOT EDIT. +# This file is generated by running hack/bin/generate-local-nix-packages.sh and +# must be regenerated whenever local packages are added or removed, or +# dependencies are added or removed. +{ mkDerivation +, aeson +, amqp +, exceptions +, extended +, federator +, gitignoreSource +, HsOpenSSL +, hspec +, http2-manager +, imports +, lib +, monad-control +, QuickCheck +, retry +, tinylog +, transformers-base +, types-common +, wire-api +, wire-api-federation +}: +mkDerivation { + pname = "background-worker"; + version = "0.1.0.0"; + src = gitignoreSource ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + aeson + amqp + exceptions + extended + HsOpenSSL + http2-manager + imports + monad-control + retry + tinylog + transformers-base + types-common + wire-api-federation + ]; + executableHaskellDepends = [ HsOpenSSL imports types-common ]; + testHaskellDepends = [ + aeson + amqp + federator + hspec + imports + QuickCheck + tinylog + types-common + wire-api + wire-api-federation + ]; + description = "Runs background work"; + license = lib.licenses.agpl3Only; + mainProgram = "background-worker"; +} diff --git a/services/background-worker/exec/Main.hs b/services/background-worker/exec/Main.hs new file mode 100644 index 0000000000..70e2554c12 --- /dev/null +++ b/services/background-worker/exec/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import Imports +import OpenSSL (withOpenSSL) +import Util.Options +import Wire.BackgroundWorker + +main :: IO () +main = withOpenSSL $ do + let desc = "Background Worker" + defaultPath = "/etc/wire/background-worker/conf/background-worker.yaml" + options <- getOptions desc Nothing defaultPath + run options diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs new file mode 100644 index 0000000000..741e5a5090 --- /dev/null +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RecordWildCards #-} + +module Wire.BackendNotificationPusher where + +import Control.Monad.Catch +import Control.Retry +import qualified Data.Aeson as A +import Data.Domain +import Imports +import qualified Network.AMQP as Q +import qualified Network.AMQP.Lifted as QL +import qualified System.Logger.Class as Log +import Wire.API.Federation.BackendNotifications +import Wire.API.Federation.Client +import Wire.BackgroundWorker.Env + +startPushingNotifications :: + Q.Channel -> + Domain -> + AppT IO Q.ConsumerTag +startPushingNotifications chan domain = do + lift $ ensureQueue chan domain + QL.consumeMsgs chan (routingKey domain) Q.Ack (pushNotification domain) + +-- | This class exists to help with testing, making the envelope in unit test is +-- too difficult. So we use fake envelopes in the unit tests. +class RabbitMQEnvelope e where + ack :: e -> IO () + reject :: e -> Bool -> IO () + +instance RabbitMQEnvelope Q.Envelope where + ack = Q.ackEnv + reject = Q.rejectEnv + +pushNotification :: RabbitMQEnvelope e => Domain -> (Q.Message, e) -> AppT IO () +pushNotification targetDomain (msg, envelope) = do + -- Jittered exponential backoff with 10ms as starting delay and + -- 300s as max delay. + -- + -- FUTUREWORK: Pull these numbers into config + let policy = capDelay 300_000_000 $ fullJitterBackoff 10000 + logErrr willRetry (SomeException e) rs = + Log.err $ + Log.msg (Log.val "Exception occurred while pushing notification") + . Log.field "error" (displayException e) + . Log.field "domain" (domainText targetDomain) + . Log.field "willRetry" willRetry + . Log.field "retryCount" rs.rsIterNumber + skipChanThreadKilled _ = Handler $ \(_ :: Q.ChanThreadKilledException) -> pure False + handlers = + skipAsyncExceptions + <> [ skipChanThreadKilled, + logRetries (const $ pure True) logErrr + ] + recovering policy handlers $ const go + where + go :: AppT IO () + go = case A.eitherDecode @BackendNotification (Q.msgBody msg) of + Left e -> do + Log.err $ + Log.msg (Log.val "Failed to parse notification, the notification will be ignored") + . Log.field "domain" (domainText targetDomain) + . Log.field "error" e + + -- FUTUREWORK: This rejects the message without any requeueing. This is + -- dangerous as it could happen that a new type of notification is + -- introduced and an old instance of this worker is running, in which case + -- the notification will just get dropped. On the other hand not dropping + -- this message blocks the whole queue. Perhaps there is a better way to + -- deal with this. + lift $ reject envelope False + Right notif -> do + ceFederator <- asks federatorInternal + ceHttp2Manager <- asks http2Manager + let ceOriginDomain = notif.ownDomain + ceTargetDomain = targetDomain + fcEnv = FederatorClientEnv {..} + liftIO $ either throwM pure =<< sendNotification fcEnv notif.targetComponent notif.path notif.body + lift $ ack envelope + +-- FUTUREWORK: Recosider using 1 channel for many consumers. It shouldn't matter +-- for a handful of remote domains. +startWorker :: [Domain] -> Q.Channel -> AppT IO () +startWorker remoteDomains chan = do + -- This ensures that we receive notifications 1 by 1 which ensures they are + -- delivered in order. + lift $ Q.qos chan 0 1 False + mapM_ (startPushingNotifications chan) remoteDomains + forever $ threadDelay maxBound diff --git a/services/background-worker/src/Wire/BackgroundWorker.hs b/services/background-worker/src/Wire/BackgroundWorker.hs new file mode 100644 index 0000000000..fea244b963 --- /dev/null +++ b/services/background-worker/src/Wire/BackgroundWorker.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DisambiguateRecordFields #-} + +module Wire.BackgroundWorker where + +import Imports +import Network.AMQP.Extended +import qualified Wire.BackendNotificationPusher as BackendNotificationPusher +import Wire.BackgroundWorker.Env +import Wire.BackgroundWorker.Options + +-- FUTUREWORK: Start an http service with status and metrics endpoints +run :: Opts -> IO () +run opts = do + env <- mkEnv opts + -- FUTUREWORK: Make some way to tracking all the workers, currently there is + -- only one so we can just block on it. + openConnectionWithRetries env.logger opts.rabbitmq.host opts.rabbitmq.port opts.rabbitmq.vHost $ + RabbitMqHooks + { onNewChannel = runAppT env . BackendNotificationPusher.startWorker opts.remoteDomains, + -- FUTUREWORK: Use these for metrics + onChannelException = const $ pure (), + onConnectionClose = pure () + } + forever $ threadDelay maxBound diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs new file mode 100644 index 0000000000..0213e3549d --- /dev/null +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} + +module Wire.BackgroundWorker.Env where + +import Control.Monad.Base +import Control.Monad.Catch +import Control.Monad.Trans.Control +import HTTP2.Client.Manager +import Imports +import OpenSSL.Session (SSLOption (..)) +import qualified OpenSSL.Session as SSL +import qualified System.Logger as Log +import System.Logger.Class +import qualified System.Logger.Extended as Log +import Util.Options +import Wire.BackgroundWorker.Options + +data Env = Env + { http2Manager :: Http2Manager, + logger :: Logger, + federatorInternal :: Endpoint + } + +mkEnv :: Opts -> IO Env +mkEnv opts = do + http2Manager <- initHttp2Manager + logger <- Log.mkLogger opts.logLevel Nothing opts.logFormat + let federatorInternal = opts.federatorInternal + pure Env {..} + +initHttp2Manager :: IO Http2Manager +initHttp2Manager = do + ctx <- SSL.context + SSL.contextAddOption ctx SSL_OP_NO_SSLv2 + SSL.contextAddOption ctx SSL_OP_NO_SSLv3 + SSL.contextAddOption ctx SSL_OP_NO_TLSv1 + SSL.contextSetCiphers ctx "HIGH" + SSL.contextSetVerificationMode ctx $ + SSL.VerifyPeer True True Nothing + SSL.contextSetDefaultVerifyPaths ctx + http2ManagerWithSSLCtx ctx + +newtype AppT m a where + AppT :: {unAppT :: ReaderT Env m a} -> AppT m a + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadCatch, + MonadThrow, + MonadMask, + MonadReader Env, + MonadTrans + ) + +deriving newtype instance MonadBase b m => MonadBase b (AppT m) + +deriving newtype instance MonadBaseControl b m => MonadBaseControl b (AppT m) + +instance MonadIO m => MonadLogger (AppT m) where + log lvl m = do + l <- asks logger + Log.log l lvl m + +runAppT :: Env -> AppT m a -> m a +runAppT env app = runReaderT (unAppT app) env diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs new file mode 100644 index 0000000000..f26edd8bc1 --- /dev/null +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -0,0 +1,27 @@ +module Wire.BackgroundWorker.Options where + +import Data.Aeson +import Data.Domain +import Imports +import System.Logger.Extended +import Util.Options + +data Opts = Opts + { logLevel :: !Level, + logFormat :: !(Maybe (Last LogFormat)), + federatorInternal :: !Endpoint, + rabbitmq :: !RabbitMqOpts, + remoteDomains :: [Domain] + } + deriving (Show, Generic) + +instance FromJSON Opts + +data RabbitMqOpts = RabbitMqOpts + { host :: !String, + port :: !Int, + vHost :: !Text + } + deriving (Show, Generic) + +instance FromJSON RabbitMqOpts diff --git a/services/background-worker/test/Main.hs b/services/background-worker/test/Main.hs new file mode 100644 index 0000000000..a824f8c30c --- /dev/null +++ b/services/background-worker/test/Main.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs new file mode 100644 index 0000000000..ae6baeee53 --- /dev/null +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE RecordWildCards #-} + +module Test.Wire.BackendNotificationPusherSpec where + +import qualified Data.Aeson as Aeson +import Data.Domain +import Data.Range +import Federator.MockServer +import Imports +import qualified Network.AMQP as Q +import qualified System.Logger as Logger +import Test.Hspec +import Test.QuickCheck +import Util.Options +import Wire.API.Federation.API +import Wire.API.Federation.API.Brig +import Wire.API.Federation.API.Common +import Wire.API.Federation.BackendNotifications +import Wire.API.RawJson +import Wire.BackendNotificationPusher +import Wire.BackgroundWorker.Env + +runTestAppT :: AppT IO a -> Int -> IO a +runTestAppT app port = do + http2Manager <- initHttp2Manager + logger <- Logger.new Logger.defSettings + let federatorInternal = Endpoint "localhost" (fromIntegral port) + env = Env {..} + runAppT env app + +spec :: Spec +spec = describe "Wire.BackendNotificationPusher" $ do + it "should push notifications" $ do + let returnSuccess _ = pure ("application/json", Aeson.encode EmptyResponse) + let origDomain = Domain "origin.example.com" + targetDomain = Domain "target.example.com" + -- Just using 'arbitrary' could generate a very big list, making tests very + -- slow. Make me wonder if notification pusher should even try to parse the + -- actual content, seems like wasted compute power. + notifContent <- generate $ UserDeletedConnectionsNotification <$> arbitrary <*> (unsafeRange . (: []) <$> arbitrary) + let notif = + BackendNotification + { targetComponent = Brig, + ownDomain = origDomain, + path = "/on-user-deleted-connections", + body = RawJson $ Aeson.encode notifContent + } + envelope <- newFakeEnvelope + let msg = + Q.newMsg + { Q.msgBody = Aeson.encode notif, + Q.msgContentType = Just "application/json" + } + + (_, fedReqs) <- + withTempMockFederator [] returnSuccess . runTestAppT $ do + pushNotification targetDomain (msg, envelope) + + readIORef envelope.acks `shouldReturn` 1 + readIORef envelope.rejections `shouldReturn` [] + fedReqs + `shouldBe` [ FederatedRequest + { frTargetDomain = targetDomain, + frOriginDomain = origDomain, + frComponent = Brig, + frRPC = "on-user-deleted-connections", + frBody = Aeson.encode notifContent + } + ] + + it "should reject invalid notifications" $ do + let returnSuccess _ = pure ("application/json", Aeson.encode EmptyResponse) + envelope <- newFakeEnvelope + let msg = + Q.newMsg + { Q.msgBody = "unparseable notification", + Q.msgContentType = Just "application/json" + } + (_, fedReqs) <- + withTempMockFederator [] returnSuccess . runTestAppT $ + pushNotification (Domain "target.example.com") (msg, envelope) + + readIORef envelope.acks `shouldReturn` 0 + readIORef envelope.rejections `shouldReturn` [False] + fedReqs `shouldBe` [] + + it "should retry failed deliveries" $ do + isFirstReqRef <- newIORef True + let returnSuccessSecondTime _ = + atomicModifyIORef isFirstReqRef $ \isFirstReq -> + if isFirstReq + then (False, ("text/html", "down for maintenance")) + else (False, ("application/json", Aeson.encode EmptyResponse)) + origDomain = Domain "origin.example.com" + targetDomain = Domain "target.example.com" + notifContent <- generate $ UserDeletedConnectionsNotification <$> arbitrary <*> (unsafeRange . (: []) <$> arbitrary) + let notif = + BackendNotification + { targetComponent = Brig, + ownDomain = origDomain, + path = "/on-user-deleted-connections", + body = RawJson $ Aeson.encode notifContent + } + envelope <- newFakeEnvelope + let msg = + Q.newMsg + { Q.msgBody = Aeson.encode notif, + Q.msgContentType = Just "application/json" + } + + (_, fedReqs) <- + withTempMockFederator [] returnSuccessSecondTime . runTestAppT $ do + pushNotification targetDomain (msg, envelope) + + readIORef envelope.acks `shouldReturn` 1 + readIORef envelope.rejections `shouldReturn` [] + let expectedReq = + FederatedRequest + { frTargetDomain = targetDomain, + frOriginDomain = origDomain, + frComponent = Brig, + frRPC = "on-user-deleted-connections", + frBody = Aeson.encode notifContent + } + fedReqs `shouldBe` [expectedReq, expectedReq] + +instance RabbitMQEnvelope FakeEnvelope where + ack e = atomicModifyIORef' e.acks $ \a -> (a + 1, ()) + reject e requeueFlag = atomicModifyIORef' e.rejections $ \r -> (r <> [requeueFlag], ()) + +data FakeEnvelope = FakeEnvelope + { rejections :: IORef [Bool], + acks :: IORef Int + } + +newFakeEnvelope :: IO FakeEnvelope +newFakeEnvelope = + FakeEnvelope + <$> newIORef [] + <*> newIORef 0 diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 7935b59004..4ff603d903 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -191,6 +191,7 @@ library , amazonka-dynamodb >=2 , amazonka-ses >=2 , amazonka-sqs >=2 + , amqp , async >=2.1 , auto-update >=0.1 , base >=4 && <5 @@ -213,7 +214,6 @@ library , data-timeout >=0.3 , dns , dns-util - , either >=4.3 , enclosed-exceptions >=1.0 , errors >=1.4 , exceptions >=0.5 @@ -269,7 +269,6 @@ library , schema-profunctor , scientific >=0.3.4 , servant - , servant-client , servant-server , servant-swagger , servant-swagger-ui diff --git a/services/brig/default.nix b/services/brig/default.nix index bad459003c..fa72a654fe 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -9,6 +9,7 @@ , amazonka-dynamodb , amazonka-ses , amazonka-sqs +, amqp , async , attoparsec , auto-update @@ -34,7 +35,6 @@ , data-timeout , dns , dns-util -, either , email-validate , enclosed-exceptions , errors @@ -171,6 +171,7 @@ mkDerivation { amazonka-dynamodb amazonka-ses amazonka-sqs + amqp async auto-update base @@ -193,7 +194,6 @@ mkDerivation { data-timeout dns dns-util - either enclosed-exceptions errors exceptions @@ -249,7 +249,6 @@ mkDerivation { schema-profunctor scientific servant - servant-client servant-server servant-swagger servant-swagger-ui diff --git a/services/brig/federation-tests.sh b/services/brig/federation-tests.sh index 5cea51393d..7a37655048 100755 --- a/services/brig/federation-tests.sh +++ b/services/brig/federation-tests.sh @@ -44,4 +44,4 @@ AWS_REGION="$(kubectl get deployment -n "$NAMESPACE" brig -o json | jq -r '.spec export AWS_REGION # shellcheck disable=SC2086 -telepresence --namespace "$NAMESPACE" --also-proxy=cassandra-ephemeral ${alsoProxyOptions[*]} --run bash -c "export INTEGRATION_FEDERATION_TESTS=1; ./dist/brig-integration -p federation-end2end-user -i i.yaml -s b.yaml" +telepresence --namespace "$NAMESPACE" --also-proxy=cassandra-ephemeral ${alsoProxyOptions[*]} --run bash -c "./dist/brig-integration -p federation-end2end-user -i i.yaml -s b.yaml" diff --git a/services/brig/src/Brig/API/OAuth.hs b/services/brig/src/Brig/API/OAuth.hs index 84df200afc..d20c929fd1 100644 --- a/services/brig/src/Brig/API/OAuth.hs +++ b/services/brig/src/Brig/API/OAuth.hs @@ -62,6 +62,9 @@ import qualified Wire.Sem.Now as Now internalOauthAPI :: ServerT I.OAuthAPI (Handler r) internalOauthAPI = Named @"create-oauth-client" registerOAuthClient + :<|> Named @"get-oauth-client" getOAuthClientById + :<|> Named @"update-oauth-client" updateOAuthClient + :<|> Named @"delete-oauth-client" deleteOAuthClient -------------------------------------------------------------------------------- -- API Public @@ -78,8 +81,8 @@ oauthAPI = -------------------------------------------------------------------------------- -- Handlers -registerOAuthClient :: RegisterOAuthClientRequest -> (Handler r) OAuthClientCredentials -registerOAuthClient (RegisterOAuthClientRequest name uri) = do +registerOAuthClient :: OAuthClientConfig -> (Handler r) OAuthClientCredentials +registerOAuthClient (OAuthClientConfig name uri) = do unlessM (Opt.setOAuthEnabled <$> view settings) $ throwStd $ errorToWai @'OAuthFeatureDisabled credentials@(OAuthClientCredentials cid secret) <- OAuthClientCredentials <$> randomId <*> createSecret safeSecret <- liftIO $ hashClientSecret secret @@ -95,6 +98,23 @@ registerOAuthClient (RegisterOAuthClientRequest name uri) = do rand32Bytes :: MonadIO m => m AsciiBase16 rand32Bytes = liftIO . fmap encodeBase16 $ randBytes 32 +getOAuthClientById :: OAuthClientId -> (Handler r) OAuthClient +getOAuthClientById cid = do + unlessM (Opt.setOAuthEnabled <$> view settings) $ throwStd $ errorToWai @'OAuthFeatureDisabled + mClient <- lift $ wrapClient $ lookupOauthClient cid + maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure mClient + +updateOAuthClient :: OAuthClientId -> OAuthClientConfig -> (Handler r) OAuthClient +updateOAuthClient cid config = do + void $ getOAuthClientById cid + lift $ wrapClient $ updateOAuthClient' cid config.applicationName config.redirectUrl + getOAuthClientById cid + +deleteOAuthClient :: OAuthClientId -> (Handler r) () +deleteOAuthClient cid = do + void $ getOAuthClientById cid + lift $ wrapClient $ deleteOAuthClient' cid + -------------------------------------------------------------------------------- getOAuthClient :: UserId -> OAuthClientId -> (Handler r) (Maybe OAuthClient) @@ -284,6 +304,18 @@ revokeOAuthAccountAccess uid cid = do -------------------------------------------------------------------------------- -- DB +deleteOAuthClient' :: (MonadClient m) => OAuthClientId -> m () +deleteOAuthClient' cid = retry x5 . write q $ params LocalQuorum (Identity cid) + where + q :: PrepQuery W (Identity OAuthClientId) () + q = "DELETE FROM oauth_client WHERE id = ?" + +updateOAuthClient' :: (MonadClient m) => OAuthClientId -> OAuthApplicationName -> RedirectUrl -> m () +updateOAuthClient' cid name uri = retry x5 . write q $ params LocalQuorum (name, uri, cid) + where + q :: PrepQuery W (OAuthApplicationName, RedirectUrl, OAuthClientId) () + q = "UPDATE oauth_client SET name = ?, redirect_uri = ? WHERE id = ?" + insertOAuthClient :: (MonadClient m) => OAuthClientId -> OAuthApplicationName -> RedirectUrl -> Password -> m () insertOAuthClient cid name uri pw = retry x5 . write q $ params LocalQuorum (cid, name, uri, pw) where diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 584eb4deaf..cc554a7a29 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -1,4 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -- FUTUREWORK: Get rid of this option once Polysemy is fully introduced to Brig @@ -60,6 +62,7 @@ module Brig.App emailSender, randomPrekeyLocalLock, keyPackageLocalLock, + rabbitmqChannel, fsWatcher, -- * App Monad @@ -132,6 +135,9 @@ import Data.Yaml (FromJSON) import qualified Database.Bloodhound as ES import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx) import Imports +import qualified Network.AMQP as Q +import Network.AMQP.Extended (RabbitMqHooks (RabbitMqHooks)) +import qualified Network.AMQP.Extended as Q import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.OpenSSL import OpenSSL.EVP.Digest (Digest, getDigestByName) @@ -191,7 +197,8 @@ data Env = Env _digestMD5 :: Digest, _indexEnv :: IndexEnv, _randomPrekeyLocalLock :: Maybe (MVar ()), - _keyPackageLocalLock :: MVar () + _keyPackageLocalLock :: MVar (), + _rabbitmqChannel :: Maybe (MVar Q.Channel) } makeLenses ''Env @@ -244,6 +251,7 @@ newEnv o = do Log.info lgr $ Log.msg (Log.val "randomPrekeys: not active; using dynamoDB instead.") pure Nothing kpLock <- newMVar () + rabbitChan <- mkRabbitMqChannel lgr o pure $! Env { _cargohold = mkEndpoint $ Opt.cargohold o, @@ -279,7 +287,8 @@ newEnv o = do _digestSHA256 = sha256, _indexEnv = mkIndexEnv o lgr mgr mtr (Opt.galley o), _randomPrekeyLocalLock = prekeyLocalLock, - _keyPackageLocalLock = kpLock + _keyPackageLocalLock = kpLock, + _rabbitmqChannel = rabbitChan } where emailConn _ (Opt.EmailAWS aws) = pure (Just aws, Nothing) @@ -295,6 +304,18 @@ newEnv o = do pure (Nothing, Just smtp) mkEndpoint service = RPC.host (encodeUtf8 (service ^. epHost)) . RPC.port (service ^. epPort) $ RPC.empty +mkRabbitMqChannel :: Logger -> Opts -> IO (Maybe (MVar Q.Channel)) +mkRabbitMqChannel l (Opt.rabbitmq -> Just Opt.RabbitMqOpts {..}) = do + chan <- newEmptyMVar + Q.openConnectionWithRetries l host port vHost $ + RabbitMqHooks + { onNewChannel = putMVar chan, + onChannelException = \_ -> void $ tryTakeMVar chan, + onConnectionClose = void $ tryTakeMVar chan + } + pure $ Just chan +mkRabbitMqChannel _ _ = pure Nothing + mkIndexEnv :: Opts -> Logger -> Manager -> Metrics -> Endpoint -> IndexEnv mkIndexEnv o lgr mgr mtr galleyEndpoint = let bhe = ES.mkBHEnv (ES.Server (Opt.url (Opt.elasticsearch o))) mgr diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index c7ee6561c1..0749ebec66 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -25,18 +26,23 @@ module Brig.Federation.Client where import Brig.App import Control.Lens import Control.Monad +import Control.Monad.Catch (MonadMask, throwM) import Control.Monad.Trans.Except (ExceptT (..), throwE) +import Control.Retry +import Control.Timeout import Data.Domain import Data.Handle import Data.Id (ClientId, UserId) import Data.Qualified import Data.Range (Range) import qualified Data.Text as T +import Data.Time.Units import Imports -import Servant.Client hiding (client) +import qualified Network.AMQP as Q import qualified System.Logger.Class as Log import Wire.API.Federation.API import Wire.API.Federation.API.Brig as FederatedBrig +import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Client import Wire.API.Federation.Error import Wire.API.User @@ -137,18 +143,48 @@ sendConnectionAction self (tUntagged -> other) action = do notifyUserDeleted :: ( MonadReader Env m, MonadIO m, - HasFedEndpoint 'Brig api "on-user-deleted-connections", - HasClient (FederatorClient 'Brig) api + MonadMask m, + Log.MonadLogger m ) => Local UserId -> Remote (Range 1 1000 [UserId]) -> - ExceptT FederationError m () + m () notifyUserDeleted self remotes = do let remoteConnections = tUnqualified remotes - void $ - runBrigFederatorClient (tDomain remotes) $ - fedClient @'Brig @"on-user-deleted-connections" $ - UserDeletedConnectionsNotification (tUnqualified self) remoteConnections + let notif = UserDeletedConnectionsNotification (tUnqualified self) remoteConnections + remoteDomain = tDomain remotes + view rabbitmqChannel >>= \case + Just chanVar -> do + enqueueNotification (tDomain self) remoteDomain Q.Persistent chanVar $ void $ fedQueueClient @'Brig @"on-user-deleted-connections" notif + Nothing -> + Log.err $ + Log.msg ("Federation error while notifying remote backends of a user deletion." :: ByteString) + . Log.field "user_id" (show self) + . Log.field "domain" (domainText remoteDomain) + . Log.field "error" (show FederationNotConfigured) + +-- | Enqueues notifications in RabbitMQ. Retries 3 times with a delay of 1s. +enqueueNotification :: (MonadReader Env m, MonadIO m, MonadMask m, Log.MonadLogger m) => Domain -> Domain -> Q.DeliveryMode -> MVar Q.Channel -> FedQueueClient c () -> m () +enqueueNotification ownDomain remoteDomain deliveryMode chanVar action = do + let policy = limitRetries 3 <> constantDelay 1_000_000 + recovering policy [logRetries (const $ pure True) logError] (const go) + where + logError willRetry (SomeException e) status = do + Log.err $ + Log.msg @Text "failed to enqueue notification in RabbitMQ" + . Log.field "error" (displayException e) + . Log.field "willRetry" willRetry + . Log.field "retryCount" status.rsIterNumber + go = do + mChan <- timeout (1 :: Second) (readMVar chanVar) + case mChan of + Nothing -> throwM NoRabbitMqChannel + Just chan -> liftIO $ enqueue chan ownDomain remoteDomain deliveryMode action + +data NoRabbitMqChannel = NoRabbitMqChannel + deriving (Show) + +instance Exception NoRabbitMqChannel runBrigFederatorClient :: (MonadReader Env m, MonadIO m) => diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 3c98f8ab9a..204488de25 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -75,8 +75,6 @@ import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as BL import qualified Data.Conduit.List as C -import Data.Domain -import Data.Either.Combinators (whenLeft) import Data.Id import Data.Json.Util ((#)) import Data.List.Split (chunksOf) @@ -296,7 +294,8 @@ notifyUserDeletionRemotes :: forall m. ( MonadReader Env m, MonadClient m, - MonadLogger m + MonadLogger m, + MonadMask m ) => UserId -> m () @@ -317,17 +316,7 @@ notifyUserDeletionRemotes deleted = do pure () Just rangedUids -> do luidDeleted <- qualifyLocal deleted - eitherFErr <- runExceptT (notifyUserDeleted luidDeleted (qualifyAs uids rangedUids)) - whenLeft eitherFErr $ - logFederationError (tDomain uids) - - logFederationError :: Domain -> FederationError -> m () - logFederationError domain fErr = - Log.err $ - Log.msg ("Federation error while notifying remote backends of a user deletion." :: ByteString) - . Log.field "user_id" (show deleted) - . Log.field "domain" (domainText domain) - . Log.field "error" (show fErr) + notifyUserDeleted luidDeleted (qualifyAs uids rangedUids) -- | Push events to other users. push :: diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 66904d3ce0..711f1c6040 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -95,6 +95,15 @@ data ElasticSearchOpts = ElasticSearchOpts instance FromJSON ElasticSearchOpts +data RabbitMqOpts = RabbitMqOpts + { host :: !String, + port :: !Int, + vHost :: !Text + } + deriving (Show, Generic) + +instance FromJSON RabbitMqOpts + data AWSOpts = AWSOpts { -- | Event journal queue for user events -- (e.g. user deletion) @@ -433,6 +442,8 @@ data Opts = Opts cassandra :: !CassandraOpts, -- | ElasticSearch settings elasticsearch :: !ElasticSearchOpts, + -- | RabbitMQ settings, required when federation is enabled. + rabbitmq :: !(Maybe RabbitMqOpts), -- | AWS settings aws :: !AWSOpts, -- | Enable Random Prekey Strategy diff --git a/services/brig/test/integration/API/OAuth.hs b/services/brig/test/integration/API/OAuth.hs index dd3276ca21..2e3a174e2f 100644 --- a/services/brig/test/integration/API/OAuth.hs +++ b/services/brig/test/integration/API/OAuth.hs @@ -129,7 +129,7 @@ tests m db b n o = do testRegisterNewOAuthClient :: Brig -> Http () testRegisterNewOAuthClient brig = do - let newOAuthClient@(RegisterOAuthClientRequest expectedAppName expectedUrl) = newOAuthClientRequestBody "E Corp" "https://example.com" + let newOAuthClient@(OAuthClientConfig expectedAppName expectedUrl) = newOAuthClientRequestBody "E Corp" "https://example.com" c <- registerNewOAuthClient brig newOAuthClient uid <- randomId oauthClientInfo <- getOAuthClientInfo brig uid c.clientId @@ -139,7 +139,7 @@ testRegisterNewOAuthClient brig = do testCreateOAuthCodeSuccess :: Brig -> Http () testCreateOAuthCodeSuccess brig = do - let newOAuthClient@(RegisterOAuthClientRequest _ redirectUrl) = newOAuthClientRequestBody "E Corp" "https://example.com" + let newOAuthClient@(OAuthClientConfig _ redirectUrl) = newOAuthClientRequestBody "E Corp" "https://example.com" c <- registerNewOAuthClient brig newOAuthClient uid <- randomId let scope = OAuthScopes $ Set.fromList [WriteConversations, WriteConversationsCode] @@ -738,17 +738,17 @@ authHeader = bearer "Authorization" bearer :: ToHttpApiData a => HeaderName -> a -> Request -> Request bearer name = header name . toHeader . Bearer -newOAuthClientRequestBody :: Text -> Text -> RegisterOAuthClientRequest +newOAuthClientRequestBody :: Text -> Text -> OAuthClientConfig newOAuthClientRequestBody name url = let redirectUrl = mkUrl (cs url) applicationName = OAuthApplicationName (unsafeRange name) - in RegisterOAuthClientRequest applicationName redirectUrl + in OAuthClientConfig applicationName redirectUrl -registerNewOAuthClient :: (MonadIO m, MonadHttp m, MonadCatch m, HasCallStack) => Brig -> RegisterOAuthClientRequest -> m OAuthClientCredentials +registerNewOAuthClient :: (MonadIO m, MonadHttp m, MonadCatch m, HasCallStack) => Brig -> OAuthClientConfig -> m OAuthClientCredentials registerNewOAuthClient brig reqBody = responseJsonError =<< registerNewOAuthClient' brig reqBody Brig -> RegisterOAuthClientRequest -> m ResponseLBS +registerNewOAuthClient' :: (MonadHttp m) => Brig -> OAuthClientConfig -> m ResponseLBS registerNewOAuthClient' brig reqBody = post (brig . paths ["i", "oauth", "clients"] . json reqBody) @@ -799,7 +799,7 @@ generateOAuthClientAndAuthorizationCode = generateOAuthClientAndAuthorizationCod generateOAuthClientAndAuthorizationCode' :: (MonadIO m, MonadHttp m, MonadCatch m, HasCallStack) => OAuthCodeChallenge -> Brig -> UserId -> OAuthScopes -> RedirectUrl -> m (OAuthClientId, OAuthAuthorizationCode) generateOAuthClientAndAuthorizationCode' chal brig uid scope url = do - let newOAuthClient = RegisterOAuthClientRequest (OAuthApplicationName (unsafeRange "E Corp")) url + let newOAuthClient = OAuthClientConfig (OAuthApplicationName (unsafeRange "E Corp")) url OAuthClientCredentials cid _ <- registerNewOAuthClient brig newOAuthClient (cid,) <$> generateOAuthAuthorizationCode' chal brig uid cid scope url diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 664a17d964..030196e303 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -87,9 +87,6 @@ import Wire.API.Asset hiding (Asset) import qualified Wire.API.Asset as Asset import Wire.API.Connection import Wire.API.Conversation -import Wire.API.Federation.API.Brig (UserDeletedConnectionsNotification (..)) -import qualified Wire.API.Federation.API.Brig as FedBrig -import Wire.API.Federation.API.Common (EmptyResponse (EmptyResponse)) import Wire.API.Internal.Notification import Wire.API.Routes.MultiTablePaging import Wire.API.Team.Feature (ExposeInvitationURLsToTeamAdminConfig (..), FeatureStatus (..), FeatureTTL' (..), LockStatus (LockStatusLocked), withStatus) @@ -157,8 +154,6 @@ tests _ at opts p b c ch g aws userJournalWatcher = test p "delete/by-code" $ testDeleteUserByCode b, test p "delete/anonymous" $ testDeleteAnonUser b, test p "delete with profile pic" $ testDeleteWithProfilePic b ch, - test p "delete with connected remote users" $ testDeleteWithRemotes opts b, - test p "delete with connected remote users and failed remote notifcations" $ testDeleteWithRemotesAndFailedNotifications opts b c, test p "put /i/users/:uid/sso-id" $ testUpdateSSOId b g, testGroup "temporary customer extensions" @@ -1479,96 +1474,6 @@ testDeleteWithProfilePic brig cargohold = do -- Check that the asset gets deleted downloadAsset cargohold uid (ast ^. Asset.assetKey) !!! const 404 === statusCode -testDeleteWithRemotes :: Opt.Opts -> Brig -> Http () -testDeleteWithRemotes opts brig = do - localUser <- randomUser brig - - let remote1Domain = Domain "remote1.example.com" - remote2Domain = Domain "remote2.example.com" - remote1UserConnected <- Qualified <$> randomId <*> pure remote1Domain - remote1UserPending <- Qualified <$> randomId <*> pure remote1Domain - remote2UserBlocked <- Qualified <$> randomId <*> pure remote2Domain - - sendConnectionAction brig opts (userId localUser) remote1UserConnected (Just FedBrig.RemoteConnect) Accepted - sendConnectionAction brig opts (userId localUser) remote1UserPending Nothing Sent - sendConnectionAction brig opts (userId localUser) remote2UserBlocked (Just FedBrig.RemoteConnect) Accepted - void $ putConnectionQualified brig (userId localUser) remote2UserBlocked Blocked - - let fedMockResponse _ = pure (Aeson.encode EmptyResponse) - let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response - galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) = - case (requestMethod, requestPath) of - (_methodDelete, ["i", "user"]) -> do - let response = Wai.responseLBS Http.status200 [(Http.hContentType, "application/json")] (cs $ Aeson.encode EmptyResponse) - pure response - _ -> error "not mocked" - - (_, rpcCalls, _galleyCalls) <- liftIO $ - withMockedFederatorAndGalley opts (Domain "example.com") fedMockResponse galleyHandler $ do - deleteUser (userId localUser) (Just defPassword) brig !!! do - const 200 === statusCode - - liftIO $ do - remote1Call <- assertOne $ filter (\c -> frTargetDomain c == remote1Domain) rpcCalls - remote1Udn <- assertRight $ parseFedRequest remote1Call - udcnUser remote1Udn @?= userId localUser - sort (fromRange (udcnConnections remote1Udn)) - @?= sort (map qUnqualified [remote1UserConnected, remote1UserPending]) - - remote2Call <- assertOne $ filter (\c -> frTargetDomain c == remote2Domain) rpcCalls - remote2Udn <- assertRight $ parseFedRequest remote2Call - udcnUser remote2Udn @?= userId localUser - fromRange (udcnConnections remote2Udn) @?= [qUnqualified remote2UserBlocked] - where - parseFedRequest :: FromJSON a => FederatedRequest -> Either String a - parseFedRequest = eitherDecode . frBody - -testDeleteWithRemotesAndFailedNotifications :: Opt.Opts -> Brig -> Cannon -> Http () -testDeleteWithRemotesAndFailedNotifications opts brig cannon = do - alice <- randomUser brig - alex <- randomUser brig - let localDomain = qDomain (userQualifiedId alice) - - let bDomain = Domain "b.example.com" - cDomain = Domain "c.example.com" - bob <- Qualified <$> randomId <*> pure bDomain - carl <- Qualified <$> randomId <*> pure cDomain - - postConnection brig (userId alice) (userId alex) !!! const 201 === statusCode - putConnection brig (userId alex) (userId alice) Accepted !!! const 200 === statusCode - sendConnectionAction brig opts (userId alice) bob (Just FedBrig.RemoteConnect) Accepted - sendConnectionAction brig opts (userId alice) carl (Just FedBrig.RemoteConnect) Accepted - - let fedMockResponse req = - if frTargetDomain req == bDomain - then throw $ MockErrorResponse Http.status500 "mocked connection problem with b domain" - else pure (Aeson.encode EmptyResponse) - - let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response - galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) = - case (Http.parseMethod requestMethod, requestPath) of - (Right Http.DELETE, ["i", "user"]) -> do - let response = Wai.responseLBS Http.status200 [(Http.hContentType, "application/json")] (cs $ Aeson.encode EmptyResponse) - pure response - _ -> error "not mocked" - - (_, rpcCalls, _galleyCalls) <- WS.bracketR cannon (userId alex) $ \wsAlex -> do - let action = withMockedFederatorAndGalley opts localDomain fedMockResponse galleyHandler $ do - deleteUser (userId alice) (Just defPassword) brig !!! do - const 200 === statusCode - liftIO action <* do - void . liftIO . WS.assertMatch (5 # Second) wsAlex $ matchDeleteUserNotification (userQualifiedId alice) - - liftIO $ do - rRpc <- assertOne $ filter (\c -> frTargetDomain c == cDomain) rpcCalls - cUdn <- assertRight $ parseFedRequest rRpc - udcnUser cUdn @?= userId alice - sort (fromRange (udcnConnections cUdn)) - @?= sort (map qUnqualified [carl]) - where - parseFedRequest :: FromJSON a => FederatedRequest -> Either String a - parseFedRequest = eitherDecode . frBody - testUpdateSSOId :: Brig -> Galley -> Http () testUpdateSSOId brig galley = do noSuchUserId <- Id <$> liftIO UUID.nextRandom diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 6428d76357..995576f81d 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -56,6 +56,7 @@ import qualified Data.Set as Set import Data.String.Conversions (cs) import Data.Text (replace) import Data.Text.Ascii (AsciiChars (validate)) +import Data.Time (addUTCTime) import Data.Time.Clock.POSIX import qualified Data.Vector as Vec import Imports @@ -1440,7 +1441,7 @@ testCreateAccessToken opts n brig = do let claimsSet' = emptyClaimsSet & claimIat ?~ NumericDate now - & claimExp ?~ NumericDate now + & claimExp ?~ NumericDate (addUTCTime 10 now) & claimNbf ?~ NumericDate now & claimSub ?~ fromMaybe (error "invalid sub claim") ((clientIdentity :: Text) ^? stringOrUri) & claimJti ?~ "6fc59e7f-b666-4ffc-b738-4f4760c884ca" @@ -1451,7 +1452,7 @@ testCreateAccessToken opts n brig = do Right signed -> do let proof = Just $ Proof (cs signed) response <- Util.createAccessTokenNginz n t cid proof - accessToken <- responseJsonError response + let accessToken = fromRight (error $ "failed to create token: " <> show response) $ responseJsonEither response liftIO $ datrType accessToken @?= DPoP where signAccessToken :: DPoPClaimsSet -> IO (Either JWTError SignedJWT) diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index dee2c47caa..efb96a7495 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -60,7 +60,6 @@ import OpenSSL (withOpenSSL) import Options.Applicative hiding (action) import qualified SMTP import System.Environment (withArgs) -import qualified System.Environment.Blank as Blank import qualified System.Logger as Logger import Test.Tasty import Test.Tasty.HUnit @@ -157,7 +156,6 @@ runTests iConf brigOpts otherArgs = do userPendingActivation <- UserPendingActivation.tests brigOpts mg db b g s federationEnd2End <- Federation.End2end.spec brigOpts mg b g ch c f brigTwo galleyTwo ch2 cannonTwo federationEndpoints <- API.Federation.tests mg brigOpts b c fedBrigClient - includeFederationTests <- (== Just "1") <$> Blank.getEnv "INTEGRATION_FEDERATION_TESTS" internalApi <- API.Internal.tests brigOpts mg db b (brig iConf) gd g let smtp = SMTP.tests mg lg @@ -191,9 +189,9 @@ runTests iConf brigOpts otherArgs = do swaggerApi, mlsApi, smtp, - oauthAPI + oauthAPI, + federationEnd2End ] - <> [federationEnd2End | includeFederationTests] where mkRequest (Endpoint h p) = host (encodeUtf8 h) . port p diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs index f8f88e5310..ed40cc9d95 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -28,6 +28,7 @@ module Federator.MockServer Mock, runMock, mockReply, + mockUnreachableFor, mockFail, guardRPC, guardComponent, @@ -45,6 +46,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import qualified Data.Aeson as Aeson import Data.Domain (Domain) +import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Lazy as LText import Federator.Error @@ -203,6 +205,16 @@ guardComponent c = do mockReply :: Aeson.ToJSON a => a -> Mock LByteString mockReply = pure . Aeson.encode +-- | Provide a mock reply simulating unreachable backends given by their +-- domains. +mockUnreachableFor :: String -> Set Domain -> Mock LByteString +mockUnreachableFor msg backends = do + target <- frTargetDomain <$> getRequest + guard (target `elem` backends) + if Set.member target backends + then throw (MockErrorResponse HTTP.status503 "Down for maintenance.") + else mockReply msg + -- | Abort the mock with an error. mockFail :: Text -> Mock a mockFail = Mock . lift . lift . throwE diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index dde713e3aa..10631d8f06 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -28,6 +28,7 @@ library Galley.API.Internal Galley.API.LegalHold Galley.API.LegalHold.Conflicts + Galley.API.LegalHold.Team Galley.API.Mapping Galley.API.Message Galley.API.MLS @@ -61,6 +62,7 @@ library Galley.API.Query Galley.API.Teams Galley.API.Teams.Features + Galley.API.Teams.Features.Get Galley.API.Teams.Notifications Galley.API.Update Galley.API.Util diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 3916bbb914..074a4afca2 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -81,6 +81,8 @@ import Galley.Types.Conversations.Members import Galley.Types.UserList import Galley.Validation import Imports +import qualified Network.HTTP.Types.Status as Wai +import qualified Network.Wai.Utilities.Error as Wai import Polysemy import Polysemy.Error import Polysemy.Input @@ -100,6 +102,7 @@ import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.Team.LegalHold import Wire.API.Team.Member +import Wire.API.Unreachable import qualified Wire.API.User as User data NoChanges = NoChanges @@ -310,7 +313,8 @@ ensureAllowed tag loc action conv origUser = do -- and also returns the (possible modified) action that was performed performAction :: forall tag r. - ( HasConversationActionEffects tag r + ( HasConversationActionEffects tag r, + Member (Error FederationError) r ) => Sing tag -> Qualified UserId -> @@ -451,7 +455,8 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do ensureConnectedToRemotes lusr remotes checkLHPolicyConflictsLocal :: - ( Member (Error InternalError) r, + ( Member (Error FederationError) r, + Member (Error InternalError) r, Member (ErrorS 'MissingLegalholdConsent) r, Member ExternalAccess r, Member FederatorAccess r, @@ -507,7 +512,9 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do checkLHPolicyConflictsRemote _remotes = pure () performConversationAccessData :: - HasConversationActionEffects 'ConversationAccessDataTag r => + ( HasConversationActionEffects 'ConversationAccessDataTag r, + Member (Error FederationError) r + ) => Qualified UserId -> Local Conversation -> ConversationAccessData -> @@ -593,6 +600,7 @@ data LocalConversationUpdate = LocalConversationUpdate updateLocalConversation :: forall tag r. ( Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'ConvNotFound) r, @@ -609,7 +617,7 @@ updateLocalConversation :: Qualified UserId -> Maybe ConnId -> ConversationAction tag -> - Sem r LocalConversationUpdate + Sem r (LocalConversationUpdate, FailedToProcess) updateLocalConversation lcnv qusr con action = do let tag = sing @tag @@ -633,6 +641,7 @@ updateLocalConversation lcnv qusr con action = do updateLocalConversationUnchecked :: forall tag r. ( SingI tag, + Member (Error FederationError) r, Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, @@ -648,7 +657,7 @@ updateLocalConversationUnchecked :: Qualified UserId -> Maybe ConnId -> ConversationAction tag -> - Sem r LocalConversationUpdate + Sem r (LocalConversationUpdate, FailedToProcess) updateLocalConversationUnchecked lconv qusr con action = do let tag = sing @tag lcnv = fmap convId lconv @@ -664,11 +673,6 @@ updateLocalConversationUnchecked lconv qusr con action = do (extraTargets, action') <- performAction tag qusr lconv action notifyConversationAction - -- Removing members should be fault tolerant. - ( case tag of - SConversationRemoveMembersTag -> False - _ -> True - ) (sing @tag) qusr False @@ -723,14 +727,14 @@ addMembersToLocalConversation lcnv users role = do notifyConversationAction :: forall tag r. - ( Member FederatorAccess r, + ( Member (Error FederationError) r, + Member FederatorAccess r, Member ExternalAccess r, Member GundeckAccess r, Member (Input UTCTime) r, Member SubConversationStore r, Member (Logger (Log.Msg -> Log.Msg)) r ) => - Bool -> Sing tag -> Qualified UserId -> Bool -> @@ -738,8 +742,8 @@ notifyConversationAction :: Local Conversation -> BotsAndMembers -> ConversationAction (tag :: ConversationActionTag) -> - Sem r LocalConversationUpdate -notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets action = do + Sem r (LocalConversationUpdate, FailedToProcess) +notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do now <- input let lcnv = fmap convId lconv conv = tUnqualified lconv @@ -759,75 +763,78 @@ notifyConversationAction failEarly tag quid notifyOrigDomain con lconv targets a Set.difference (Set.map void (bmRemotes targets)) (Set.fromList (map (void . rmId) (convRemoteMembers conv))) - subConvs <- Map.assocs <$> E.listSubConversations (convId conv) + newRemotes = + Set.filter (\r -> Set.member (void r) newDomains) + . bmRemotes + $ targets - let nrc = - NewRemoteConversation - { nrcConvId = convId conv, - nrcProtocol = convProtocol conv - } - - let errorIntolerant = do - E.runFederatedConcurrently_ (toList newDomains) $ \_ -> do - void $ fedClient @'Galley @"on-new-remote-conversation" nrc - for_ subConvs $ \(mSubId, mlsData) -> - fedClient @'Galley @"on-new-remote-subconversation" - NewRemoteSubConversation - { nrscConvId = convId conv, - nrscSubConvId = mSubId, - nrscMlsData = mlsData - } - fmap (fromMaybe (mkUpdate []) . asum . map tUnqualified) - . E.runFederatedConcurrently (toList (bmRemotes targets)) - $ \ruids -> do - let update = mkUpdate (tUnqualified ruids) - -- if notifyOrigDomain is false, filter out user from quid's domain, - -- because quid's backend will update local state and notify its users - -- itself using the ConversationUpdate returned by this function - if notifyOrigDomain || tDomain ruids /= qDomain quid - then fedClient @'Galley @"on-conversation-updated" update $> Nothing - else pure (Just update) - errorTolerant = do - fedEithers <- E.runFederatedConcurrentlyEither (toList newDomains) $ \_ -> do - void $ fedClient @'Galley @"on-new-remote-conversation" nrc - for_ subConvs $ \(mSubId, mlsData) -> - fedClient @'Galley @"on-new-remote-subconversation" - NewRemoteSubConversation - { nrscConvId = convId conv, - nrscSubConvId = mSubId, - nrscMlsData = mlsData - } - for_ fedEithers $ - either - (logError "on-new-remote-conversation" "An error occurred while communicating with federated server: ") - (pure . tUnqualified) - updates <- - E.runFederatedConcurrentlyEither (toList (bmRemotes targets)) $ - \ruids -> do - let update = mkUpdate (tUnqualified ruids) - -- if notifyOrigDomain is false, filter out user from quid's domain, - -- because quid's backend will update local state and notify its users - -- itself using the ConversationUpdate returned by this function - if notifyOrigDomain || tDomain ruids /= qDomain quid - then fedClient @'Galley @"on-conversation-updated" update $> Nothing - else pure (Just update) - let f = fromMaybe (mkUpdate []) . asum . map tUnqualified . rights - update = f updates - for_ (lefts updates) $ - logError - "on-conversation-update" - "An error occurred while communicating with federated server: " - pure update - - update <- if failEarly then errorIntolerant else errorTolerant + subConvs <- Map.assocs <$> E.listSubConversations (convId conv) + (update, failedToProcess) <- do + notifyEithers <- + E.runFederatedConcurrentlyEither (toList newRemotes) $ \_ -> do + void $ + fedClient @'Galley @"on-new-remote-conversation" $ + NewRemoteConversation + { nrcConvId = convId conv, + nrcProtocol = convProtocol conv + } + for_ subConvs $ \(mSubId, mlsData) -> + fedClient @'Galley @"on-new-remote-subconversation" + NewRemoteSubConversation + { nrscConvId = convId conv, + nrscSubConvId = mSubId, + nrscMlsData = mlsData + } + + -- For now these users will not be able to join the conversation until + -- queueing and retrying is implemented. + let failedNotifies = lefts notifyEithers + for_ failedNotifies $ \case + -- rethrow invalid-domain errors and mis-configured federation errors + (_, ex@(FederationCallFailure (FederatorClientError (Wai.Error (Wai.Status 422 _) _ _ _)))) -> throw ex + (_, ex@(FederationCallFailure (FederatorClientHTTP2Error (FederatorClientConnectionError _)))) -> throw ex + _ -> pure () + for_ failedNotifies $ + logError + "on-new-remote-conversation" + "An error occurred while communicating with federated server: " + updates <- + E.runFederatedConcurrentlyEither (toList (bmRemotes targets)) $ + \ruids -> do + let update = mkUpdate (tUnqualified ruids) + -- if notifyOrigDomain is false, filter out user from quid's domain, + -- because quid's backend will update local state and notify its users + -- itself using the ConversationUpdate returned by this function + if notifyOrigDomain || tDomain ruids /= qDomain quid + then fedClient @'Galley @"on-conversation-updated" update $> Nothing + else pure (Just update) + let f = fromMaybe (mkUpdate []) . asum . map tUnqualified . rights + update = f updates + failedUpdates = lefts updates + toFailedToProcess :: [Qualified UserId] -> FailedToProcess + toFailedToProcess us = case tag of + SConversationJoinTag -> failedToAdd us + SConversationLeaveTag -> failedToRemove us + SConversationRemoveMembersTag -> failedToRemove us + _ -> mempty + for_ failedUpdates $ + logError + "on-conversation-updated" + "An error occurred while communicating with federated server: " + let totalFailedToProcess = + failedToAdd (qualifiedFails failedNotifies) + <> toFailedToProcess (qualifiedFails failedUpdates) + pure (update, totalFailedToProcess) -- notify local participants and bots pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) -- return both the event and the 'ConversationUpdate' structure corresponding -- to the originating domain (if it is remote) - pure $ LocalConversationUpdate e update + pure $ (LocalConversationUpdate e update, failedToProcess) where + qualifiedFails :: [(QualifiedWithTag t [a], b)] -> [Qualified a] + qualifiedFails = foldMap (sequenceA . tUntagged . fst) logError :: Show a => String -> String -> (a, FederationError) -> Sem r () logError field msg e = P.warn $ @@ -883,7 +890,8 @@ notifyRemoteConversationAction loc rconvUpdate con = do -- leave, but then sends notifications as if the user was removed by someone -- else. kickMember :: - ( Member (Error InternalError) r, + ( Member (Error FederationError) r, + Member (Error InternalError) r, Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, @@ -907,7 +915,6 @@ kickMember qusr lconv targets victim = void . runError @NoChanges $ do lconv () notifyConversationAction - False (sing @'ConversationRemoveMembersTag) qusr True diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 67f6d74c28..db4af6d76c 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -28,11 +28,10 @@ import Control.Error import Control.Lens (itraversed, preview, to, (<.>)) import Data.Bifunctor import Data.ByteString.Conversion (toByteString') -import Data.Containers.ListUtils (nubOrd) import Data.Domain (Domain) +import Data.Either.Combinators import Data.Id import Data.Json.Util -import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) import Data.Qualified @@ -54,11 +53,11 @@ import Galley.API.MLS.Welcome import qualified Galley.API.Mapping as Mapping import Galley.API.Message import Galley.API.Push +import Galley.API.Update import Galley.API.Util import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Effects -import qualified Galley.Effects.BrigAccess as E import Galley.Effects.ConversationStore (deleteGroupIds) import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.FireAndForget as E @@ -79,7 +78,6 @@ import qualified Polysemy.TinyLog as P import Servant (ServerT) import Servant.API import qualified System.Logger.Class as Log -import Wire.API.Connection import Wire.API.Conversation hiding (Member) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action @@ -101,7 +99,6 @@ import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation import Wire.API.MLS.Welcome import Wire.API.Message -import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Named (Named (Named)) import Wire.API.ServantProto @@ -252,9 +249,6 @@ getConversations domain (F.GetConversationsRequest uid cids) = do . mapMaybe (Mapping.conversationToRemote (tDomain loc) ruid) <$> E.getConversations cids -getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] -getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomain) . toList - -- | Update the local database with information on conversation members joining -- or leaving. Finally, push out notifications to local users. onConversationUpdated :: @@ -268,99 +262,7 @@ onConversationUpdated :: Domain -> F.ConversationUpdate -> Sem r () -onConversationUpdated requestingDomain cu = do - loc <- qualifyLocal () - let rconvId = toRemoteUnsafe requestingDomain (F.cuConvId cu) - qconvId = tUntagged rconvId - - -- Note: we generally do not send notifications to users that are not part of - -- the conversation (from our point of view), to prevent spam from the remote - -- backend. See also the comment below. - (presentUsers, allUsersArePresent) <- - E.selectRemoteMembers (F.cuAlreadyPresentUsers cu) rconvId - - -- Perform action, and determine extra notification targets. - -- - -- When new users are being added to the conversation, we consider them as - -- notification targets. Since we check connections before letting - -- people being added, this is safe against spam. However, if users that - -- are not in the conversations are being removed or have their membership state - -- updated, we do **not** add them to the list of targets, because we have no - -- way to make sure that they are actually supposed to receive that notification. - - (mActualAction :: Maybe SomeConversationAction, extraTargets :: [UserId]) <- case F.cuAction cu of - sca@(SomeConversationAction singTag action) -> case singTag of - SConversationJoinTag -> do - let ConversationJoin toAdd role = action - let (localUsers, remoteUsers) = partitionQualified loc toAdd - addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId (F.cuOrigUserId cu) localUsers - let allAddedUsers = map (tUntagged . qualifyAs loc) addedLocalUsers <> map tUntagged remoteUsers - case allAddedUsers of - [] -> pure (Nothing, []) -- If no users get added, its like no action was performed. - (u : us) -> pure (Just (SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (u :| us) role)), addedLocalUsers) - SConversationLeaveTag -> do - let users = foldQualified loc (pure . tUnqualified) (const []) (F.cuOrigUserId cu) - E.deleteMembersInRemoteConversation rconvId users - pure (Just sca, []) - SConversationRemoveMembersTag -> do - let localUsers = getLocalUsers (tDomain loc) action - E.deleteMembersInRemoteConversation rconvId localUsers - pure (Just sca, []) - SConversationMemberUpdateTag -> - pure (Just sca, []) - SConversationDeleteTag -> do - E.deleteMembersInRemoteConversation rconvId presentUsers - pure (Just sca, []) - SConversationRenameTag -> pure (Just sca, []) - SConversationMessageTimerUpdateTag -> pure (Just sca, []) - SConversationReceiptModeUpdateTag -> pure (Just sca, []) - SConversationAccessDataTag -> pure (Just sca, []) - - unless allUsersArePresent $ - P.warn $ - Log.field "conversation" (toByteString' (F.cuConvId cu)) - . Log.field "domain" (toByteString' requestingDomain) - . Log.msg - ( "Attempt to send notification about conversation update \ - \to users not in the conversation" :: - ByteString - ) - - -- Send notifications - for_ mActualAction $ \(SomeConversationAction tag action) -> do - let event = conversationActionToEvent tag (F.cuTime cu) (F.cuOrigUserId cu) qconvId Nothing action - targets = nubOrd $ presentUsers <> extraTargets - -- FUTUREWORK: support bots? - pushConversationEvent Nothing event (qualifyAs loc targets) [] - -addLocalUsersToRemoteConv :: - ( Member BrigAccess r, - Member MemberStore r, - Member P.TinyLog r - ) => - Remote ConvId -> - Qualified UserId -> - [UserId] -> - Sem r (Set UserId) -addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do - connStatus <- E.getConnections localUsers (Just [qAdder]) (Just Accepted) - let localUserIdsSet = Set.fromList localUsers - connected = Set.fromList $ fmap csv2From connStatus - unconnected = Set.difference localUserIdsSet connected - connectedList = Set.toList connected - - -- FUTUREWORK: Consider handling the discrepancy between the views of the - -- conversation-owning backend and the local backend - unless (Set.null unconnected) $ - P.warn $ - Log.msg ("A remote user is trying to add unconnected local users to a remote conversation" :: Text) - . Log.field "remote_user" (show qAdder) - . Log.field "local_unconnected_users" (show unconnected) - - -- Update the local view of the remote conversation by adding only those local - -- users that are connected to the adder - E.createMembersInRemoteConversation remoteConvId connectedList - pure connected +onConversationUpdated requestingDomain cu = updateLocalStateOfRemoteConv requestingDomain cu -- as of now this will not generate the necessary events on the leaver's domain leaveConversation :: @@ -381,7 +283,7 @@ leaveConversation :: F.LeaveConversationRequest -> Sem r F.LeaveConversationResponse leaveConversation requestingDomain lc = do - let leaver :: Remote UserId = qTagUnsafe $ Qualified (F.lcLeaver lc) requestingDomain + let leaver = Qualified (F.lcLeaver lc) requestingDomain lcnv <- qualifyLocal (F.lcConvId lc) res <- @@ -391,34 +293,48 @@ leaveConversation requestingDomain lc = do . mapToRuntimeError @'InvalidOperation F.RemoveFromConversationErrorRemovalNotAllowed . mapError @NoChanges (const F.RemoveFromConversationErrorUnchanged) $ do - (conv, _self) <- getConversationAndMemberWithError @'ConvNotFound (tUntagged leaver) lcnv - update <- - lcuUpdate - <$> updateLocalConversation - @'ConversationLeaveTag - lcnv - (tUntagged leaver) - Nothing - () - pure (update, conv) + (conv, _self) <- getConversationAndMemberWithError @'ConvNotFound leaver lcnv + outcome <- + runError @FederationError $ + first lcuUpdate + <$> updateLocalConversation + @'ConversationLeaveTag + lcnv + leaver + Nothing + () + case outcome of + Left e -> do + logFederationError lcnv e + throw . internalErr $ e + Right update -> pure (update, conv) case res of Left e -> pure $ F.LeaveConversationResponse (Left e) - Right (_update, conv) -> do - let remotes = filter ((== tDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) + Right ((_update, updateFailedToProcess), conv) -> do + let remotes = filter ((== qDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) let botsAndMembers = BotsAndMembers mempty (Set.fromList remotes) mempty - _ <- - notifyConversationAction - False - SConversationLeaveTag - (tUntagged leaver) - False - Nothing - (qualifyAs lcnv conv) - botsAndMembers - () - - pure $ F.LeaveConversationResponse (Right ()) + (_, notifyFailedToProcess) <- do + outcome <- + runError @FederationError $ + notifyConversationAction + SConversationLeaveTag + leaver + False + Nothing + (qualifyAs lcnv conv) + botsAndMembers + () + case outcome of + Left e -> do + logFederationError lcnv e + throw . internalErr $ e + Right v -> pure v + + pure . F.LeaveConversationResponse . Right $ + updateFailedToProcess <> notifyFailedToProcess + where + internalErr = InternalErrorWithDescription . LT.pack . displayException -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients @@ -536,16 +452,17 @@ onUserDeleted origDomain udcn = do Public.RegularConv -> do let botsAndMembers = convBotsAndMembers conv removeUser (qualifyAs lc conv) (tUntagged deletedUser) - void $ - notifyConversationAction - False - (sing @'ConversationLeaveTag) - untaggedDeletedUser - False - Nothing - (qualifyAs lc conv) - botsAndMembers - () + outcome <- + runError @FederationError $ + notifyConversationAction + (sing @'ConversationLeaveTag) + untaggedDeletedUser + False + Nothing + (qualifyAs lc conv) + botsAndMembers + () + whenLeft outcome . logFederationError $ lc pure EmptyResponse updateConversation :: @@ -584,53 +501,53 @@ updateConversation origDomain updateRequest = do SomeConversationAction tag action -> case tag of SConversationJoinTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationJoinTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged rusr) Nothing action SConversationLeaveTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationLeaveTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationLeaveTag lcnv (tUntagged rusr) Nothing action SConversationRemoveMembersTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationRemoveMembersTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationRemoveMembersTag lcnv (tUntagged rusr) Nothing action SConversationMemberUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationMemberUpdateTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationMemberUpdateTag lcnv (tUntagged rusr) Nothing action SConversationDeleteTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationDeleteTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationDeleteTag lcnv (tUntagged rusr) Nothing action SConversationRenameTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationRenameTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationRenameTag lcnv (tUntagged rusr) Nothing action SConversationMessageTimerUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationMessageTimerUpdateTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationMessageTimerUpdateTag lcnv (tUntagged rusr) Nothing action SConversationReceiptModeUpdateTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationReceiptModeUpdateTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationReceiptModeUpdateTag lcnv (tUntagged rusr) Nothing action SConversationAccessDataTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationAccessDataTag) - . fmap lcuUpdate + . fmap (first lcuUpdate) $ updateLocalConversation @'ConversationAccessDataTag lcnv (tUntagged rusr) Nothing action where mkResponse = fmap toResponse . runError @GalleyError . runError @NoChanges toResponse (Left galleyErr) = F.ConversationUpdateResponseError galleyErr toResponse (Right (Left NoChanges)) = F.ConversationUpdateResponseNoChanges - toResponse (Right (Right update)) = F.ConversationUpdateResponseUpdate update + toResponse (Right (Right (update, ftp))) = F.ConversationUpdateResponseUpdate update ftp sendMLSCommitBundle :: ( Member BrigAccess r, @@ -974,3 +891,24 @@ instance runError act >>= \case Left _ -> throw (demote @err) Right res -> pure res + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +-- | Log a federation error that is impossible in processing a remote request +-- for a local conversation. +logFederationError :: + Member P.TinyLog r => + Local ConvId -> + FederationError -> + Sem r () +logFederationError lc e = + P.warn $ + Log.field "conversation" (toByteString' (tUnqualified lc)) + Log.~~ Log.field "domain" (toByteString' (tDomain lc)) + Log.~~ Log.msg + ( "An impossible federation error occurred when deleting\ + \ a user from a local conversation: " + <> displayException e + ) diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 240a8e544c..794486cadf 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -51,7 +51,6 @@ import Galley.API.Teams.Features import qualified Galley.API.Update as Update import Galley.API.Util import Galley.App -import Galley.Cassandra.TeamFeatures import qualified Galley.Data.Conversation as Data import Galley.Effects import Galley.Effects.ClientStore @@ -142,80 +141,80 @@ iTeamsAPI = mkAPI $ \tid -> hoistAPIHandler id (base tid) <@> mkNamedAPI @"get-team-name" (Teams.getTeamNameInternalH tid) <@> mkNamedAPI @"update-team-status" (Teams.updateTeamStatus tid) <@> hoistAPISegment - ( mkNamedAPI @"unchecked-add-team-member" (Teams.uncheckedAddTeamMember @Cassandra tid) + ( mkNamedAPI @"unchecked-add-team-member" (Teams.uncheckedAddTeamMember tid) <@> mkNamedAPI @"unchecked-get-team-members" (Teams.uncheckedGetTeamMembersH tid) <@> mkNamedAPI @"unchecked-get-team-member" (Teams.uncheckedGetTeamMember tid) - <@> mkNamedAPI @"can-user-join-team" (Teams.canUserJoinTeam @Cassandra tid) + <@> mkNamedAPI @"can-user-join-team" (Teams.canUserJoinTeam tid) <@> mkNamedAPI @"unchecked-update-team-member" (Teams.uncheckedUpdateTeamMember Nothing Nothing tid) ) <@> mkNamedAPI @"user-is-team-owner" (Teams.userIsTeamOwner tid) <@> hoistAPISegment ( mkNamedAPI @"get-search-visibility-internal" (Teams.getSearchVisibilityInternal tid) - <@> mkNamedAPI @"set-search-visibility-internal" (Teams.setSearchVisibilityInternal (featureEnabledForTeam @Cassandra @SearchVisibilityAvailableConfig) tid) + <@> mkNamedAPI @"set-search-visibility-internal" (Teams.setSearchVisibilityInternal (featureEnabledForTeam @SearchVisibilityAvailableConfig) tid) ) featureAPI :: API IFeatureAPI GalleyEffects featureAPI = - mkNamedAPI @'("iget", SSOConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", SSOConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", SSOConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", LegalholdConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", LegalholdConfig) (callsFed (exposeAnnotations (setFeatureStatusInternal @Cassandra))) - <@> mkNamedAPI @'("ipatch", LegalholdConfig) (callsFed (exposeAnnotations (patchFeatureStatusInternal @Cassandra))) - <@> mkNamedAPI @'("iget", SearchVisibilityAvailableConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", SearchVisibilityAvailableConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", SearchVisibilityAvailableConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", ValidateSAMLEmailsConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", ValidateSAMLEmailsConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", ValidateSAMLEmailsConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", DigitalSignaturesConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", DigitalSignaturesConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", DigitalSignaturesConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", AppLockConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", AppLockConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", AppLockConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", FileSharingConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", FileSharingConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ilock", FileSharingConfig) (updateLockStatus @Cassandra @FileSharingConfig) - <@> mkNamedAPI @'("ipatch", FileSharingConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", ConferenceCallingConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", ConferenceCallingConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", ConferenceCallingConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", SelfDeletingMessagesConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", SelfDeletingMessagesConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ilock", SelfDeletingMessagesConfig) (updateLockStatus @Cassandra @SelfDeletingMessagesConfig) - <@> mkNamedAPI @'("ipatch", SelfDeletingMessagesConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", GuestLinksConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", GuestLinksConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ilock", GuestLinksConfig) (updateLockStatus @Cassandra @GuestLinksConfig) - <@> mkNamedAPI @'("ipatch", GuestLinksConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", SndFactorPasswordChallengeConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", SndFactorPasswordChallengeConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ilock", SndFactorPasswordChallengeConfig) (updateLockStatus @Cassandra @SndFactorPasswordChallengeConfig) - <@> mkNamedAPI @'("ipatch", SndFactorPasswordChallengeConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", SearchVisibilityInboundConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", SearchVisibilityInboundConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", SearchVisibilityInboundConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("igetmulti", SearchVisibilityInboundConfig) (getFeatureStatusMulti @Cassandra) - <@> mkNamedAPI @'("iget", ClassifiedDomainsConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iget", MLSConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", MLSConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", MLSConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", ExposeInvitationURLsToTeamAdminConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", ExposeInvitationURLsToTeamAdminConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", ExposeInvitationURLsToTeamAdminConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", SearchVisibilityInboundConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", SearchVisibilityInboundConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", SearchVisibilityInboundConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("iget", OutlookCalIntegrationConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", OutlookCalIntegrationConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", OutlookCalIntegrationConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ilock", OutlookCalIntegrationConfig) (updateLockStatus @Cassandra @OutlookCalIntegrationConfig) - <@> mkNamedAPI @'("iget", MlsE2EIdConfig) (getFeatureStatus @Cassandra DontDoAuth) - <@> mkNamedAPI @'("iput", MlsE2EIdConfig) (setFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ipatch", MlsE2EIdConfig) (patchFeatureStatusInternal @Cassandra) - <@> mkNamedAPI @'("ilock", MlsE2EIdConfig) (updateLockStatus @Cassandra @MlsE2EIdConfig) - <@> mkNamedAPI @"feature-configs-internal" (maybe getAllFeatureConfigsForServer (getAllFeatureConfigsForUser @Cassandra)) + mkNamedAPI @'("iget", SSOConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", SSOConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", SSOConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", LegalholdConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", LegalholdConfig) (callsFed (exposeAnnotations setFeatureStatusInternal)) + <@> mkNamedAPI @'("ipatch", LegalholdConfig) (callsFed (exposeAnnotations patchFeatureStatusInternal)) + <@> mkNamedAPI @'("iget", SearchVisibilityAvailableConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", SearchVisibilityAvailableConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", SearchVisibilityAvailableConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", ValidateSAMLEmailsConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", ValidateSAMLEmailsConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", ValidateSAMLEmailsConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", DigitalSignaturesConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", DigitalSignaturesConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", DigitalSignaturesConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", AppLockConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", AppLockConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", AppLockConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", FileSharingConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", FileSharingConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ilock", FileSharingConfig) (updateLockStatus @FileSharingConfig) + <@> mkNamedAPI @'("ipatch", FileSharingConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", ConferenceCallingConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", ConferenceCallingConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", ConferenceCallingConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", SelfDeletingMessagesConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", SelfDeletingMessagesConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ilock", SelfDeletingMessagesConfig) (updateLockStatus @SelfDeletingMessagesConfig) + <@> mkNamedAPI @'("ipatch", SelfDeletingMessagesConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", GuestLinksConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", GuestLinksConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ilock", GuestLinksConfig) (updateLockStatus @GuestLinksConfig) + <@> mkNamedAPI @'("ipatch", GuestLinksConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", SndFactorPasswordChallengeConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", SndFactorPasswordChallengeConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ilock", SndFactorPasswordChallengeConfig) (updateLockStatus @SndFactorPasswordChallengeConfig) + <@> mkNamedAPI @'("ipatch", SndFactorPasswordChallengeConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", SearchVisibilityInboundConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", SearchVisibilityInboundConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", SearchVisibilityInboundConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("igetmulti", SearchVisibilityInboundConfig) getFeatureStatusMulti + <@> mkNamedAPI @'("iget", ClassifiedDomainsConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iget", MLSConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", MLSConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", MLSConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", ExposeInvitationURLsToTeamAdminConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", ExposeInvitationURLsToTeamAdminConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", ExposeInvitationURLsToTeamAdminConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", SearchVisibilityInboundConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", SearchVisibilityInboundConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", SearchVisibilityInboundConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("iget", OutlookCalIntegrationConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", OutlookCalIntegrationConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", OutlookCalIntegrationConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("ilock", OutlookCalIntegrationConfig) (updateLockStatus @OutlookCalIntegrationConfig) + <@> mkNamedAPI @'("iget", MlsE2EIdConfig) (getFeatureStatus DontDoAuth) + <@> mkNamedAPI @'("iput", MlsE2EIdConfig) setFeatureStatusInternal + <@> mkNamedAPI @'("ipatch", MlsE2EIdConfig) patchFeatureStatusInternal + <@> mkNamedAPI @'("ilock", MlsE2EIdConfig) (updateLockStatus @MlsE2EIdConfig) + <@> mkNamedAPI @"feature-configs-internal" (maybe getAllFeatureConfigsForServer getAllFeatureConfigsForUser) internalSitemap :: Routes a (Sem GalleyEffects) () internalSitemap = unsafeCallsFed @'Galley @"on-client-removed" $ unsafeCallsFed @'Galley @"on-mls-message-sent" $ do diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index f02fad715d..fea1cb9e81 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -26,7 +26,6 @@ module Galley.API.LegalHold requestDevice, approveDevice, disableForUser, - isLegalHoldEnabledForTeam, unsetTeamLegalholdWhitelistedH, ) where @@ -45,6 +44,7 @@ import Data.Qualified import Data.Range (toRange) import Data.Time.Clock import Galley.API.Error +import Galley.API.LegalHold.Team import Galley.API.Query (iterateConversations) import Galley.API.Update (removeMemberFromLocalConv) import Galley.API.Util @@ -54,7 +54,6 @@ import Galley.Effects import Galley.Effects.BrigAccess import Galley.Effects.FireAndForget import qualified Galley.Effects.LegalHoldStore as LegalHoldData -import qualified Galley.Effects.TeamFeatureStore as TeamFeatures import Galley.Effects.TeamMemberStore import Galley.Effects.TeamStore import qualified Galley.External.LegalHoldService as LHService @@ -71,10 +70,10 @@ import Wire.API.Conversation (ConvType (..)) 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 -import qualified Wire.API.Team.Feature as Public import Wire.API.Team.LegalHold import qualified Wire.API.Team.LegalHold as Public import Wire.API.Team.LegalHold.External hiding (userId) @@ -83,64 +82,25 @@ import Wire.API.User.Client.Prekey import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra -assertLegalHoldEnabledForTeam :: - forall db r. - ( Member LegalHoldStore r, - Member TeamStore r, - Member (TeamFeatureStore db) r, - Member (ErrorS 'LegalHoldNotEnabled) r - ) => - TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig => - TeamId -> - Sem r () -assertLegalHoldEnabledForTeam tid = - unlessM (isLegalHoldEnabledForTeam @db tid) $ - throwS @'LegalHoldNotEnabled - -isLegalHoldEnabledForTeam :: - forall db r. - ( ( Member LegalHoldStore r, - Member TeamStore r, - Member (TeamFeatureStore db) r - ), - TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig - ) => - TeamId -> - Sem r Bool -isLegalHoldEnabledForTeam tid = do - getLegalHoldFlag >>= \case - FeatureLegalHoldDisabledPermanently -> do - pure False - FeatureLegalHoldDisabledByDefault -> do - statusValue <- - Public.wssStatus <$$> TeamFeatures.getFeatureConfig @db (Proxy @Public.LegalholdConfig) tid - pure $ case statusValue of - Just Public.FeatureStatusEnabled -> True - Just Public.FeatureStatusDisabled -> False - Nothing -> False - FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> - LegalHoldData.isTeamLegalholdWhitelisted tid - createSettings :: - forall db r. + forall r. ( Member (ErrorS 'NotATeamMember) r, Member (ErrorS OperationDenied) r, Member (ErrorS 'LegalHoldNotEnabled) r, Member (ErrorS 'LegalHoldServiceInvalidKey) r, Member (ErrorS 'LegalHoldServiceBadResponse) r, Member LegalHoldStore r, - Member (TeamFeatureStore db) r, + Member TeamFeatureStore r, Member TeamStore r, Member P.TinyLog r ) => - TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig => Local UserId -> TeamId -> Public.NewLegalHoldService -> Sem r Public.ViewLegalHoldService createSettings lzusr tid newService = do let zusr = tUnqualified lzusr - assertLegalHoldEnabledForTeam @db tid + assertLegalHoldEnabledForTeam tid zusrMembership <- getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ @@ -156,13 +116,12 @@ createSettings lzusr tid newService = do pure . viewLegalHoldService $ service getSettings :: - forall db r. + forall r. ( Member (ErrorS 'NotATeamMember) r, Member LegalHoldStore r, - Member (TeamFeatureStore db) r, + Member TeamFeatureStore r, Member TeamStore r ) => - TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig => Local UserId -> TeamId -> Sem r Public.ViewLegalHoldService @@ -170,7 +129,7 @@ getSettings lzusr tid = do let zusr = tUnqualified lzusr zusrMembership <- getTeamMember tid zusr void $ maybe (throwS @'NotATeamMember) pure zusrMembership - isenabled <- isLegalHoldEnabledForTeam @db tid + isenabled <- isLegalHoldEnabledForTeam tid mresult <- LegalHoldData.getSettings tid pure $ case (isenabled, mresult) of (False, _) -> Public.ViewLegalHoldServiceDisabled @@ -178,10 +137,11 @@ getSettings lzusr tid = do (True, Just result) -> viewLegalHoldService result removeSettingsInternalPaging :: - forall db r. + forall r. ( Member BrigAccess 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, @@ -203,25 +163,25 @@ removeSettingsInternalPaging :: Member MemberStore r, Member ProposalStore r, Member P.TinyLog r, - Member SubConversationStore r, - Member (TeamFeatureStore db) r, + Member TeamFeatureStore r, Member (TeamMemberStore InternalPaging) r, - Member TeamStore r + Member TeamStore r, + Member SubConversationStore r ) => - TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig => Local UserId -> TeamId -> Public.RemoveLegalHoldSettingsRequest -> Sem r () -removeSettingsInternalPaging lzusr = removeSettings @db @InternalPaging (tUnqualified lzusr) +removeSettingsInternalPaging lzusr = removeSettings @InternalPaging (tUnqualified lzusr) removeSettings :: - forall db p r. + forall p r. ( Paging p, Bounded (PagingBounds p TeamMember), Member BrigAccess 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, @@ -243,19 +203,18 @@ removeSettings :: Member MemberStore r, Member ProposalStore r, Member P.TinyLog r, - Member SubConversationStore r, - Member (TeamFeatureStore db) r, + Member TeamFeatureStore r, Member (TeamMemberStore p) r, - Member TeamStore r + Member TeamStore r, + Member SubConversationStore r ) => - TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig => UserId -> TeamId -> Public.RemoveLegalHoldSettingsRequest -> Sem r () removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do assertNotWhitelisting - assertLegalHoldEnabledForTeam @db tid + assertLegalHoldEnabledForTeam tid zusrMembership <- getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ @@ -280,6 +239,7 @@ removeSettings' :: Bounded (PagingBounds p TeamMember), Member BrigAccess r, Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldServiceNotRegistered) r, @@ -367,6 +327,7 @@ getUserStatus _lzusr tid uid = do grantConsent :: ( Member BrigAccess r, Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -401,9 +362,10 @@ grantConsent lusr tid = do -- | Request to provision a device on the legal hold service for a user requestDevice :: - forall db r. + forall r. ( Member BrigAccess r, Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -428,10 +390,9 @@ requestDevice :: Member ProposalStore r, Member P.TinyLog r, Member SubConversationStore r, - Member (TeamFeatureStore db) r, + Member TeamFeatureStore r, Member TeamStore r ) => - TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig => Local UserId -> TeamId -> UserId -> @@ -439,7 +400,7 @@ requestDevice :: requestDevice lzusr tid uid = do let zusr = tUnqualified lzusr luid <- qualifyLocal uid - assertLegalHoldEnabledForTeam @db tid + assertLegalHoldEnabledForTeam tid P.debug $ Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.requestDevice") @@ -480,10 +441,11 @@ requestDevice lzusr tid uid = do -- it gets interupted. There's really no reason to delete them anyways -- since they are replaced if needed when registering new LH devices. approveDevice :: - forall db r. + forall r. ( Member BrigAccess r, Member ConversationStore r, Member (Error AuthenticationError) r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, @@ -507,10 +469,9 @@ approveDevice :: Member ProposalStore r, Member P.TinyLog r, Member SubConversationStore r, - Member (TeamFeatureStore db) r, + Member TeamFeatureStore r, Member TeamStore r ) => - TeamFeatures.FeaturePersistentConstraint db Public.LegalholdConfig => Local UserId -> ConnId -> TeamId -> @@ -520,7 +481,7 @@ approveDevice :: approveDevice lzusr connId tid uid (Public.ApproveLegalHoldForUserRequest mPassword) = do let zusr = tUnqualified lzusr luid <- qualifyLocal uid - assertLegalHoldEnabledForTeam @db tid + assertLegalHoldEnabledForTeam tid P.debug $ Log.field "targets" (toByteString (tUnqualified luid)) . Log.field "action" (Log.val "LegalHold.approveDevice") @@ -563,6 +524,7 @@ disableForUser :: ( Member BrigAccess 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, @@ -619,6 +581,7 @@ disableForUser lzusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = changeLegalholdStatus :: ( Member BrigAccess r, Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, @@ -735,6 +698,7 @@ unsetTeamLegalholdWhitelistedH tid = do -- one from the database. handleGroupConvPolicyConflicts :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member ExternalAccess r, diff --git a/services/galley/src/Galley/API/LegalHold/Team.hs b/services/galley/src/Galley/API/LegalHold/Team.hs new file mode 100644 index 0000000000..a8d148116c --- /dev/null +++ b/services/galley/src/Galley/API/LegalHold/Team.hs @@ -0,0 +1,97 @@ +-- 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.Team + ( isLegalHoldEnabledForTeam, + assertLegalHoldEnabledForTeam, + ensureNotTooLargeToActivateLegalHold, + teamSizeBelowLimit, + ) +where + +import Data.Id +import Data.Range +import Galley.Effects +import Galley.Effects.BrigAccess +import qualified Galley.Effects.LegalHoldStore as LegalHoldData +import qualified Galley.Effects.TeamFeatureStore as TeamFeatures +import Galley.Effects.TeamStore +import Galley.Types.Teams as Team +import Imports +import Polysemy +import Wire.API.Error +import Wire.API.Error.Galley +import qualified Wire.API.Team.Feature as Public +import Wire.API.Team.Size + +assertLegalHoldEnabledForTeam :: + forall r. + ( Member LegalHoldStore r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (ErrorS 'LegalHoldNotEnabled) r + ) => + TeamId -> + Sem r () +assertLegalHoldEnabledForTeam tid = + unlessM (isLegalHoldEnabledForTeam tid) $ + throwS @'LegalHoldNotEnabled + +isLegalHoldEnabledForTeam :: + forall r. + ( Member LegalHoldStore r, + Member TeamStore r, + Member TeamFeatureStore r + ) => + TeamId -> + Sem r Bool +isLegalHoldEnabledForTeam tid = do + getLegalHoldFlag >>= \case + FeatureLegalHoldDisabledPermanently -> do + pure False + FeatureLegalHoldDisabledByDefault -> do + statusValue <- + Public.wssStatus <$$> TeamFeatures.getFeatureConfig Public.FeatureSingletonLegalholdConfig tid + pure $ case statusValue of + Just Public.FeatureStatusEnabled -> True + Just Public.FeatureStatusDisabled -> False + Nothing -> False + FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> + LegalHoldData.isTeamLegalholdWhitelisted tid + +ensureNotTooLargeToActivateLegalHold :: + ( Member BrigAccess r, + Member (ErrorS 'CannotEnableLegalHoldServiceLargeTeam) r, + Member TeamStore r + ) => + TeamId -> + Sem r () +ensureNotTooLargeToActivateLegalHold tid = do + (TeamSize teamSize) <- getSize tid + unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ + throwS @'CannotEnableLegalHoldServiceLargeTeam + +teamSizeBelowLimit :: Member TeamStore r => Int -> Sem r Bool +teamSizeBelowLimit teamSize = do + limit <- fromIntegral . fromRange <$> fanoutLimit + let withinLimit = teamSize <= limit + getLegalHoldFlag >>= \case + FeatureLegalHoldDisabledPermanently -> pure withinLimit + FeatureLegalHoldDisabledByDefault -> pure withinLimit + FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> + -- unlimited, see docs of 'ensureNotTooLargeForLegalHold' + pure True diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 967c005baf..da1c778d8c 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -95,6 +95,7 @@ import Wire.API.MLS.SubConversation import Wire.API.MLS.Welcome import Wire.API.Message import Wire.API.Routes.Internal.Brig +import Wire.API.Unreachable import Wire.API.User.Client type MLSMessageStaticErrors = @@ -204,7 +205,7 @@ postMLSCommitBundle :: Qualified ConvOrSubConvId -> Maybe ConnId -> CommitBundle -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) postMLSCommitBundle loc qusr mc qConvOrSub conn rawBundle = foldQualified loc @@ -245,7 +246,7 @@ postMLSCommitBundleToLocalConv :: Maybe ConnId -> CommitBundle -> Local ConvOrSubConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) postMLSCommitBundleToLocalConv qusr mc conn bundle lConvOrSubId = do lConvOrSub <- fetchConvOrSub qusr lConvOrSubId let msg = rmValue (cbCommitMsg bundle) @@ -305,7 +306,7 @@ postMLSCommitBundleToRemoteConv :: Maybe ConnId -> CommitBundle -> Remote ConvOrSubConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) postMLSCommitBundleToRemoteConv loc qusr mc con bundle rConvOrSubId = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr @@ -366,15 +367,16 @@ postMLSMessage :: Qualified ConvOrSubConvId -> Maybe ConnId -> RawMLS SomeMessage -> - Sem r ([LocalConversationUpdate], UnreachableUsers) -postMLSMessage loc qusr mc qconvOrSub con smsg = case rmValue smsg of - SomeMessage tag msg -> do - mSender <- fmap ciClient <$> getSenderIdentity qusr mc tag msg - foldQualified - loc - (postMLSMessageToLocalConv qusr mSender con smsg) - (postMLSMessageToRemoteConv loc qusr mSender con smsg) - qconvOrSub + Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) +postMLSMessage loc qusr mc qcnv con smsg = + case rmValue smsg of + SomeMessage tag msg -> do + mSender <- fmap ciClient <$> getSenderIdentity qusr mc tag msg + foldQualified + loc + (postMLSMessageToLocalConv qusr mSender con smsg) + (postMLSMessageToRemoteConv loc qusr mSender con smsg) + qcnv -- Check that the MLS client who created the message belongs to the user who -- is the sender of the REST request, identified by HTTP header. @@ -440,7 +442,7 @@ postMLSMessageToLocalConv :: Maybe ConnId -> RawMLS SomeMessage -> Local ConvOrSubConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) postMLSMessageToLocalConv qusr senderClient con smsg convOrSubId = case rmValue smsg of SomeMessage tag msg -> do @@ -478,7 +480,7 @@ postMLSMessageToRemoteConv :: Maybe ConnId -> RawMLS SomeMessage -> Remote ConvOrSubConvId -> - Sem r ([LocalConversationUpdate], UnreachableUsers) + Sem r ([LocalConversationUpdate], Maybe UnreachableUsers) postMLSMessageToRemoteConv loc qusr mc con smsg rConvOrSubId = do -- only local users can send messages to remote conversations lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr @@ -1254,7 +1256,7 @@ addMembers qusr con lconvOrSub users = case tUnqualified lconvOrSub of foldMap ( handleNoChanges . handleMLSProposalFailures @ProposalErrors - . fmap pure + . fmap (pure . fst) . updateLocalConversationUnchecked @'ConversationJoinTag lconv qusr con . flip ConversationJoin roleNameWireMember ) @@ -1277,7 +1279,7 @@ removeMembers qusr con lconvOrSub users = case tUnqualified lconvOrSub of foldMap ( handleNoChanges . handleMLSProposalFailures @ProposalErrors - . fmap pure + . fmap (pure . fst) . updateLocalConversationUnchecked @'ConversationRemoveMembersTag lconv qusr con ) . nonEmpty diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index f5ac6d3f7a..09c2cad3b7 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -43,9 +43,9 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error -import Wire.API.MLS.Message import Wire.API.MLS.SubConversation import Wire.API.Message +import Wire.API.Unreachable -- | Propagate a message. propagateMessage :: @@ -60,7 +60,7 @@ propagateMessage :: Maybe ConnId -> ByteString -> ClientMap -> - Sem r UnreachableUsers + Sem r (Maybe UnreachableUsers) propagateMessage qusr lConvOrSub con raw cm = do now <- input @UTCTime let mlsConv = convOfConvOrSub <$> lConvOrSub @@ -84,7 +84,7 @@ propagateMessage qusr lConvOrSub con raw cm = do foldMap (uncurry mkPush) (lmems >>= localMemberMLSClients mlsConv) -- send to remotes - UnreachableUsers . concat + unreachableFromList . concat <$$> traverse handleError <=< runFederatedConcurrentlyEither (map remoteMemberQualify rmems) $ \(tUnqualified -> rs) -> diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 0846c7e9cb..68e47fede6 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -26,10 +26,8 @@ import Data.Qualified import qualified Galley.API.Query as Query import qualified Galley.API.Teams.Features as Features import Galley.App -import Galley.Cassandra.TeamFeatures import Galley.Effects import qualified Galley.Effects as E -import Galley.Effects.TeamFeatureStore (FeaturePersistentConstraint) import Galley.Options import Imports hiding (head) import Network.Wai @@ -45,7 +43,6 @@ import Wire.API.Error import Wire.API.Error.Galley import qualified Wire.API.Event.Team as Public () import Wire.API.Routes.API -import Wire.API.Team.Feature -- These are all the errors that can be thrown by wai-routing handlers. -- We don't do any static checks on these errors, so we simply remap them to @@ -92,29 +89,28 @@ sitemap :: Routes () (Sem GalleyEffects) () sitemap = do -- Bot API ------------------------------------------------------------ - get "/bot/conversation" (continueE (getBotConversationH @Cassandra)) $ + get "/bot/conversation" (continueE getBotConversationH) $ zauth ZAuthBot .&> zauthBotId .&. zauthConvId .&. accept "application" "json" getBotConversationH :: - forall db r. + forall r. ( Member E.ConversationStore r, Member (Input (Local ())) r, Member (Input Opts) r, - Member (TeamFeatureStore db) r, + Member TeamFeatureStore r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS OperationDenied) r, Member (ErrorS 'NotATeamMember) r, Member (ErrorS 'TeamNotFound) r, - Member TeamStore r, - FeaturePersistentConstraint db SndFactorPasswordChallengeConfig + Member TeamStore r ) => BotId ::: ConvId ::: JSON -> Sem r Response getBotConversationH arg@(bid ::: cid ::: _) = - Features.guardSecondFactorDisabled @db (botUserId bid) cid (Query.getBotConversationH arg) + Features.guardSecondFactorDisabled (botUserId bid) cid (Query.getBotConversationH arg) type JSON = Media "application" "json" diff --git a/services/galley/src/Galley/API/Public/Conversation.hs b/services/galley/src/Galley/API/Public/Conversation.hs index 3efe3445ca..070d996823 100644 --- a/services/galley/src/Galley/API/Public/Conversation.hs +++ b/services/galley/src/Galley/API/Public/Conversation.hs @@ -24,7 +24,6 @@ import Galley.API.MLS.Types import Galley.API.Query import Galley.API.Update import Galley.App -import Galley.Cassandra.TeamFeatures import Imports import Wire.API.Federation.API import Wire.API.Routes.API @@ -45,7 +44,7 @@ conversationAPI = <@> mkNamedAPI @"list-conversations@v1" (callsFed (exposeAnnotations listConversations)) <@> mkNamedAPI @"list-conversations@v2" (callsFed (exposeAnnotations listConversations)) <@> mkNamedAPI @"list-conversations" (callsFed (exposeAnnotations listConversations)) - <@> mkNamedAPI @"get-conversation-by-reusable-code" (getConversationByReusableCode @Cassandra) + <@> mkNamedAPI @"get-conversation-by-reusable-code" getConversationByReusableCode <@> mkNamedAPI @"create-group-conversation@v2" (callsFed (exposeAnnotations createGroupConversationUpToV3)) <@> mkNamedAPI @"create-group-conversation@v3" (callsFed (exposeAnnotations createGroupConversationUpToV3)) <@> mkNamedAPI @"create-group-conversation" (callsFed (exposeAnnotations createGroupConversation)) @@ -62,13 +61,13 @@ conversationAPI = <@> mkNamedAPI @"add-members-to-conversation-unqualified2" (callsFed addMembersUnqualifiedV2) <@> mkNamedAPI @"add-members-to-conversation" (callsFed addMembers) <@> mkNamedAPI @"join-conversation-by-id-unqualified" (callsFed joinConversationById) - <@> mkNamedAPI @"join-conversation-by-code-unqualified" (callsFed (joinConversationByReusableCode @Cassandra)) - <@> mkNamedAPI @"code-check" (checkReusableCode @Cassandra) - <@> mkNamedAPI @"create-conversation-code-unqualified@v3" (addCodeUnqualified @Cassandra Nothing) - <@> mkNamedAPI @"create-conversation-code-unqualified" (addCodeUnqualifiedWithReqBody @Cassandra) - <@> mkNamedAPI @"get-conversation-guest-links-status" (getConversationGuestLinksStatus @Cassandra) + <@> mkNamedAPI @"join-conversation-by-code-unqualified" (callsFed joinConversationByReusableCode) + <@> mkNamedAPI @"code-check" checkReusableCode + <@> mkNamedAPI @"create-conversation-code-unqualified@v3" (addCodeUnqualified Nothing) + <@> mkNamedAPI @"create-conversation-code-unqualified" addCodeUnqualifiedWithReqBody + <@> mkNamedAPI @"get-conversation-guest-links-status" getConversationGuestLinksStatus <@> mkNamedAPI @"remove-code-unqualified" rmCodeUnqualified - <@> mkNamedAPI @"get-code" (getCode @Cassandra) + <@> mkNamedAPI @"get-code" getCode <@> mkNamedAPI @"member-typing-unqualified" (callsFed (exposeAnnotations memberTypingUnqualified)) <@> mkNamedAPI @"member-typing-qualified" (callsFed (exposeAnnotations memberTyping)) <@> mkNamedAPI @"remove-member-unqualified" (callsFed (exposeAnnotations removeMemberUnqualified)) diff --git a/services/galley/src/Galley/API/Public/Feature.hs b/services/galley/src/Galley/API/Public/Feature.hs index 028c3cfc1a..65fd370b2b 100644 --- a/services/galley/src/Galley/API/Public/Feature.hs +++ b/services/galley/src/Galley/API/Public/Feature.hs @@ -20,7 +20,6 @@ module Galley.API.Public.Feature where import Galley.API.Teams import Galley.API.Teams.Features import Galley.App -import Galley.Cassandra.TeamFeatures import Imports import Wire.API.Federation.API import Wire.API.Routes.API @@ -29,53 +28,53 @@ import Wire.API.Team.Feature featureAPI :: API FeatureAPI GalleyEffects featureAPI = - mkNamedAPI @'("get", SSOConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", LegalholdConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", LegalholdConfig) (callsFed (exposeAnnotations (setFeatureStatus @Cassandra . DoAuth))) - <@> mkNamedAPI @'("get", SearchVisibilityAvailableConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", SearchVisibilityAvailableConfig) (setFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get-deprecated", SearchVisibilityAvailableConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put-deprecated", SearchVisibilityAvailableConfig) (setFeatureStatus @Cassandra . DoAuth) + mkNamedAPI @'("get", SSOConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", LegalholdConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", LegalholdConfig) (callsFed (exposeAnnotations (setFeatureStatus . DoAuth))) + <@> mkNamedAPI @'("get", SearchVisibilityAvailableConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", SearchVisibilityAvailableConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get-deprecated", SearchVisibilityAvailableConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put-deprecated", SearchVisibilityAvailableConfig) (setFeatureStatus . DoAuth) <@> mkNamedAPI @"get-search-visibility" getSearchVisibility - <@> mkNamedAPI @"set-search-visibility" (setSearchVisibility (featureEnabledForTeam @Cassandra @SearchVisibilityAvailableConfig)) - <@> mkNamedAPI @'("get", ValidateSAMLEmailsConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get-deprecated", ValidateSAMLEmailsConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", DigitalSignaturesConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get-deprecated", DigitalSignaturesConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", AppLockConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", AppLockConfig) (setFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", FileSharingConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", FileSharingConfig) (setFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", ClassifiedDomainsConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", ConferenceCallingConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", SelfDeletingMessagesConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", SelfDeletingMessagesConfig) (setFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", GuestLinksConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", GuestLinksConfig) (setFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", SndFactorPasswordChallengeConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", SndFactorPasswordChallengeConfig) (setFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", MLSConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", MLSConfig) (setFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", ExposeInvitationURLsToTeamAdminConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", ExposeInvitationURLsToTeamAdminConfig) (setFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", SearchVisibilityInboundConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", SearchVisibilityInboundConfig) (setFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", OutlookCalIntegrationConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", OutlookCalIntegrationConfig) (setFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("get", MlsE2EIdConfig) (getFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @'("put", MlsE2EIdConfig) (setFeatureStatus @Cassandra . DoAuth) - <@> mkNamedAPI @"get-all-feature-configs-for-user" (getAllFeatureConfigsForUser @Cassandra) - <@> mkNamedAPI @"get-all-feature-configs-for-team" (getAllFeatureConfigsForTeam @Cassandra) - <@> mkNamedAPI @'("get-config", LegalholdConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", SSOConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", SearchVisibilityAvailableConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", ValidateSAMLEmailsConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", DigitalSignaturesConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", AppLockConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", FileSharingConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", ClassifiedDomainsConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", ConferenceCallingConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", SelfDeletingMessagesConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", GuestLinksConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", SndFactorPasswordChallengeConfig) (getFeatureStatusForUser @Cassandra) - <@> mkNamedAPI @'("get-config", MLSConfig) (getFeatureStatusForUser @Cassandra) + <@> mkNamedAPI @"set-search-visibility" (setSearchVisibility (featureEnabledForTeam @SearchVisibilityAvailableConfig)) + <@> mkNamedAPI @'("get", ValidateSAMLEmailsConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get-deprecated", ValidateSAMLEmailsConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", DigitalSignaturesConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get-deprecated", DigitalSignaturesConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", AppLockConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", AppLockConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", FileSharingConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", FileSharingConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", ClassifiedDomainsConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", ConferenceCallingConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", SelfDeletingMessagesConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", SelfDeletingMessagesConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", GuestLinksConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", GuestLinksConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", SndFactorPasswordChallengeConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", SndFactorPasswordChallengeConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", MLSConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", MLSConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", ExposeInvitationURLsToTeamAdminConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", ExposeInvitationURLsToTeamAdminConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", SearchVisibilityInboundConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", SearchVisibilityInboundConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", OutlookCalIntegrationConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", OutlookCalIntegrationConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @'("get", MlsE2EIdConfig) (getFeatureStatus . DoAuth) + <@> mkNamedAPI @'("put", MlsE2EIdConfig) (setFeatureStatus . DoAuth) + <@> mkNamedAPI @"get-all-feature-configs-for-user" getAllFeatureConfigsForUser + <@> mkNamedAPI @"get-all-feature-configs-for-team" getAllFeatureConfigsForTeam + <@> mkNamedAPI @'("get-config", LegalholdConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", SSOConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", SearchVisibilityAvailableConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", ValidateSAMLEmailsConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", DigitalSignaturesConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", AppLockConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", FileSharingConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", ClassifiedDomainsConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", ConferenceCallingConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", SelfDeletingMessagesConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", GuestLinksConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", SndFactorPasswordChallengeConfig) getFeatureStatusForUser + <@> mkNamedAPI @'("get-config", MLSConfig) getFeatureStatusForUser diff --git a/services/galley/src/Galley/API/Public/LegalHold.hs b/services/galley/src/Galley/API/Public/LegalHold.hs index ef64ab8e4f..b313b84e97 100644 --- a/services/galley/src/Galley/API/Public/LegalHold.hs +++ b/services/galley/src/Galley/API/Public/LegalHold.hs @@ -19,18 +19,17 @@ module Galley.API.Public.LegalHold where import Galley.API.LegalHold import Galley.App -import Galley.Cassandra.TeamFeatures import Wire.API.Federation.API import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.LegalHold legalHoldAPI :: API LegalHoldAPI GalleyEffects legalHoldAPI = - mkNamedAPI @"create-legal-hold-settings" (createSettings @Cassandra) - <@> mkNamedAPI @"get-legal-hold-settings" (getSettings @Cassandra) - <@> mkNamedAPI @"delete-legal-hold-settings" (callsFed (exposeAnnotations (removeSettingsInternalPaging @Cassandra))) + mkNamedAPI @"create-legal-hold-settings" createSettings + <@> mkNamedAPI @"get-legal-hold-settings" getSettings + <@> mkNamedAPI @"delete-legal-hold-settings" (callsFed (exposeAnnotations removeSettingsInternalPaging)) <@> mkNamedAPI @"get-legal-hold" getUserStatus <@> mkNamedAPI @"consent-to-legal-hold" (callsFed (exposeAnnotations grantConsent)) - <@> mkNamedAPI @"request-legal-hold-device" (callsFed (exposeAnnotations (requestDevice @Cassandra))) + <@> mkNamedAPI @"request-legal-hold-device" (callsFed (exposeAnnotations requestDevice)) <@> mkNamedAPI @"disable-legal-hold-for-user" (callsFed (exposeAnnotations disableForUser)) - <@> mkNamedAPI @"approve-legal-hold-device" (callsFed (exposeAnnotations (approveDevice @Cassandra))) + <@> mkNamedAPI @"approve-legal-hold-device" (callsFed (exposeAnnotations approveDevice)) diff --git a/services/galley/src/Galley/API/Public/TeamMember.hs b/services/galley/src/Galley/API/Public/TeamMember.hs index af7e761c66..91956a2171 100644 --- a/services/galley/src/Galley/API/Public/TeamMember.hs +++ b/services/galley/src/Galley/API/Public/TeamMember.hs @@ -19,7 +19,6 @@ module Galley.API.Public.TeamMember where import Galley.API.Teams import Galley.App -import Galley.Cassandra.TeamFeatures import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.TeamMember @@ -28,7 +27,7 @@ teamMemberAPI = mkNamedAPI @"get-team-members" getTeamMembers <@> mkNamedAPI @"get-team-member" getTeamMember <@> mkNamedAPI @"get-team-members-by-ids" bulkGetTeamMembers - <@> mkNamedAPI @"add-team-member" (addTeamMember @Cassandra) + <@> mkNamedAPI @"add-team-member" addTeamMember <@> mkNamedAPI @"delete-team-member" deleteTeamMember <@> mkNamedAPI @"delete-non-binding-team-member" deleteNonBindingTeamMember <@> mkNamedAPI @"update-team-member" updateTeamMember diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 01ca538839..425b6121e1 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -67,7 +67,6 @@ import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.FederatorAccess as E import qualified Galley.Effects.ListItems as E import qualified Galley.Effects.MemberStore as E -import Galley.Effects.TeamFeatureStore (FeaturePersistentConstraint) import qualified Galley.Effects.TeamFeatureStore as TeamFeatures import Galley.Env import Galley.Options @@ -620,7 +619,7 @@ getConversationMeta cnv = do pure Nothing getConversationByReusableCode :: - forall db r. + forall r. ( Member BrigAccess r, Member CodeStore r, Member ConversationStore r, @@ -631,9 +630,8 @@ getConversationByReusableCode :: Member (ErrorS 'GuestLinksDisabled) r, Member (ErrorS 'NotATeamMember) r, Member TeamStore r, - Member (TeamFeatureStore db) r, - Member (Input Opts) r, - FeaturePersistentConstraint db GuestLinksConfig + Member TeamFeatureStore r, + Member (Input Opts) r ) => Local UserId -> Key -> @@ -643,7 +641,7 @@ getConversationByReusableCode lusr key value = do c <- verifyReusableCode False Nothing (ConversationCode key value Nothing) conv <- E.getConversation (codeConversation c) >>= noteS @'ConvNotFound ensureConversationAccess (tUnqualified lusr) conv CodeAccess - ensureGuestLinksEnabled @db (Data.convTeam conv) + ensureGuestLinksEnabled (Data.convTeam conv) pure $ coverView c conv where coverView :: Data.Code -> Data.Conversation -> ConversationCoverView @@ -655,27 +653,25 @@ getConversationByReusableCode lusr key value = do } ensureGuestLinksEnabled :: - forall db r. + forall r. ( Member (ErrorS 'GuestLinksDisabled) r, - Member (TeamFeatureStore db) r, - Member (Input Opts) r, - FeaturePersistentConstraint db GuestLinksConfig + Member TeamFeatureStore r, + Member (Input Opts) r ) => Maybe TeamId -> Sem r () ensureGuestLinksEnabled mbTid = - getConversationGuestLinksFeatureStatus @db mbTid >>= \ws -> case wsStatus ws of + getConversationGuestLinksFeatureStatus mbTid >>= \ws -> case wsStatus ws of FeatureStatusEnabled -> pure () FeatureStatusDisabled -> throwS @'GuestLinksDisabled getConversationGuestLinksStatus :: - forall db r. + forall r. ( Member ConversationStore r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'ConvAccessDenied) r, Member (Input Opts) r, - Member (TeamFeatureStore db) r, - FeaturePersistentConstraint db GuestLinksConfig + Member TeamFeatureStore r ) => UserId -> ConvId -> @@ -683,13 +679,12 @@ getConversationGuestLinksStatus :: getConversationGuestLinksStatus uid convId = do conv <- E.getConversation convId >>= noteS @'ConvNotFound ensureConvAdmin (Data.convLocalMembers conv) uid - getConversationGuestLinksFeatureStatus @db (Data.convTeam conv) + getConversationGuestLinksFeatureStatus (Data.convTeam conv) getConversationGuestLinksFeatureStatus :: - forall db r. - ( Member (TeamFeatureStore db) r, - Member (Input Opts) r, - FeaturePersistentConstraint db GuestLinksConfig + forall r. + ( Member TeamFeatureStore r, + Member (Input Opts) r ) => Maybe TeamId -> Sem r (WithStatus GuestLinksConfig) @@ -698,8 +693,8 @@ getConversationGuestLinksFeatureStatus mbTid = do case mbTid of Nothing -> pure defaultStatus Just tid -> do - mbConfigNoLock <- TeamFeatures.getFeatureConfig @db (Proxy @GuestLinksConfig) tid - mbLockStatus <- TeamFeatures.getFeatureLockStatus @db (Proxy @GuestLinksConfig) tid + mbConfigNoLock <- TeamFeatures.getFeatureConfig FeatureSingletonGuestLinksConfig tid + mbLockStatus <- TeamFeatures.getFeatureLockStatus FeatureSingletonGuestLinksConfig tid pure $ computeFeatureConfigForTeamUser mbConfigNoLock mbLockStatus defaultStatus -- | The same as 'getMLSSelfConversation', but it throws an error in case the diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 94caf4992a..94f50efa35 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -83,7 +83,7 @@ import Data.Range as Range import qualified Data.Set as Set import Data.Time.Clock (UTCTime) import Galley.API.Error as Galley -import Galley.API.LegalHold +import Galley.API.LegalHold.Team import qualified Galley.API.Teams.Notifications as APITeamQueue import qualified Galley.API.Update as API import Galley.API.Util @@ -101,7 +101,6 @@ import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.Queue as E import qualified Galley.Effects.SearchVisibilityStore as SearchVisibilityData import qualified Galley.Effects.SparAccess as Spar -import Galley.Effects.TeamFeatureStore (FeaturePersistentConstraint) import qualified Galley.Effects.TeamMemberStore as E import qualified Galley.Effects.TeamStore as E import qualified Galley.Intra.Journal as Journal @@ -138,7 +137,6 @@ import qualified Wire.API.Team as Public import Wire.API.Team.Conversation import qualified Wire.API.Team.Conversation as Public import Wire.API.Team.Export (TeamExportUser (..)) -import Wire.API.Team.Feature import Wire.API.Team.Member import qualified Wire.API.Team.Member as Public import Wire.API.Team.Permission (Perm (..), Permissions (..), SPerm (..), copy, fullPermissions, self) @@ -701,7 +699,7 @@ uncheckedGetTeamMembers :: uncheckedGetTeamMembers = E.getTeamMembersWithLimit addTeamMember :: - forall db r. + forall r. ( Member BrigAccess r, Member GundeckAccess r, Member (ErrorS 'InvalidPermissions) r, @@ -716,11 +714,10 @@ addTeamMember :: Member (Input Opts) r, Member (Input UTCTime) r, Member LegalHoldStore r, - Member (TeamFeatureStore db) r, + Member TeamFeatureStore r, Member TeamNotificationStore r, Member TeamStore r, - Member P.TinyLog r, - FeaturePersistentConstraint db LegalholdConfig + Member P.TinyLog r ) => Local UserId -> ConnId -> @@ -743,28 +740,24 @@ addTeamMember lzusr zcon tid nmem = do ensureUnboundUsers [uid] ensureConnectedToLocals zusr [uid] (TeamSize sizeBeforeJoin) <- E.getSize tid - ensureNotTooLargeForLegalHold @db tid (fromIntegral sizeBeforeJoin + 1) + ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) memList <- getTeamMembersForFanout tid void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem memList -- This function is "unchecked" because there is no need to check for user binding (invite only). uncheckedAddTeamMember :: - forall db r. - ( ( Member BrigAccess r, - Member GundeckAccess r, - Member (ErrorS 'TooManyTeamMembers) r, - Member (Input (Local ())) r, - Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r, - Member (Input Opts) r, - Member (Input UTCTime) r, - Member MemberStore r, - Member LegalHoldStore r, - Member P.TinyLog r, - Member (TeamFeatureStore db) r, - Member TeamNotificationStore r, - Member TeamStore r - ), - FeaturePersistentConstraint db LegalholdConfig + forall r. + ( Member BrigAccess r, + Member GundeckAccess r, + Member (ErrorS 'TooManyTeamMembers) r, + Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r, + Member (Input Opts) r, + Member (Input UTCTime) r, + Member LegalHoldStore r, + Member P.TinyLog r, + Member TeamFeatureStore r, + Member TeamNotificationStore r, + Member TeamStore r ) => TeamId -> NewTeamMember -> @@ -772,7 +765,7 @@ uncheckedAddTeamMember :: uncheckedAddTeamMember tid nmem = do mems <- getTeamMembersForFanout tid (TeamSize sizeBeforeJoin) <- E.getSize tid - ensureNotTooLargeForLegalHold @db tid (fromIntegral sizeBeforeJoin + 1) + ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) (TeamSize sizeBeforeAdd) <- addTeamMemberInternal tid Nothing Nothing nmem mems billingUserIds <- Journal.getBillingUserIds tid $ Just $ newTeamMemberList (ntmNewTeamMember nmem : mems ^. teamMembers) (mems ^. teamMemberListType) Journal.teamUpdate tid (sizeBeforeAdd + 1) billingUserIds @@ -1243,45 +1236,20 @@ ensureNotTooLarge tid = do -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. ensureNotTooLargeForLegalHold :: - forall db r. - ( ( Member LegalHoldStore r, - Member TeamStore r, - Member (TeamFeatureStore db) r, - Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r - ), - FeaturePersistentConstraint db LegalholdConfig + forall r. + ( Member LegalHoldStore r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r ) => TeamId -> Int -> Sem r () ensureNotTooLargeForLegalHold tid teamSize = - whenM (isLegalHoldEnabledForTeam @db tid) $ + whenM (isLegalHoldEnabledForTeam tid) $ unlessM (teamSizeBelowLimit teamSize) $ throwS @'TooManyTeamMembersOnTeamWithLegalhold -ensureNotTooLargeToActivateLegalHold :: - ( Member BrigAccess r, - Member (ErrorS 'CannotEnableLegalHoldServiceLargeTeam) r, - Member TeamStore r - ) => - TeamId -> - Sem r () -ensureNotTooLargeToActivateLegalHold tid = do - (TeamSize teamSize) <- E.getSize tid - unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ - throwS @'CannotEnableLegalHoldServiceLargeTeam - -teamSizeBelowLimit :: Member TeamStore r => Int -> Sem r Bool -teamSizeBelowLimit teamSize = do - limit <- fromIntegral . fromRange <$> E.fanoutLimit - let withinLimit = teamSize <= limit - E.getLegalHoldFlag >>= \case - FeatureLegalHoldDisabledPermanently -> pure withinLimit - FeatureLegalHoldDisabledByDefault -> pure withinLimit - FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> - -- unlimited, see docs of 'ensureNotTooLargeForLegalHold' - pure True - addTeamMemberInternal :: ( Member BrigAccess r, Member (ErrorS 'TooManyTeamMembers) r, @@ -1382,22 +1350,20 @@ getBindingTeamMembers zusr = do -- thrown in IO, we could then refactor that to be thrown in `ExceptT -- RegisterError`. canUserJoinTeam :: - forall db r. - ( ( Member BrigAccess r, - Member LegalHoldStore r, - Member TeamStore r, - Member (TeamFeatureStore db) r, - Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r - ), - FeaturePersistentConstraint db LegalholdConfig + forall r. + ( Member BrigAccess r, + Member LegalHoldStore r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (ErrorS 'TooManyTeamMembersOnTeamWithLegalhold) r ) => TeamId -> Sem r () canUserJoinTeam tid = do - lhEnabled <- isLegalHoldEnabledForTeam @db tid + lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do (TeamSize sizeBeforeJoin) <- E.getSize tid - ensureNotTooLargeForLegalHold @db tid (fromIntegral sizeBeforeJoin + 1) + ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) -- | Modify and get visibility type for a team (internal, no user permission checks) getSearchVisibilityInternal :: diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 8c630764d5..2e429e0549 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -37,32 +37,28 @@ module Galley.API.Teams.Features where import Control.Lens -import Data.Bifunctor (second) import Data.ByteString.Conversion (toByteString') import Data.Id import Data.Kind -import Data.Proxy (Proxy (Proxy)) -import Data.Qualified (Local, tUnqualified) +import Data.Qualified (Local) import Data.Schema import Data.String.Conversions (cs) import Data.Time (UTCTime) import GHC.TypeLits (KnownSymbol) import Galley.API.Error (InternalError) -import Galley.API.LegalHold (isLegalHoldEnabledForTeam) import qualified Galley.API.LegalHold as LegalHold import Galley.API.Teams (ensureNotTooLargeToActivateLegalHold) +import Galley.API.Teams.Features.Get import Galley.API.Util (assertTeamExists, getTeamMembersForFanout, membersToRecipients, permissionCheck) import Galley.App import Galley.Effects -import Galley.Effects.BrigAccess (getAccountConferenceCallingConfigClient, updateSearchVisibilityInbound) -import Galley.Effects.ConversationStore as ConversationStore +import Galley.Effects.BrigAccess (updateSearchVisibilityInbound) import Galley.Effects.GundeckAccess import qualified Galley.Effects.SearchVisibilityStore as SearchVisibilityData import Galley.Effects.TeamFeatureStore import qualified Galley.Effects.TeamFeatureStore as TeamFeatures -import Galley.Effects.TeamStore (getLegalHoldFlag, getOneUserTeam, getTeam, getTeamMember) +import Galley.Effects.TeamStore (getLegalHoldFlag, getTeamMember) import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush) -import Galley.Options import Galley.Types.Teams import Imports import Polysemy @@ -70,207 +66,37 @@ import Polysemy.Error import Polysemy.Input import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Log -import Wire.API.Conversation (cnvmTeam) import Wire.API.Conversation.Role (Action (RemoveConversationMember)) -import Wire.API.Error (ErrorS, throwS) +import Wire.API.Error (ErrorS) import Wire.API.Error.Galley import qualified Wire.API.Event.FeatureConfig as Event -import qualified Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti as Multi +import Wire.API.Federation.Error import Wire.API.Team.Feature import Wire.API.Team.Member import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra -data DoAuth = DoAuth UserId | DontDoAuth - --- | Don't export methods of this typeclass -class GetFeatureConfig (db :: Type) cfg where - type GetConfigForTeamConstraints db cfg (r :: EffectRow) :: Constraint - type - GetConfigForTeamConstraints db cfg (r :: EffectRow) = - ( FeaturePersistentConstraint db cfg, - ( Member (Input Opts) r, - Member (TeamFeatureStore db) r - ) - ) - - type GetConfigForUserConstraints db cfg (r :: EffectRow) :: Constraint - type - GetConfigForUserConstraints db cfg (r :: EffectRow) = - ( FeaturePersistentConstraint db cfg, - ( Member (Input Opts) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r, - Member (TeamFeatureStore db) r - ) - ) - - getConfigForServer :: - Member (Input Opts) r => - Sem r (WithStatus cfg) - -- only override if there is additional business logic for getting the feature config - -- and/or if the feature flag is configured for the backend in 'FeatureFlags' for galley in 'Galley.Types.Teams' - -- otherwise this will return the default config from wire-api - default getConfigForServer :: (IsFeatureConfig cfg) => Sem r (WithStatus cfg) - getConfigForServer = pure defFeatureStatus - - getConfigForTeam :: - GetConfigForTeamConstraints db cfg r => - TeamId -> - Sem r (WithStatus cfg) - default getConfigForTeam :: - ( FeaturePersistentConstraint db cfg, - ( Member (Input Opts) r, - Member (TeamFeatureStore db) r - ) - ) => - TeamId -> - Sem r (WithStatus cfg) - getConfigForTeam = genericGetConfigForTeam @db - - getConfigForUser :: - GetConfigForUserConstraints db cfg r => - UserId -> - Sem r (WithStatus cfg) - default getConfigForUser :: - ( FeaturePersistentConstraint db cfg, - ( Member (Input Opts) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r, - Member (TeamFeatureStore db) r - ) - ) => - UserId -> - Sem r (WithStatus cfg) - getConfigForUser = genericGetConfigForUser @db - --- | Don't export methods of this typeclass -class GetFeatureConfig (db :: Type) cfg => SetFeatureConfig (db :: Type) cfg where - type SetConfigForTeamConstraints db cfg (r :: EffectRow) :: Constraint - type SetConfigForTeamConstraints db cfg (r :: EffectRow) = () - - -- | This method should generate the side-effects of changing the feature and - -- also (depending on the feature) persist the new setting to the database and - -- push a event to clients (see 'persistAndPushEvent'). - setConfigForTeam :: - ( SetConfigForTeamConstraints db cfg r, - GetConfigForTeamConstraints db cfg r, - FeaturePersistentConstraint db cfg, - ( Member (TeamFeatureStore db) r, - Member (P.Logger (Log.Msg -> Log.Msg)) r, - Member GundeckAccess r, - Member TeamStore r - ) - ) => - TeamId -> - WithStatusNoLock cfg -> - Sem r (WithStatus cfg) - default setConfigForTeam :: - ( GetConfigForTeamConstraints db cfg r, - FeaturePersistentConstraint db cfg, - IsFeatureConfig cfg, - KnownSymbol (FeatureSymbol cfg), - ToSchema cfg, - Members - '[ TeamFeatureStore db, - P.Logger (Log.Msg -> Log.Msg), - GundeckAccess, - TeamStore - ] - r - ) => - TeamId -> - WithStatusNoLock cfg -> - Sem r (WithStatus cfg) - setConfigForTeam tid wsnl = persistAndPushEvent @db tid wsnl - -type FeaturePersistentAllFeatures db = - ( FeaturePersistentConstraint db LegalholdConfig, - FeaturePersistentConstraint db SSOConfig, - FeaturePersistentConstraint db SearchVisibilityAvailableConfig, - FeaturePersistentConstraint db ValidateSAMLEmailsConfig, - FeaturePersistentConstraint db DigitalSignaturesConfig, - FeaturePersistentConstraint db AppLockConfig, - FeaturePersistentConstraint db FileSharingConfig, - FeaturePersistentConstraint db ClassifiedDomainsConfig, - FeaturePersistentConstraint db ConferenceCallingConfig, - FeaturePersistentConstraint db SelfDeletingMessagesConfig, - FeaturePersistentConstraint db GuestLinksConfig, - FeaturePersistentConstraint db SndFactorPasswordChallengeConfig, - FeaturePersistentConstraint db MLSConfig, - FeaturePersistentConstraint db SearchVisibilityInboundConfig, - FeaturePersistentConstraint db ExposeInvitationURLsToTeamAdminConfig, - FeaturePersistentConstraint db OutlookCalIntegrationConfig, - FeaturePersistentConstraint db MlsE2EIdConfig - ) - -getFeatureStatus :: - forall db cfg r. - ( GetFeatureConfig db cfg, - GetConfigForTeamConstraints db cfg r, - ( Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r - ) - ) => - DoAuth -> - TeamId -> - Sem r (WithStatus cfg) -getFeatureStatus doauth tid = do - case doauth of - DoAuth uid -> - getTeamMember tid uid >>= maybe (throwS @'NotATeamMember) (const $ pure ()) - DontDoAuth -> - assertTeamExists tid - getConfigForTeam @db @cfg tid - -getFeatureStatusMulti :: - forall db cfg r. - ( GetFeatureConfig db cfg, - FeaturePersistentConstraint db cfg, - ( Member (Input Opts) r, - Member (TeamFeatureStore db) r - ) - ) => - Multi.TeamFeatureNoConfigMultiRequest -> - Sem r (Multi.TeamFeatureNoConfigMultiResponse cfg) -getFeatureStatusMulti (Multi.TeamFeatureNoConfigMultiRequest tids) = do - cfgs <- genericGetConfigForMultiTeam @db @cfg tids - let xs = uncurry toTeamStatus . second forgetLock <$> cfgs - pure $ Multi.TeamFeatureNoConfigMultiResponse xs - -toTeamStatus :: TeamId -> WithStatusNoLock cfg -> Multi.TeamStatus cfg -toTeamStatus tid ws = Multi.TeamStatus tid (wssStatus ws) - patchFeatureStatusInternal :: - forall db cfg r. - ( SetFeatureConfig db cfg, - GetConfigForTeamConstraints db cfg r, - SetConfigForTeamConstraints db cfg r, - FeaturePersistentConstraint db cfg, - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'TeamNotFound) r, - Member (Error TeamFeatureError) r, - Member TeamStore r, - Member (TeamFeatureStore db) r, - Member (P.Logger (Log.Msg -> Log.Msg)) r, - Member GundeckAccess r - ) + forall cfg r. + ( SetFeatureConfig cfg, + GetConfigForTeamConstraints cfg r, + SetConfigForTeamConstraints cfg r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (P.Logger (Log.Msg -> Log.Msg)) r, + Member GundeckAccess r ) => TeamId -> WithStatusPatch cfg -> Sem r (WithStatus cfg) patchFeatureStatusInternal tid patch = do - currentFeatureStatus <- getFeatureStatus @db @cfg DontDoAuth tid + currentFeatureStatus <- getFeatureStatus @cfg DontDoAuth tid let newFeatureStatus = applyPatch currentFeatureStatus - when (isJust $ wspLockStatus patch) $ void $ updateLockStatus @db @cfg tid (wsLockStatus newFeatureStatus) - setConfigForTeam @db @cfg tid (forgetLock newFeatureStatus) + when (isJust $ wspLockStatus patch) $ void $ updateLockStatus @cfg tid (wsLockStatus newFeatureStatus) + setConfigForTeam @cfg tid (forgetLock newFeatureStatus) where applyPatch :: WithStatus cfg -> WithStatus cfg applyPatch current = @@ -281,20 +107,18 @@ patchFeatureStatusInternal tid patch = do & setWsTTL (fromMaybe (wsTTL current) (wspTTL patch)) setFeatureStatus :: - forall db cfg r. - ( SetFeatureConfig db cfg, - GetConfigForTeamConstraints db cfg r, - SetConfigForTeamConstraints db cfg r, - FeaturePersistentConstraint db cfg, - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'TeamNotFound) r, - Member (Error TeamFeatureError) r, - Member TeamStore r, - Member (TeamFeatureStore db) r, - Member (P.Logger (Log.Msg -> Log.Msg)) r, - Member GundeckAccess r - ) + forall cfg r. + ( SetFeatureConfig cfg, + GetConfigForTeamConstraints cfg r, + SetConfigForTeamConstraints cfg r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'TeamNotFound) r, + Member (Error TeamFeatureError) r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (P.Logger (Log.Msg -> Log.Msg)) r, + Member GundeckAccess r ) => DoAuth -> TeamId -> @@ -307,34 +131,32 @@ setFeatureStatus doauth tid wsnl = do void $ permissionCheck ChangeTeamFeature zusrMembership DontDoAuth -> assertTeamExists tid - guardLockStatus . wsLockStatus =<< getConfigForTeam @db @cfg tid - setConfigForTeam @db @cfg tid wsnl + guardLockStatus . wsLockStatus =<< getConfigForTeam @cfg tid + setConfigForTeam @cfg tid wsnl setFeatureStatusInternal :: - forall db cfg r. - ( SetFeatureConfig db cfg, - GetConfigForTeamConstraints db cfg r, - SetConfigForTeamConstraints db cfg r, - FeaturePersistentConstraint db cfg, - ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'TeamNotFound) r, - Member (Error TeamFeatureError) r, - Member TeamStore r, - Member (TeamFeatureStore db) r, - Member (P.Logger (Log.Msg -> Log.Msg)) r, - Member GundeckAccess r - ) + forall cfg r. + ( SetFeatureConfig cfg, + GetConfigForTeamConstraints cfg r, + SetConfigForTeamConstraints cfg r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'TeamNotFound) r, + Member (Error TeamFeatureError) r, + Member TeamStore r, + Member TeamFeatureStore r, + Member (P.Logger (Log.Msg -> Log.Msg)) r, + Member GundeckAccess r ) => TeamId -> WithStatusNoLock cfg -> Sem r (WithStatus cfg) -setFeatureStatusInternal = setFeatureStatus @db @cfg DontDoAuth +setFeatureStatusInternal = setFeatureStatus @cfg DontDoAuth updateLockStatus :: - forall db cfg r. - ( FeaturePersistentConstraint db cfg, - Member (TeamFeatureStore db) r, + forall cfg r. + ( IsFeatureConfig cfg, + Member TeamFeatureStore r, Member TeamStore r, Member (ErrorS 'TeamNotFound) r ) => @@ -343,242 +165,26 @@ updateLockStatus :: Sem r LockStatusResponse updateLockStatus tid lockStatus = do assertTeamExists tid - TeamFeatures.setFeatureLockStatus @db (Proxy @cfg) tid lockStatus + TeamFeatures.setFeatureLockStatus (featureSingleton @cfg) tid lockStatus pure $ LockStatusResponse lockStatus --- | For individual users to get feature config for their account (personal or team). --- This looks supposedly redundant to the implementations of `getConfigForUser` but it's not. --- Here we explicitly return the team setting if the user is a team member. --- In `getConfigForUser` this is mostly also the case. But there are exceptions, e.g. `ConferenceCallingConfig` -getFeatureStatusForUser :: - forall (db :: Type) cfg r. - ( ( Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r - ), - GetConfigForTeamConstraints db cfg r, - GetConfigForUserConstraints db cfg r, - GetFeatureConfig db cfg - ) => - UserId -> - Sem r (WithStatus cfg) -getFeatureStatusForUser zusr = do - mbTeam <- getOneUserTeam zusr - case mbTeam of - Nothing -> - getConfigForUser @db @cfg zusr - Just tid -> do - zusrMembership <- getTeamMember tid zusr - void $ maybe (throwS @'NotATeamMember) pure zusrMembership - assertTeamExists tid - getConfigForTeam @db @cfg tid - -getAllFeatureConfigsForUser :: - forall db r. - ( Member BrigAccess r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'TeamNotFound) r, - Member (Input Opts) r, - Member LegalHoldStore r, - Member (TeamFeatureStore db) r, - Member TeamStore r - ) => - FeaturePersistentAllFeatures db => - UserId -> - Sem r AllFeatureConfigs -getAllFeatureConfigsForUser zusr = do - mbTeam <- getOneUserTeam zusr - when (isJust mbTeam) $ do - zusrMembership <- maybe (pure Nothing) (`getTeamMember` zusr) mbTeam - maybe (throwS @'NotATeamMember) (const $ pure ()) zusrMembership - case mbTeam of - Just tid -> - getAllFeatureConfigsTeam @db tid - Nothing -> - getAllFeatureConfigsUser @db zusr - -getAllFeatureConfigsForTeam :: - forall db r. - ( Member (ErrorS 'NotATeamMember) r, - Member (Input Opts) r, - Member LegalHoldStore r, - Member (TeamFeatureStore db) r, - Member TeamStore r - ) => - FeaturePersistentAllFeatures db => - Local UserId -> - TeamId -> - Sem r AllFeatureConfigs -getAllFeatureConfigsForTeam luid tid = do - zusrMembership <- getTeamMember tid (tUnqualified luid) - maybe (throwS @'NotATeamMember) (const $ pure ()) zusrMembership - getAllFeatureConfigsTeam @db tid - -getAllFeatureConfigsForServer :: - forall r. - Member (Input Opts) r => - Sem r AllFeatureConfigs -getAllFeatureConfigsForServer = - AllFeatureConfigs - <$> getConfigForServer @LegalholdConfig - <*> getConfigForServer @SSOConfig - <*> getConfigForServer @SearchVisibilityAvailableConfig - <*> getConfigForServer @SearchVisibilityInboundConfig - <*> getConfigForServer @ValidateSAMLEmailsConfig - <*> getConfigForServer @DigitalSignaturesConfig - <*> getConfigForServer @AppLockConfig - <*> getConfigForServer @FileSharingConfig - <*> getConfigForServer @ClassifiedDomainsConfig - <*> getConfigForServer @ConferenceCallingConfig - <*> getConfigForServer @SelfDeletingMessagesConfig - <*> getConfigForServer @GuestLinksConfig - <*> getConfigForServer @SndFactorPasswordChallengeConfig - <*> getConfigForServer @MLSConfig - <*> getConfigForServer @ExposeInvitationURLsToTeamAdminConfig - <*> getConfigForServer @OutlookCalIntegrationConfig - <*> getConfigForServer @MlsE2EIdConfig - -getAllFeatureConfigsUser :: - forall db r. - ( Member BrigAccess r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member (ErrorS OperationDenied) r, - Member (Input Opts) r, - Member LegalHoldStore r, - Member (TeamFeatureStore db) r, - Member TeamStore r - ) => - FeaturePersistentAllFeatures db => - UserId -> - Sem r AllFeatureConfigs -getAllFeatureConfigsUser uid = - AllFeatureConfigs - <$> getConfigForUser @db @LegalholdConfig uid - <*> getConfigForUser @db @SSOConfig uid - <*> getConfigForUser @db @SearchVisibilityAvailableConfig uid - <*> getConfigForUser @db @SearchVisibilityInboundConfig uid - <*> getConfigForUser @db @ValidateSAMLEmailsConfig uid - <*> getConfigForUser @db @DigitalSignaturesConfig uid - <*> getConfigForUser @db @AppLockConfig uid - <*> getConfigForUser @db @FileSharingConfig uid - <*> getConfigForUser @db @ClassifiedDomainsConfig uid - <*> getConfigForUser @db @ConferenceCallingConfig uid - <*> getConfigForUser @db @SelfDeletingMessagesConfig uid - <*> getConfigForUser @db @GuestLinksConfig uid - <*> getConfigForUser @db @SndFactorPasswordChallengeConfig uid - <*> getConfigForUser @db @MLSConfig uid - <*> getConfigForUser @db @ExposeInvitationURLsToTeamAdminConfig uid - <*> getConfigForUser @db @OutlookCalIntegrationConfig uid - <*> getConfigForUser @db @MlsE2EIdConfig uid - -getAllFeatureConfigsTeam :: - forall db r. - ( Member (Input Opts) r, - Member LegalHoldStore r, - Member (TeamFeatureStore db) r, - Member TeamStore r - ) => - FeaturePersistentAllFeatures db => - TeamId -> - Sem r AllFeatureConfigs -getAllFeatureConfigsTeam tid = - AllFeatureConfigs - <$> getConfigForTeam @db @LegalholdConfig tid - <*> getConfigForTeam @db @SSOConfig tid - <*> getConfigForTeam @db @SearchVisibilityAvailableConfig tid - <*> getConfigForTeam @db @SearchVisibilityInboundConfig tid - <*> getConfigForTeam @db @ValidateSAMLEmailsConfig tid - <*> getConfigForTeam @db @DigitalSignaturesConfig tid - <*> getConfigForTeam @db @AppLockConfig tid - <*> getConfigForTeam @db @FileSharingConfig tid - <*> getConfigForTeam @db @ClassifiedDomainsConfig tid - <*> getConfigForTeam @db @ConferenceCallingConfig tid - <*> getConfigForTeam @db @SelfDeletingMessagesConfig tid - <*> getConfigForTeam @db @GuestLinksConfig tid - <*> getConfigForTeam @db @SndFactorPasswordChallengeConfig tid - <*> getConfigForTeam @db @MLSConfig tid - <*> getConfigForTeam @db @ExposeInvitationURLsToTeamAdminConfig tid - <*> getConfigForTeam @db @OutlookCalIntegrationConfig tid - <*> getConfigForTeam @db @MlsE2EIdConfig tid - --- | Note: this is an internal function which doesn't cover all features, e.g. LegalholdConfig -genericGetConfigForTeam :: - forall db cfg r. - GetFeatureConfig db cfg => - FeaturePersistentConstraint db cfg => - Member (TeamFeatureStore db) r => - Member (Input Opts) r => - TeamId -> - Sem r (WithStatus cfg) -genericGetConfigForTeam tid = do - computeFeatureConfigForTeamUser - <$> TeamFeatures.getFeatureConfig @db (Proxy @cfg) tid - <*> TeamFeatures.getFeatureLockStatus @db (Proxy @cfg) tid - <*> getConfigForServer @db - --- Note: this function assumes the feature cannot be locked -genericGetConfigForMultiTeam :: - forall db cfg r. - GetFeatureConfig db cfg => - FeaturePersistentConstraint db cfg => - Member (TeamFeatureStore db) r => - Member (Input Opts) r => - [TeamId] -> - Sem r [(TeamId, WithStatus cfg)] -genericGetConfigForMultiTeam tids = do - def <- getConfigForServer @db - (\(tid, mwsnl) -> (tid, computeFeatureConfigForTeamUser mwsnl (Just LockStatusUnlocked) def)) - <$$> TeamFeatures.getFeatureConfigMulti @db (Proxy @cfg) tids - --- | Note: this is an internal function which doesn't cover all features, e.g. conference calling -genericGetConfigForUser :: - forall db cfg r. - FeaturePersistentConstraint db cfg => - ( ( Member (Input Opts) r, - Member (TeamFeatureStore db) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r - ), - GetFeatureConfig db cfg - ) => - UserId -> - Sem r (WithStatus cfg) -genericGetConfigForUser uid = do - mbTeam <- getOneUserTeam uid - case mbTeam of - Nothing -> do - getConfigForServer @db - Just tid -> do - zusrMembership <- getTeamMember tid uid - maybe (throwS @'NotATeamMember) (const $ pure ()) zusrMembership - assertTeamExists tid - genericGetConfigForTeam @db tid - persistAndPushEvent :: - forall (db :: Type) cfg r. - ( IsFeatureConfig cfg, - KnownSymbol (FeatureSymbol cfg), + forall cfg r. + ( KnownSymbol (FeatureSymbol cfg), ToSchema cfg, - GetFeatureConfig db cfg, - FeaturePersistentConstraint db cfg, - GetConfigForTeamConstraints db cfg r, - ( Member (TeamFeatureStore db) r, - Member (P.Logger (Log.Msg -> Log.Msg)) r, - Member GundeckAccess r, - Member TeamStore r - ) + GetFeatureConfig cfg, + GetConfigForTeamConstraints cfg r, + Member TeamFeatureStore r, + Member (P.Logger (Log.Msg -> Log.Msg)) r, + Member GundeckAccess r, + Member TeamStore r ) => TeamId -> WithStatusNoLock cfg -> Sem r (WithStatus cfg) persistAndPushEvent tid wsnl = do - setFeatureConfig @db (Proxy @cfg) tid wsnl - fs <- getConfigForTeam @db @cfg tid + setFeatureConfig (featureSingleton @cfg) tid wsnl + fs <- getConfigForTeam @cfg tid pushFeatureConfigEvent tid (Event.mkUpdateEvent fs) pure fs @@ -613,121 +219,103 @@ guardLockStatus = \case LockStatusLocked -> throw FeatureLocked ------------------------------------------------------------------------------- --- GetFeatureConfig and SetFeatureConfig instances +-- SetFeatureConfig instances -instance GetFeatureConfig db SSOConfig where - getConfigForServer = do - status <- - inputs (view (optSettings . setFeatureFlags . flagSSO)) <&> \case - FeatureSSOEnabledByDefault -> FeatureStatusEnabled - FeatureSSODisabledByDefault -> FeatureStatusDisabled - pure $ setStatus status defFeatureStatus +-- | Don't export methods of this typeclass +class GetFeatureConfig cfg => SetFeatureConfig cfg where + type SetConfigForTeamConstraints cfg (r :: EffectRow) :: Constraint + type SetConfigForTeamConstraints cfg (r :: EffectRow) = () - getConfigForUser = genericGetConfigForUser @db + -- | This method should generate the side-effects of changing the feature and + -- also (depending on the feature) persist the new setting to the database and + -- push a event to clients (see 'persistAndPushEvent'). + setConfigForTeam :: + ( SetConfigForTeamConstraints cfg r, + GetConfigForTeamConstraints cfg r, + ( Member TeamFeatureStore r, + Member (P.Logger (Log.Msg -> Log.Msg)) r, + Member GundeckAccess r, + Member TeamStore r + ) + ) => + TeamId -> + WithStatusNoLock cfg -> + Sem r (WithStatus cfg) + default setConfigForTeam :: + ( GetConfigForTeamConstraints cfg r, + KnownSymbol (FeatureSymbol cfg), + ToSchema cfg, + Members + '[ TeamFeatureStore, + P.Logger (Log.Msg -> Log.Msg), + GundeckAccess, + TeamStore + ] + r + ) => + TeamId -> + WithStatusNoLock cfg -> + Sem r (WithStatus cfg) + setConfigForTeam tid wsnl = persistAndPushEvent tid wsnl -instance SetFeatureConfig db SSOConfig where - type SetConfigForTeamConstraints db SSOConfig (r :: EffectRow) = (Member (Error TeamFeatureError) r) +instance SetFeatureConfig SSOConfig where + type SetConfigForTeamConstraints SSOConfig (r :: EffectRow) = (Member (Error TeamFeatureError) r) setConfigForTeam tid wsnl = do case wssStatus wsnl of FeatureStatusEnabled -> pure () FeatureStatusDisabled -> throw DisableSsoNotImplemented - persistAndPushEvent @db tid wsnl + persistAndPushEvent tid wsnl -instance GetFeatureConfig db SearchVisibilityAvailableConfig where - getConfigForServer = do - status <- - inputs (view (optSettings . setFeatureFlags . flagTeamSearchVisibility)) <&> \case - FeatureTeamSearchVisibilityAvailableByDefault -> FeatureStatusEnabled - FeatureTeamSearchVisibilityUnavailableByDefault -> FeatureStatusDisabled - pure $ setStatus status defFeatureStatus - -instance SetFeatureConfig db SearchVisibilityAvailableConfig where - type SetConfigForTeamConstraints db SearchVisibilityAvailableConfig (r :: EffectRow) = (Member SearchVisibilityStore r) +instance SetFeatureConfig SearchVisibilityAvailableConfig where + type SetConfigForTeamConstraints SearchVisibilityAvailableConfig (r :: EffectRow) = (Member SearchVisibilityStore r) setConfigForTeam tid wsnl = do case wssStatus wsnl of FeatureStatusEnabled -> pure () FeatureStatusDisabled -> SearchVisibilityData.resetSearchVisibility tid - persistAndPushEvent @db tid wsnl - -instance GetFeatureConfig db ValidateSAMLEmailsConfig where - getConfigForServer = - inputs (view (optSettings . setFeatureFlags . flagsTeamFeatureValidateSAMLEmailsStatus . unDefaults . unImplicitLockStatus)) - -instance SetFeatureConfig db ValidateSAMLEmailsConfig - -instance GetFeatureConfig db DigitalSignaturesConfig - -instance SetFeatureConfig db DigitalSignaturesConfig + persistAndPushEvent tid wsnl -instance GetFeatureConfig db LegalholdConfig where - type - GetConfigForTeamConstraints db LegalholdConfig (r :: EffectRow) = - ( FeaturePersistentConstraint db LegalholdConfig, - ( Member (Input Opts) r, - Member (TeamFeatureStore db) r, - Member LegalHoldStore r, - Member TeamStore r - ) - ) - type - GetConfigForUserConstraints db LegalholdConfig (r :: EffectRow) = - ( FeaturePersistentConstraint db LegalholdConfig, - ( Member (Input Opts) r, - Member (TeamFeatureStore db) r, - Member LegalHoldStore r, - Member TeamStore r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r - ) - ) +instance SetFeatureConfig ValidateSAMLEmailsConfig - getConfigForTeam tid = do - status <- - isLegalHoldEnabledForTeam @db tid <&> \case - True -> FeatureStatusEnabled - False -> FeatureStatusDisabled - pure $ setStatus status defFeatureStatus +instance SetFeatureConfig DigitalSignaturesConfig -instance SetFeatureConfig db LegalholdConfig where +instance SetFeatureConfig LegalholdConfig where type - SetConfigForTeamConstraints db LegalholdConfig (r :: EffectRow) = + SetConfigForTeamConstraints LegalholdConfig (r :: EffectRow) = ( Bounded (PagingBounds InternalPaging TeamMember), - ( Member BotAccess r, - Member BrigAccess r, - Member CodeStore r, - Member ConversationStore r, - Member (Error AuthenticationError) r, - Member (Error InternalError) r, - Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, - Member (ErrorS 'CannotEnableLegalHoldServiceLargeTeam) r, - Member (ErrorS 'NotATeamMember) r, - Member (Error TeamFeatureError) r, - Member (ErrorS 'LegalHoldNotEnabled) r, - Member (ErrorS 'LegalHoldDisableUnimplemented) r, - Member (ErrorS 'LegalHoldServiceNotRegistered) r, - Member (ErrorS 'UserLegalHoldIllegalOperation) r, - Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, - Member ExternalAccess r, - Member FederatorAccess r, - Member FireAndForget r, - Member GundeckAccess r, - Member (Input (Local ())) r, - Member (Input Env) r, - Member (Input UTCTime) r, - Member LegalHoldStore r, - Member (ListItems LegacyPaging ConvId) r, - Member MemberStore r, - Member ProposalStore r, - Member SubConversationStore r, - Member (TeamFeatureStore db) r, - Member TeamStore r, - Member (TeamMemberStore InternalPaging) r, - Member P.TinyLog r - ), - FeaturePersistentConstraint db LegalholdConfig + Member BotAccess r, + Member BrigAccess r, + Member CodeStore r, + Member ConversationStore r, + Member (Error AuthenticationError) r, + Member (Error FederationError) r, + Member (Error InternalError) r, + Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, + Member (ErrorS 'CannotEnableLegalHoldServiceLargeTeam) r, + Member (ErrorS 'NotATeamMember) r, + Member (Error TeamFeatureError) r, + Member (ErrorS 'LegalHoldNotEnabled) r, + Member (ErrorS 'LegalHoldDisableUnimplemented) r, + Member (ErrorS 'LegalHoldServiceNotRegistered) r, + Member (ErrorS 'UserLegalHoldIllegalOperation) r, + Member (ErrorS 'LegalHoldCouldNotBlockConnections) r, + Member ExternalAccess r, + Member FederatorAccess r, + Member FireAndForget r, + Member GundeckAccess r, + Member (Input (Local ())) r, + Member (Input Env) r, + Member (Input UTCTime) r, + Member LegalHoldStore r, + Member (ListItems LegacyPaging ConvId) r, + Member MemberStore r, + Member ProposalStore r, + Member SubConversationStore r, + Member TeamFeatureStore r, + Member TeamStore r, + Member (TeamMemberStore InternalPaging) r, + Member P.TinyLog r ) -- we're good to update the status now. @@ -747,164 +335,36 @@ instance SetFeatureConfig db LegalholdConfig where case wssStatus wsnl of FeatureStatusDisabled -> LegalHold.removeSettings' @InternalPaging tid FeatureStatusEnabled -> ensureNotTooLargeToActivateLegalHold tid - persistAndPushEvent @db tid wsnl - -instance GetFeatureConfig db FileSharingConfig where - getConfigForServer = - input <&> view (optSettings . setFeatureFlags . flagFileSharing . unDefaults) + persistAndPushEvent tid wsnl -instance SetFeatureConfig db FileSharingConfig +instance SetFeatureConfig FileSharingConfig -instance GetFeatureConfig db AppLockConfig where - getConfigForServer = - input <&> view (optSettings . setFeatureFlags . flagAppLockDefaults . unDefaults . unImplicitLockStatus) - -instance SetFeatureConfig db AppLockConfig where - type SetConfigForTeamConstraints db AppLockConfig r = Member (Error TeamFeatureError) r +instance SetFeatureConfig AppLockConfig where + type SetConfigForTeamConstraints AppLockConfig r = Member (Error TeamFeatureError) r setConfigForTeam tid wsnl = do when ((applockInactivityTimeoutSecs . wssConfig $ wsnl) < 30) $ throw AppLockInactivityTimeoutTooLow - persistAndPushEvent @db tid wsnl - -instance GetFeatureConfig db ClassifiedDomainsConfig where - getConfigForServer = - input <&> view (optSettings . setFeatureFlags . flagClassifiedDomains . unImplicitLockStatus) + persistAndPushEvent tid wsnl -instance GetFeatureConfig db ConferenceCallingConfig where - type - GetConfigForUserConstraints db ConferenceCallingConfig r = - ( FeaturePersistentConstraint db ConferenceCallingConfig, - ( Member (Input Opts) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r, - Member (TeamFeatureStore db) r, - Member BrigAccess r - ) - ) - - getConfigForServer = - input <&> view (optSettings . setFeatureFlags . flagConferenceCalling . unDefaults . unImplicitLockStatus) +instance SetFeatureConfig ConferenceCallingConfig - getConfigForUser uid = do - wsnl <- getAccountConferenceCallingConfigClient uid - pure $ withLockStatus (wsLockStatus (defFeatureStatus @ConferenceCallingConfig)) wsnl +instance SetFeatureConfig SelfDeletingMessagesConfig -instance SetFeatureConfig db ConferenceCallingConfig +instance SetFeatureConfig GuestLinksConfig -instance GetFeatureConfig db SelfDeletingMessagesConfig where - getConfigForServer = - input <&> view (optSettings . setFeatureFlags . flagSelfDeletingMessages . unDefaults) +instance SetFeatureConfig SndFactorPasswordChallengeConfig -instance SetFeatureConfig db SelfDeletingMessagesConfig - -instance SetFeatureConfig db GuestLinksConfig +instance SetFeatureConfig SearchVisibilityInboundConfig where + type SetConfigForTeamConstraints SearchVisibilityInboundConfig (r :: EffectRow) = (Member BrigAccess r) + setConfigForTeam tid wsnl = do + updateSearchVisibilityInbound $ toTeamStatus tid wsnl + persistAndPushEvent tid wsnl -instance GetFeatureConfig db GuestLinksConfig where - getConfigForServer = - input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults) +instance SetFeatureConfig MLSConfig -instance SetFeatureConfig db SndFactorPasswordChallengeConfig +instance SetFeatureConfig ExposeInvitationURLsToTeamAdminConfig -instance GetFeatureConfig db SndFactorPasswordChallengeConfig where - getConfigForServer = - input <&> view (optSettings . setFeatureFlags . flagTeamFeatureSndFactorPasswordChallengeStatus . unDefaults) +instance SetFeatureConfig OutlookCalIntegrationConfig -instance SetFeatureConfig db SearchVisibilityInboundConfig where - type SetConfigForTeamConstraints db SearchVisibilityInboundConfig (r :: EffectRow) = (Member BrigAccess r) - setConfigForTeam tid wsnl = do - updateSearchVisibilityInbound $ toTeamStatus tid wsnl - persistAndPushEvent @db tid wsnl - -instance GetFeatureConfig db SearchVisibilityInboundConfig where - getConfigForServer = - input <&> view (optSettings . setFeatureFlags . flagTeamFeatureSearchVisibilityInbound . unDefaults . unImplicitLockStatus) - -instance GetFeatureConfig db MLSConfig where - getConfigForServer = - input <&> view (optSettings . setFeatureFlags . flagMLS . unDefaults . unImplicitLockStatus) - -instance SetFeatureConfig db MLSConfig - -instance GetFeatureConfig db ExposeInvitationURLsToTeamAdminConfig where - getConfigForTeam tid = do - allowList <- input <&> view (optSettings . setExposeInvitationURLsTeamAllowlist . to (fromMaybe [])) - mbOldStatus <- TeamFeatures.getFeatureConfig @db (Proxy @ExposeInvitationURLsToTeamAdminConfig) tid <&> fmap wssStatus - let teamAllowed = tid `elem` allowList - pure $ computeConfigForTeam teamAllowed (fromMaybe FeatureStatusDisabled mbOldStatus) - where - computeConfigForTeam :: Bool -> FeatureStatus -> WithStatus ExposeInvitationURLsToTeamAdminConfig - computeConfigForTeam teamAllowed teamDbStatus = - if teamAllowed - then makeConfig LockStatusUnlocked teamDbStatus - else makeConfig LockStatusLocked FeatureStatusDisabled - - makeConfig :: LockStatus -> FeatureStatus -> WithStatus ExposeInvitationURLsToTeamAdminConfig - makeConfig lockStatus status = - withStatus - status - lockStatus - ExposeInvitationURLsToTeamAdminConfig - FeatureTTLUnlimited - -instance SetFeatureConfig db ExposeInvitationURLsToTeamAdminConfig - -instance SetFeatureConfig db OutlookCalIntegrationConfig - -instance GetFeatureConfig db OutlookCalIntegrationConfig where - getConfigForServer = - input <&> view (optSettings . setFeatureFlags . flagOutlookCalIntegration . unDefaults) - -instance SetFeatureConfig db MlsE2EIdConfig - -instance GetFeatureConfig db MlsE2EIdConfig where - getConfigForServer = - input <&> view (optSettings . setFeatureFlags . flagMlsE2EId . unDefaults) - --- -- | 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 db r a. - ( Member (Input Opts) r, - Member (TeamFeatureStore db) r, - Member (ErrorS 'AccessDenied) r, - Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r, - Member ConversationStore r, - FeaturePersistentConstraint db SndFactorPasswordChallengeConfig - ) => - UserId -> - ConvId -> - Sem r a -> - Sem r a -guardSecondFactorDisabled uid cid action = do - mbCnvData <- ConversationStore.getConversationMetadata cid - tf <- case mbCnvData >>= cnvmTeam of - Nothing -> getConfigForUser @db @SndFactorPasswordChallengeConfig uid - Just tid -> do - teamExists <- isJust <$> getTeam tid - if teamExists - then getConfigForTeam @db @SndFactorPasswordChallengeConfig tid - else getConfigForUser @db @SndFactorPasswordChallengeConfig uid - case wsStatus tf of - FeatureStatusDisabled -> action - FeatureStatusEnabled -> throwS @'AccessDenied - -featureEnabledForTeam :: - forall db cfg r. - ( GetFeatureConfig db cfg, - GetConfigForTeamConstraints db cfg r, - ( Member (ErrorS OperationDenied) r, - Member (ErrorS 'NotATeamMember) r, - Member (ErrorS 'TeamNotFound) r, - Member TeamStore r - ) - ) => - TeamId -> - Sem r Bool -featureEnabledForTeam tid = (==) FeatureStatusEnabled . wsStatus <$> getFeatureStatus @db @cfg DontDoAuth tid +instance SetFeatureConfig MlsE2EIdConfig diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs new file mode 100644 index 0000000000..dd18af5e0f --- /dev/null +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -0,0 +1,529 @@ +-- 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 + ( getFeatureStatus, + getFeatureStatusMulti, + getFeatureStatusForUser, + getAllFeatureConfigsForServer, + getAllFeatureConfigsForTeam, + getAllFeatureConfigsForUser, + GetFeatureConfig (..), + guardSecondFactorDisabled, + DoAuth (..), + featureEnabledForTeam, + toTeamStatus, + ) +where + +import Control.Lens +import Data.Bifunctor (second) +import Data.Id +import Data.Kind +import Data.Qualified (Local, tUnqualified) +import Galley.API.LegalHold.Team (isLegalHoldEnabledForTeam) +import Galley.API.Util +import Galley.Effects +import Galley.Effects.BrigAccess (getAccountConferenceCallingConfigClient) +import Galley.Effects.ConversationStore as ConversationStore +import qualified Galley.Effects.TeamFeatureStore as TeamFeatures +import Galley.Effects.TeamStore (getOneUserTeam, getTeam, getTeamMember) +import Galley.Options +import Galley.Types.Teams +import Imports +import Polysemy +import Polysemy.Input +import Wire.API.Conversation (cnvmTeam) +import Wire.API.Error (ErrorS, throwS) +import Wire.API.Error.Galley +import qualified Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti as Multi +import Wire.API.Team.Feature + +data DoAuth = DoAuth UserId | DontDoAuth + +-- | Don't export methods of this typeclass +class IsFeatureConfig cfg => GetFeatureConfig cfg where + type GetConfigForTeamConstraints cfg (r :: EffectRow) :: Constraint + type + GetConfigForTeamConstraints cfg (r :: EffectRow) = + ( Member (Input Opts) r, + Member TeamFeatureStore r + ) + + type GetConfigForUserConstraints cfg (r :: EffectRow) :: Constraint + type + GetConfigForUserConstraints cfg (r :: EffectRow) = + ( Member (Input Opts) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamStore r, + Member TeamFeatureStore r + ) + + getConfigForServer :: + Member (Input Opts) r => + Sem r (WithStatus cfg) + -- only override if there is additional business logic for getting the feature config + -- and/or if the feature flag is configured for the backend in 'FeatureFlags' for galley in 'Galley.Types.Teams' + -- otherwise this will return the default config from wire-api + default getConfigForServer :: Sem r (WithStatus cfg) + getConfigForServer = pure defFeatureStatus + + getConfigForTeam :: + GetConfigForTeamConstraints cfg r => + TeamId -> + Sem r (WithStatus cfg) + default getConfigForTeam :: + ( Member (Input Opts) r, + Member TeamFeatureStore r + ) => + TeamId -> + Sem r (WithStatus cfg) + getConfigForTeam = genericGetConfigForTeam + + getConfigForUser :: + GetConfigForUserConstraints cfg r => + UserId -> + Sem r (WithStatus cfg) + default getConfigForUser :: + ( Member (Input Opts) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamStore r, + Member TeamFeatureStore r + ) => + UserId -> + Sem r (WithStatus cfg) + getConfigForUser = genericGetConfigForUser + +getFeatureStatus :: + forall cfg r. + ( GetFeatureConfig cfg, + GetConfigForTeamConstraints cfg r, + ( Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamStore r + ) + ) => + DoAuth -> + TeamId -> + Sem r (WithStatus cfg) +getFeatureStatus doauth tid = do + case doauth of + DoAuth uid -> + getTeamMember tid uid >>= maybe (throwS @'NotATeamMember) (const $ pure ()) + DontDoAuth -> + assertTeamExists tid + getConfigForTeam @cfg tid + +getFeatureStatusMulti :: + forall cfg r. + ( GetFeatureConfig cfg, + Member (Input Opts) r, + Member TeamFeatureStore r + ) => + Multi.TeamFeatureNoConfigMultiRequest -> + Sem r (Multi.TeamFeatureNoConfigMultiResponse cfg) +getFeatureStatusMulti (Multi.TeamFeatureNoConfigMultiRequest tids) = do + cfgs <- genericGetConfigForMultiTeam @cfg tids + let xs = uncurry toTeamStatus . second forgetLock <$> cfgs + pure $ Multi.TeamFeatureNoConfigMultiResponse xs + +toTeamStatus :: TeamId -> WithStatusNoLock cfg -> Multi.TeamStatus cfg +toTeamStatus tid ws = Multi.TeamStatus tid (wssStatus ws) + +-- | For individual users to get feature config for their account (personal or team). +-- This looks supposedly redundant to the implementations of `getConfigForUser` but it's not. +-- Here we explicitly return the team setting if the user is a team member. +-- In `getConfigForUser` this is mostly also the case. But there are exceptions, e.g. `ConferenceCallingConfig` +getFeatureStatusForUser :: + forall cfg r. + ( Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamStore r, + GetConfigForTeamConstraints cfg r, + GetConfigForUserConstraints cfg r, + GetFeatureConfig cfg + ) => + UserId -> + Sem r (WithStatus cfg) +getFeatureStatusForUser zusr = do + mbTeam <- getOneUserTeam zusr + case mbTeam of + Nothing -> + getConfigForUser @cfg zusr + Just tid -> do + zusrMembership <- getTeamMember tid zusr + void $ maybe (throwS @'NotATeamMember) pure zusrMembership + assertTeamExists tid + getConfigForTeam @cfg tid + +getAllFeatureConfigsForUser :: + forall r. + ( Member BrigAccess r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'TeamNotFound) r, + Member (Input Opts) r, + Member LegalHoldStore r, + Member TeamFeatureStore r, + Member TeamStore r + ) => + UserId -> + Sem r AllFeatureConfigs +getAllFeatureConfigsForUser zusr = do + mbTeam <- getOneUserTeam zusr + when (isJust mbTeam) $ do + zusrMembership <- maybe (pure Nothing) (`getTeamMember` zusr) mbTeam + maybe (throwS @'NotATeamMember) (const $ pure ()) zusrMembership + case mbTeam of + Just tid -> + getAllFeatureConfigsTeam tid + Nothing -> + getAllFeatureConfigsUser zusr + +getAllFeatureConfigsForTeam :: + forall r. + ( Member (ErrorS 'NotATeamMember) r, + Member (Input Opts) r, + Member LegalHoldStore r, + Member TeamFeatureStore r, + Member TeamStore r + ) => + Local UserId -> + TeamId -> + Sem r AllFeatureConfigs +getAllFeatureConfigsForTeam luid tid = do + zusrMembership <- getTeamMember tid (tUnqualified luid) + maybe (throwS @'NotATeamMember) (const $ pure ()) zusrMembership + getAllFeatureConfigsTeam tid + +getAllFeatureConfigsForServer :: + forall r. + Member (Input Opts) r => + Sem r AllFeatureConfigs +getAllFeatureConfigsForServer = + AllFeatureConfigs + <$> getConfigForServer @LegalholdConfig + <*> getConfigForServer @SSOConfig + <*> getConfigForServer @SearchVisibilityAvailableConfig + <*> getConfigForServer @SearchVisibilityInboundConfig + <*> getConfigForServer @ValidateSAMLEmailsConfig + <*> getConfigForServer @DigitalSignaturesConfig + <*> getConfigForServer @AppLockConfig + <*> getConfigForServer @FileSharingConfig + <*> getConfigForServer @ClassifiedDomainsConfig + <*> getConfigForServer @ConferenceCallingConfig + <*> getConfigForServer @SelfDeletingMessagesConfig + <*> getConfigForServer @GuestLinksConfig + <*> getConfigForServer @SndFactorPasswordChallengeConfig + <*> getConfigForServer @MLSConfig + <*> getConfigForServer @ExposeInvitationURLsToTeamAdminConfig + <*> getConfigForServer @OutlookCalIntegrationConfig + <*> getConfigForServer @MlsE2EIdConfig + +getAllFeatureConfigsUser :: + forall r. + ( Member BrigAccess r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'TeamNotFound) r, + Member (ErrorS OperationDenied) r, + Member (Input Opts) r, + Member LegalHoldStore r, + Member TeamFeatureStore r, + Member TeamStore r + ) => + UserId -> + Sem r AllFeatureConfigs +getAllFeatureConfigsUser uid = + AllFeatureConfigs + <$> getConfigForUser @LegalholdConfig uid + <*> getConfigForUser @SSOConfig uid + <*> getConfigForUser @SearchVisibilityAvailableConfig uid + <*> getConfigForUser @SearchVisibilityInboundConfig uid + <*> getConfigForUser @ValidateSAMLEmailsConfig uid + <*> getConfigForUser @DigitalSignaturesConfig uid + <*> getConfigForUser @AppLockConfig uid + <*> getConfigForUser @FileSharingConfig uid + <*> getConfigForUser @ClassifiedDomainsConfig uid + <*> getConfigForUser @ConferenceCallingConfig uid + <*> getConfigForUser @SelfDeletingMessagesConfig uid + <*> getConfigForUser @GuestLinksConfig uid + <*> getConfigForUser @SndFactorPasswordChallengeConfig uid + <*> getConfigForUser @MLSConfig uid + <*> getConfigForUser @ExposeInvitationURLsToTeamAdminConfig uid + <*> getConfigForUser @OutlookCalIntegrationConfig uid + <*> getConfigForUser @MlsE2EIdConfig uid + +getAllFeatureConfigsTeam :: + forall r. + ( Member (Input Opts) r, + Member LegalHoldStore r, + Member TeamFeatureStore r, + Member TeamStore r + ) => + TeamId -> + Sem r AllFeatureConfigs +getAllFeatureConfigsTeam tid = + AllFeatureConfigs + <$> getConfigForTeam @LegalholdConfig tid + <*> getConfigForTeam @SSOConfig tid + <*> getConfigForTeam @SearchVisibilityAvailableConfig tid + <*> getConfigForTeam @SearchVisibilityInboundConfig tid + <*> getConfigForTeam @ValidateSAMLEmailsConfig tid + <*> getConfigForTeam @DigitalSignaturesConfig tid + <*> getConfigForTeam @AppLockConfig tid + <*> getConfigForTeam @FileSharingConfig tid + <*> getConfigForTeam @ClassifiedDomainsConfig tid + <*> getConfigForTeam @ConferenceCallingConfig tid + <*> getConfigForTeam @SelfDeletingMessagesConfig tid + <*> getConfigForTeam @GuestLinksConfig tid + <*> getConfigForTeam @SndFactorPasswordChallengeConfig tid + <*> getConfigForTeam @MLSConfig tid + <*> getConfigForTeam @ExposeInvitationURLsToTeamAdminConfig tid + <*> getConfigForTeam @OutlookCalIntegrationConfig tid + <*> getConfigForTeam @MlsE2EIdConfig tid + +-- | Note: this is an internal function which doesn't cover all features, e.g. LegalholdConfig +genericGetConfigForTeam :: + forall cfg r. + GetFeatureConfig cfg => + Member TeamFeatureStore r => + Member (Input Opts) r => + TeamId -> + Sem r (WithStatus cfg) +genericGetConfigForTeam tid = do + computeFeatureConfigForTeamUser + <$> TeamFeatures.getFeatureConfig (featureSingleton @cfg) tid + <*> TeamFeatures.getFeatureLockStatus (featureSingleton @cfg) tid + <*> getConfigForServer + +-- Note: this function assumes the feature cannot be locked +genericGetConfigForMultiTeam :: + forall cfg r. + GetFeatureConfig cfg => + Member TeamFeatureStore r => + Member (Input Opts) r => + [TeamId] -> + Sem r [(TeamId, WithStatus cfg)] +genericGetConfigForMultiTeam tids = do + def <- getConfigForServer + (\(tid, mwsnl) -> (tid, computeFeatureConfigForTeamUser mwsnl (Just LockStatusUnlocked) def)) + <$$> TeamFeatures.getFeatureConfigMulti (featureSingleton @cfg) tids + +-- | Note: this is an internal function which doesn't cover all features, e.g. conference calling +genericGetConfigForUser :: + forall cfg r. + ( Member (Input Opts) r, + Member TeamFeatureStore r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamStore r, + GetFeatureConfig cfg + ) => + UserId -> + Sem r (WithStatus cfg) +genericGetConfigForUser uid = do + mbTeam <- getOneUserTeam uid + case mbTeam of + Nothing -> do + getConfigForServer + Just tid -> do + zusrMembership <- getTeamMember tid uid + maybe (throwS @'NotATeamMember) (const $ pure ()) zusrMembership + assertTeamExists tid + genericGetConfigForTeam tid + +------------------------------------------------------------------------------- +-- GetFeatureConfig instances + +instance GetFeatureConfig SSOConfig where + getConfigForServer = do + status <- + inputs (view (optSettings . setFeatureFlags . flagSSO)) <&> \case + FeatureSSOEnabledByDefault -> FeatureStatusEnabled + FeatureSSODisabledByDefault -> FeatureStatusDisabled + pure $ setStatus status defFeatureStatus + + getConfigForUser = genericGetConfigForUser + +instance GetFeatureConfig SearchVisibilityAvailableConfig where + getConfigForServer = do + status <- + inputs (view (optSettings . setFeatureFlags . flagTeamSearchVisibility)) <&> \case + FeatureTeamSearchVisibilityAvailableByDefault -> FeatureStatusEnabled + FeatureTeamSearchVisibilityUnavailableByDefault -> FeatureStatusDisabled + pure $ setStatus status defFeatureStatus + +instance GetFeatureConfig ValidateSAMLEmailsConfig where + getConfigForServer = + inputs (view (optSettings . setFeatureFlags . flagsTeamFeatureValidateSAMLEmailsStatus . unDefaults . unImplicitLockStatus)) + +instance GetFeatureConfig DigitalSignaturesConfig + +instance GetFeatureConfig LegalholdConfig where + type + GetConfigForTeamConstraints LegalholdConfig (r :: EffectRow) = + ( Member (Input Opts) r, + Member TeamFeatureStore r, + Member LegalHoldStore r, + Member TeamStore r + ) + type + GetConfigForUserConstraints LegalholdConfig (r :: EffectRow) = + ( Member (Input Opts) r, + Member TeamFeatureStore r, + Member LegalHoldStore r, + Member TeamStore r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'TeamNotFound) r + ) + + getConfigForTeam tid = do + status <- + isLegalHoldEnabledForTeam tid <&> \case + True -> FeatureStatusEnabled + False -> FeatureStatusDisabled + pure $ setStatus status defFeatureStatus + +instance GetFeatureConfig FileSharingConfig where + getConfigForServer = + input <&> view (optSettings . setFeatureFlags . flagFileSharing . unDefaults) + +instance GetFeatureConfig AppLockConfig where + getConfigForServer = + input <&> view (optSettings . setFeatureFlags . flagAppLockDefaults . unDefaults . unImplicitLockStatus) + +instance GetFeatureConfig ClassifiedDomainsConfig where + getConfigForServer = + input <&> view (optSettings . setFeatureFlags . flagClassifiedDomains . unImplicitLockStatus) + +instance GetFeatureConfig ConferenceCallingConfig where + type + GetConfigForUserConstraints ConferenceCallingConfig r = + ( Member (Input Opts) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamStore r, + Member TeamFeatureStore r, + Member BrigAccess r + ) + + getConfigForServer = + input <&> view (optSettings . setFeatureFlags . flagConferenceCalling . unDefaults . unImplicitLockStatus) + + getConfigForUser uid = do + wsnl <- getAccountConferenceCallingConfigClient uid + pure $ withLockStatus (wsLockStatus (defFeatureStatus @ConferenceCallingConfig)) wsnl + +instance GetFeatureConfig SelfDeletingMessagesConfig where + getConfigForServer = + input <&> view (optSettings . setFeatureFlags . flagSelfDeletingMessages . unDefaults) + +instance GetFeatureConfig GuestLinksConfig where + getConfigForServer = + input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults) + +instance GetFeatureConfig SndFactorPasswordChallengeConfig where + getConfigForServer = + input <&> view (optSettings . setFeatureFlags . flagTeamFeatureSndFactorPasswordChallengeStatus . unDefaults) + +instance GetFeatureConfig SearchVisibilityInboundConfig where + getConfigForServer = + input <&> view (optSettings . setFeatureFlags . flagTeamFeatureSearchVisibilityInbound . unDefaults . unImplicitLockStatus) + +instance GetFeatureConfig MLSConfig where + getConfigForServer = + input <&> view (optSettings . setFeatureFlags . flagMLS . unDefaults . unImplicitLockStatus) + +instance GetFeatureConfig ExposeInvitationURLsToTeamAdminConfig where + getConfigForTeam tid = do + allowList <- input <&> view (optSettings . setExposeInvitationURLsTeamAllowlist . to (fromMaybe [])) + mbOldStatus <- TeamFeatures.getFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig tid <&> fmap wssStatus + let teamAllowed = tid `elem` allowList + pure $ computeConfigForTeam teamAllowed (fromMaybe FeatureStatusDisabled mbOldStatus) + where + computeConfigForTeam :: Bool -> FeatureStatus -> WithStatus ExposeInvitationURLsToTeamAdminConfig + computeConfigForTeam teamAllowed teamDbStatus = + if teamAllowed + then makeConfig LockStatusUnlocked teamDbStatus + else makeConfig LockStatusLocked FeatureStatusDisabled + + makeConfig :: LockStatus -> FeatureStatus -> WithStatus ExposeInvitationURLsToTeamAdminConfig + makeConfig lockStatus status = + withStatus + status + lockStatus + ExposeInvitationURLsToTeamAdminConfig + FeatureTTLUnlimited + +instance GetFeatureConfig OutlookCalIntegrationConfig where + getConfigForServer = + input <&> view (optSettings . setFeatureFlags . flagOutlookCalIntegration . unDefaults) + +instance GetFeatureConfig MlsE2EIdConfig where + getConfigForServer = + input <&> view (optSettings . setFeatureFlags . flagMlsE2EId . unDefaults) + +-- -- | 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 a. + ( Member (Input Opts) r, + Member TeamFeatureStore r, + Member (ErrorS 'AccessDenied) r, + Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamStore r, + Member ConversationStore r + ) => + UserId -> + ConvId -> + Sem r a -> + Sem r a +guardSecondFactorDisabled uid cid action = do + mbCnvData <- ConversationStore.getConversationMetadata cid + tf <- case mbCnvData >>= cnvmTeam of + Nothing -> getConfigForUser @SndFactorPasswordChallengeConfig uid + Just tid -> do + teamExists <- isJust <$> getTeam tid + if teamExists + then getConfigForTeam @SndFactorPasswordChallengeConfig tid + else getConfigForUser @SndFactorPasswordChallengeConfig uid + case wsStatus tf of + FeatureStatusDisabled -> action + FeatureStatusEnabled -> throwS @'AccessDenied + +featureEnabledForTeam :: + forall cfg r. + ( GetFeatureConfig cfg, + GetConfigForTeamConstraints cfg r, + ( Member (ErrorS OperationDenied) r, + Member (ErrorS 'NotATeamMember) r, + Member (ErrorS 'TeamNotFound) r, + Member TeamStore r + ) + ) => + TeamId -> + Sem r Bool +featureEnabledForTeam tid = (==) FeatureStatusEnabled . wsStatus <$> getFeatureStatus @cfg DontDoAuth tid diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 0b7062d408..57869b8ff9 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -39,6 +39,7 @@ module Galley.API.Update updateConversationAccess, deleteLocalConversation, updateRemoteConversation, + updateLocalStateOfRemoteConv, updateConversationProtocolWithLocalUser, -- * Managing Members @@ -53,6 +54,7 @@ module Galley.API.Update removeMemberUnqualified, removeMemberFromLocalConv, removeMemberFromRemoteConv, + addLocalUsersToRemoteConv, -- * Talking postProteusMessage, @@ -74,9 +76,13 @@ where import Control.Error.Util (hush) import Control.Lens import Control.Monad.State +import Data.ByteString.Conversion import Data.Code +import Data.Domain import Data.Id import Data.Json.Util +import Data.List.Extra (nubOrd) +import Data.List.NonEmpty (NonEmpty (..)) import Data.List1 import qualified Data.Map.Strict as Map import Data.Qualified @@ -85,7 +91,6 @@ import Data.Singletons import Data.Time import Galley.API.Action import Galley.API.Error -import Galley.API.Federation (onConversationUpdated) import Galley.API.MLS.KeyPackage (nullKeyPackageRef) import Galley.API.Mapping import Galley.API.Message @@ -96,6 +101,7 @@ import qualified Galley.Data.Conversation as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) import Galley.Effects +import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.ClientStore as E import qualified Galley.Effects.CodeStore as E import qualified Galley.Effects.ConversationStore as E @@ -104,7 +110,6 @@ import qualified Galley.Effects.FederatorAccess as E import qualified Galley.Effects.GundeckAccess as E import qualified Galley.Effects.MemberStore as E import qualified Galley.Effects.ServiceStore as E -import Galley.Effects.TeamFeatureStore (FeaturePersistentConstraint) import Galley.Effects.WaiRoutes import Galley.Intra.Push import Galley.Options @@ -121,7 +126,10 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog +import qualified Polysemy.TinyLog as P import System.Logger (Msg) +import qualified System.Logger.Class as Log +import Wire.API.Connection (Relation (Accepted)) import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Action import Wire.API.Conversation.Code @@ -134,16 +142,17 @@ import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley +import qualified Wire.API.Federation.API.Galley as F import Wire.API.Federation.Error import Wire.API.MLS.CipherSuite import Wire.API.MLS.Group import Wire.API.Message import Wire.API.Password (mkSafePassword) import Wire.API.Provider.Service (ServiceRef) +import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Public.Galley.Messaging import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) -import Wire.API.Team.Feature hiding (setStatus) import Wire.API.Team.Member import Wire.API.User.Client @@ -294,7 +303,7 @@ updateConversationAccess :: Sem r (UpdateResult Event) updateConversationAccess lusr con qcnv update = do lcnv <- ensureLocal lusr qcnv - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationAccessDataTag lcnv (tUntagged lusr) (Just con) update updateConversationAccessUnqualified :: @@ -306,7 +315,7 @@ updateConversationAccessUnqualified :: ConversationAccessData -> Sem r (UpdateResult Event) updateConversationAccessUnqualified lusr con cnv update = - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationAccessDataTag (qualifyAs lusr cnv) (tUntagged lusr) @@ -326,8 +335,8 @@ updateConversationReceiptMode :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member MemberStore r, - Member SubConversationStore r, - Member TinyLog r + Member TinyLog r, + Member SubConversationStore r ) => Local UserId -> ConnId -> @@ -338,7 +347,7 @@ updateConversationReceiptMode lusr zcon qcnv update = foldQualified lusr ( \lcnv -> - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationReceiptModeUpdateTag lcnv @@ -377,10 +386,9 @@ updateRemoteConversation rcnv lusr conn action = getUpdateResult $ do convUpdate <- case response of ConversationUpdateResponseNoChanges -> throw NoChanges ConversationUpdateResponseError err' -> rethrowErrors @(HasConversationActionGalleyErrors tag) err' - ConversationUpdateResponseUpdate convUpdate -> pure convUpdate + ConversationUpdateResponseUpdate convUpdate _failedToProcess -> pure convUpdate - -- FUTUREWORK: Should we really be calling a federation handler here? - onConversationUpdated (tDomain rcnv) convUpdate + updateLocalStateOfRemoteConv (tDomain rcnv) convUpdate notifyRemoteConversationAction lusr (qualifyAs rcnv convUpdate) (Just conn) updateConversationReceiptModeUnqualified :: @@ -396,8 +404,8 @@ updateConversationReceiptModeUnqualified :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member MemberStore r, - Member SubConversationStore r, - Member TinyLog r + Member TinyLog r, + Member SubConversationStore r ) => Local UserId -> ConnId -> @@ -416,8 +424,8 @@ updateConversationMessageTimer :: Member FederatorAccess r, Member GundeckAccess r, Member (Input UTCTime) r, - Member SubConversationStore r, - Member (Logger (Msg -> Msg)) r + Member (Logger (Msg -> Msg)) r, + Member SubConversationStore r ) => Local UserId -> ConnId -> @@ -429,7 +437,7 @@ updateConversationMessageTimer lusr zcon qcnv update = foldQualified lusr ( \lcnv -> - lcuEvent + lcuEvent . fst <$> updateLocalConversation @'ConversationMessageTimerUpdateTag lcnv @@ -450,8 +458,8 @@ updateConversationMessageTimerUnqualified :: Member FederatorAccess r, Member GundeckAccess r, Member (Input UTCTime) r, - Member SubConversationStore r, - Member (Logger (Msg -> Msg)) r + Member (Logger (Msg -> Msg)) r, + Member SubConversationStore r ) => Local UserId -> ConnId -> @@ -484,14 +492,14 @@ deleteLocalConversation :: Local ConvId -> Sem r (UpdateResult Event) deleteLocalConversation lusr con lcnv = - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationDeleteTag lcnv (tUntagged lusr) (Just con) () getUpdateResult :: Sem (Error NoChanges ': r) a -> Sem r (UpdateResult a) getUpdateResult = fmap (either (const Unchanged) Updated) . runError addCodeUnqualifiedWithReqBody :: - forall db r. + forall r. ( Member CodeStore r, Member ConversationStore r, Member (ErrorS 'ConvAccessDenied) r, @@ -504,18 +512,17 @@ addCodeUnqualifiedWithReqBody :: Member (Input UTCTime) r, Member (Embed IO) r, Member (Input Opts) r, - Member (TeamFeatureStore db) r, - FeaturePersistentConstraint db GuestLinksConfig + Member TeamFeatureStore r ) => UserId -> Maybe ConnId -> ConvId -> CreateConversationCodeRequest -> Sem r AddCodeResult -addCodeUnqualifiedWithReqBody usr mZcon cnv req = addCodeUnqualified @db (Just req) usr mZcon cnv +addCodeUnqualifiedWithReqBody usr mZcon cnv req = addCodeUnqualified (Just req) usr mZcon cnv addCodeUnqualified :: - forall db r. + forall r. ( Member CodeStore r, Member ConversationStore r, Member (ErrorS 'ConvAccessDenied) r, @@ -528,8 +535,7 @@ addCodeUnqualified :: Member (Input UTCTime) r, Member (Input Opts) r, Member (Embed IO) r, - Member (TeamFeatureStore db) r, - FeaturePersistentConstraint db GuestLinksConfig + Member TeamFeatureStore r ) => Maybe CreateConversationCodeRequest -> UserId -> @@ -539,10 +545,10 @@ addCodeUnqualified :: addCodeUnqualified mReq usr mZcon cnv = do lusr <- qualifyLocal usr lcnv <- qualifyLocal cnv - addCode @db lusr mZcon lcnv mReq + addCode lusr mZcon lcnv mReq addCode :: - forall db r. + forall r. ( Member CodeStore r, Member ConversationStore r, Member (ErrorS 'ConvNotFound) r, @@ -553,9 +559,8 @@ addCode :: Member GundeckAccess r, Member (Input UTCTime) r, Member (Input Opts) r, - Member (TeamFeatureStore db) r, - Member (Embed IO) r, - FeaturePersistentConstraint db GuestLinksConfig + Member TeamFeatureStore r, + Member (Embed IO) r ) => Local UserId -> Maybe ConnId -> @@ -564,7 +569,7 @@ addCode :: Sem r AddCodeResult addCode lusr mZcon lcnv mReq = do conv <- E.getConversation (tUnqualified lcnv) >>= noteS @'ConvNotFound - Query.ensureGuestLinksEnabled @db (Data.convTeam conv) + Query.ensureGuestLinksEnabled (Data.convTeam conv) Query.ensureConvAdmin (Data.convLocalMembers conv) (tUnqualified lusr) ensureAccess conv CodeAccess ensureGuestsOrNonTeamMembersAllowed conv @@ -642,7 +647,7 @@ rmCode lusr zcon lcnv = do pure event getCode :: - forall db r. + forall r. ( Member CodeStore r, Member ConversationStore r, Member (ErrorS 'CodeNotFound) r, @@ -650,8 +655,7 @@ getCode :: Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'GuestLinksDisabled) r, Member (Input Opts) r, - Member (TeamFeatureStore db) r, - FeaturePersistentConstraint db GuestLinksConfig + Member TeamFeatureStore r ) => Local UserId -> ConvId -> @@ -659,7 +663,7 @@ getCode :: getCode lusr cnv = do conv <- E.getConversation cnv >>= noteS @'ConvNotFound - Query.ensureGuestLinksEnabled @db (Data.convTeam conv) + Query.ensureGuestLinksEnabled (Data.convTeam conv) ensureAccess conv CodeAccess ensureConvMember (Data.convLocalMembers conv) (tUnqualified lusr) key <- E.makeKey cnv @@ -667,15 +671,14 @@ getCode lusr cnv = do mkConversationCodeInfo (isJust mPw) (codeKey c) (codeValue c) <$> E.getConversationCodeURI checkReusableCode :: - forall db r. + forall r. ( Member CodeStore r, Member ConversationStore r, - Member (TeamFeatureStore db) r, + Member TeamFeatureStore r, Member (ErrorS 'CodeNotFound) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidConversationPassword) r, - Member (Input Opts) r, - FeaturePersistentConstraint db GuestLinksConfig + Member (Input Opts) r ) => ConversationCode -> Sem r () @@ -683,7 +686,7 @@ checkReusableCode convCode = do code <- verifyReusableCode False Nothing convCode conv <- E.getConversation (codeConversation code) >>= noteS @'ConvNotFound mapErrorS @'GuestLinksDisabled @'CodeNotFound $ - Query.ensureGuestLinksEnabled @db (Data.convTeam conv) + Query.ensureGuestLinksEnabled (Data.convTeam conv) updateConversationProtocolWithLocalUser :: forall r. @@ -748,10 +751,11 @@ updateLocalConversationProtocol qusr client mconn lcnv protocolUpdate@(P.Protoco (_, _) -> throwS @'ConvInvalidProtocolTransition joinConversationByReusableCode :: - forall db r. + forall r. ( Member BrigAccess r, Member CodeStore r, Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS 'CodeNotFound) r, Member (ErrorS 'InvalidConversationPassword) r, Member (ErrorS 'ConvAccessDenied) r, @@ -766,11 +770,10 @@ joinConversationByReusableCode :: Member (Input Opts) r, Member (Input UTCTime) r, Member MemberStore r, - Member SubConversationStore r, Member TeamStore r, - Member (TeamFeatureStore db) r, + Member TeamFeatureStore r, Member (Logger (Msg -> Msg)) r, - FeaturePersistentConstraint db GuestLinksConfig + Member SubConversationStore r ) => Local UserId -> ConnId -> @@ -779,7 +782,7 @@ joinConversationByReusableCode :: joinConversationByReusableCode lusr zcon req = do c <- verifyReusableCode True req.password req.code conv <- E.getConversation (codeConversation c) >>= noteS @'ConvNotFound - Query.ensureGuestLinksEnabled @db (Data.convTeam conv) + Query.ensureGuestLinksEnabled (Data.convTeam conv) joinConversation lusr zcon conv CodeAccess joinConversationById :: @@ -787,6 +790,7 @@ joinConversationById :: ( Member BrigAccess r, Member FederatorAccess r, Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS 'ConvAccessDenied) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, @@ -794,10 +798,10 @@ joinConversationById :: Member (ErrorS 'TooManyMembers) r, Member ExternalAccess r, Member GundeckAccess r, + Member SubConversationStore r, Member (Input Opts) r, Member (Input UTCTime) r, Member MemberStore r, - Member SubConversationStore r, Member TeamStore r, Member (Logger (Msg -> Msg)) r ) => @@ -812,6 +816,7 @@ joinConversationById lusr zcon cnv = do joinConversation :: ( Member BrigAccess r, Member FederatorAccess r, + Member (Error FederationError) r, Member (ErrorS 'ConvAccessDenied) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, @@ -821,9 +826,9 @@ joinConversation :: Member (Input Opts) r, Member (Input UTCTime) r, Member MemberStore r, - Member SubConversationStore r, Member TeamStore r, - Member (Logger (Msg -> Msg)) r + Member (Logger (Msg -> Msg)) r, + Member SubConversationStore r ) => Local UserId -> ConnId -> @@ -843,9 +848,8 @@ joinConversation lusr zcon conv access = do let users = filter (notIsConvMember lusr conv) [tUnqualified lusr] (extraTargets, action) <- addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember - lcuEvent + lcuEvent . fst <$> notifyConversationAction - False (sing @'ConversationJoinTag) (tUntagged lusr) False @@ -888,7 +892,7 @@ addMembers :: Sem r (UpdateResult Event) addMembers lusr zcon qcnv (InviteQualified users role) = do lcnv <- ensureLocal lusr qcnv - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged lusr) (Just zcon) $ ConversationJoin users role @@ -926,7 +930,7 @@ addMembersUnqualifiedV2 :: Sem r (UpdateResult Event) addMembersUnqualifiedV2 lusr zcon cnv (InviteQualified users role) = do let lcnv = qualifyAs lusr cnv - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationJoinTag lcnv (tUntagged lusr) (Just zcon) $ ConversationJoin users role @@ -1032,6 +1036,7 @@ updateUnqualifiedSelfMember lusr zcon cnv update = do updateOtherMemberLocalConv :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS ('ActionDenied 'ModifyOtherConversationMember)) r, Member (ErrorS 'InvalidTarget) r, Member (ErrorS 'InvalidOperation) r, @@ -1042,8 +1047,8 @@ updateOtherMemberLocalConv :: Member GundeckAccess r, Member (Input UTCTime) r, Member MemberStore r, - Member SubConversationStore r, - Member (Logger (Msg -> Msg)) r + Member (Logger (Msg -> Msg)) r, + Member SubConversationStore r ) => Local ConvId -> Local UserId -> @@ -1051,7 +1056,7 @@ updateOtherMemberLocalConv :: Qualified UserId -> OtherMemberUpdate -> Sem r () -updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult . fmap lcuEvent $ do +updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult . fmap (lcuEvent . fst) $ do when (tUntagged lusr == qvictim) $ throwS @'InvalidTarget updateLocalConversation @'ConversationMemberUpdateTag lcnv (tUntagged lusr) (Just con) $ @@ -1059,6 +1064,7 @@ updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult updateOtherMemberUnqualified :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS ('ActionDenied 'ModifyOtherConversationMember)) r, Member (ErrorS 'InvalidTarget) r, Member (ErrorS 'InvalidOperation) r, @@ -1067,9 +1073,9 @@ updateOtherMemberUnqualified :: Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, + Member SubConversationStore r, Member (Input UTCTime) r, Member MemberStore r, - Member SubConversationStore r, Member (Logger (Msg -> Msg)) r ) => Local UserId -> @@ -1096,8 +1102,8 @@ updateOtherMember :: Member GundeckAccess r, Member (Input UTCTime) r, Member MemberStore r, - Member SubConversationStore r, - Member (Logger (Msg -> Msg)) r + Member (Logger (Msg -> Msg)) r, + Member SubConversationStore r ) => Local UserId -> ConnId -> @@ -1121,6 +1127,7 @@ updateOtherMemberRemoteConv _ _ _ _ _ = throw FederationNotImplemented removeMemberUnqualified :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'ConvNotFound) r, @@ -1147,6 +1154,7 @@ removeMemberUnqualified lusr con cnv victim = do removeMemberQualified :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, Member (ErrorS 'ConvNotFound) r, @@ -1189,7 +1197,7 @@ removeMemberFromRemoteConv cnv lusr victim | tUntagged lusr == victim = do let lc = LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) let rpc = fedClient @'Galley @"leave-conversation" lc - (either handleError handleSuccess . leaveResponse =<<) $ + (either handleError handleSuccess . void . leaveResponse =<<) $ E.runFederated cnv rpc | otherwise = throwS @('ActionDenied 'RemoveConversationMember) where @@ -1214,6 +1222,7 @@ removeMemberFromRemoteConv cnv lusr victim -- | Remove a member from a local conversation. removeMemberFromLocalConv :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InternalError) r, Member (ErrorS ('ActionDenied 'LeaveConversation)) r, Member (ErrorS ('ActionDenied 'RemoveConversationMember)) r, @@ -1236,12 +1245,12 @@ removeMemberFromLocalConv :: Sem r (Maybe Event) removeMemberFromLocalConv lcnv lusr con victim | tUntagged lusr == victim = - fmap (fmap lcuEvent . hush) + fmap (fmap lcuEvent . hush . fmap fst) . runError @NoChanges . updateLocalConversation @'ConversationLeaveTag lcnv (tUntagged lusr) con $ () | otherwise = - fmap (fmap lcuEvent . hush) + fmap (fmap lcuEvent . hush . fmap fst) . runError @NoChanges . updateLocalConversation @'ConversationRemoveMembersTag lcnv (tUntagged lusr) con . pure @@ -1410,8 +1419,8 @@ updateConversationName :: Member FederatorAccess r, Member GundeckAccess r, Member (Input UTCTime) r, - Member SubConversationStore r, - Member (Logger (Msg -> Msg)) r + Member (Logger (Msg -> Msg)) r, + Member SubConversationStore r ) => Local UserId -> ConnId -> @@ -1428,6 +1437,7 @@ updateConversationName lusr zcon qcnv convRename = do updateUnqualifiedConversationName :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InvalidInput) r, Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, @@ -1436,8 +1446,8 @@ updateUnqualifiedConversationName :: Member FederatorAccess r, Member GundeckAccess r, Member (Input UTCTime) r, - Member SubConversationStore r, - Member (Logger (Msg -> Msg)) r + Member (Logger (Msg -> Msg)) r, + Member SubConversationStore r ) => Local UserId -> ConnId -> @@ -1450,6 +1460,7 @@ updateUnqualifiedConversationName lusr zcon cnv rename = do updateLocalConversationName :: ( Member ConversationStore r, + Member (Error FederationError) r, Member (Error InvalidInput) r, Member (ErrorS ('ActionDenied 'ModifyConversationName)) r, Member (ErrorS 'ConvNotFound) r, @@ -1458,8 +1469,8 @@ updateLocalConversationName :: Member FederatorAccess r, Member GundeckAccess r, Member (Input UTCTime) r, - Member SubConversationStore r, - Member (Logger (Msg -> Msg)) r + Member (Logger (Msg -> Msg)) r, + Member SubConversationStore r ) => Local UserId -> ConnId -> @@ -1467,7 +1478,7 @@ updateLocalConversationName :: ConversationRename -> Sem r (UpdateResult Event) updateLocalConversationName lusr zcon lcnv rename = - getUpdateResult . fmap lcuEvent $ + getUpdateResult . fmap (lcuEvent . fst) $ updateLocalConversation @'ConversationRenameTag lcnv (tUntagged lusr) (Just zcon) rename memberTyping :: @@ -1687,6 +1698,113 @@ rmBot lusr zcon b = do E.deliverAsync (bots `zip` repeat e) pure $ Updated e +-- | Update the local database with information on conversation members joining +-- or leaving. Finally, push out notifications to local users. +updateLocalStateOfRemoteConv :: + ( Member BrigAccess r, + Member GundeckAccess r, + Member ExternalAccess r, + Member (Input (Local ())) r, + Member MemberStore r, + Member P.TinyLog r + ) => + Domain -> + F.ConversationUpdate -> + Sem r () +updateLocalStateOfRemoteConv requestingDomain cu = do + loc <- qualifyLocal () + let rconvId = toRemoteUnsafe requestingDomain (F.cuConvId cu) + qconvId = tUntagged rconvId + + -- Note: we generally do not send notifications to users that are not part of + -- the conversation (from our point of view), to prevent spam from the remote + -- backend. See also the comment below. + (presentUsers, allUsersArePresent) <- + E.selectRemoteMembers (F.cuAlreadyPresentUsers cu) rconvId + + -- Perform action, and determine extra notification targets. + -- + -- When new users are being added to the conversation, we consider them as + -- notification targets. Since we check connections before letting + -- people being added, this is safe against spam. However, if users that + -- are not in the conversations are being removed or have their membership state + -- updated, we do **not** add them to the list of targets, because we have no + -- way to make sure that they are actually supposed to receive that notification. + + (mActualAction :: Maybe SomeConversationAction, extraTargets :: [UserId]) <- case F.cuAction cu of + sca@(SomeConversationAction singTag action) -> case singTag of + SConversationJoinTag -> do + let ConversationJoin toAdd role = action + let (localUsers, remoteUsers) = partitionQualified loc toAdd + addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId (F.cuOrigUserId cu) localUsers + let allAddedUsers = map (tUntagged . qualifyAs loc) addedLocalUsers <> map tUntagged remoteUsers + case allAddedUsers of + [] -> pure (Nothing, []) -- If no users get added, its like no action was performed. + (u : us) -> pure (Just (SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (u :| us) role)), addedLocalUsers) + SConversationLeaveTag -> do + let users = foldQualified loc (pure . tUnqualified) (const []) (F.cuOrigUserId cu) + E.deleteMembersInRemoteConversation rconvId users + pure (Just sca, []) + SConversationRemoveMembersTag -> do + let localUsers = getLocalUsers (tDomain loc) action + E.deleteMembersInRemoteConversation rconvId localUsers + pure (Just sca, []) + SConversationMemberUpdateTag -> + pure (Just sca, []) + SConversationDeleteTag -> do + E.deleteMembersInRemoteConversation rconvId presentUsers + pure (Just sca, []) + SConversationRenameTag -> pure (Just sca, []) + SConversationMessageTimerUpdateTag -> pure (Just sca, []) + SConversationReceiptModeUpdateTag -> pure (Just sca, []) + SConversationAccessDataTag -> pure (Just sca, []) + + unless allUsersArePresent $ + P.warn $ + Log.field "conversation" (toByteString' (F.cuConvId cu)) + . Log.field "domain" (toByteString' requestingDomain) + . Log.msg + ( "Attempt to send notification about conversation update \ + \to users not in the conversation" :: + ByteString + ) + + -- Send notifications + for_ mActualAction $ \(SomeConversationAction tag action) -> do + let event = conversationActionToEvent tag (F.cuTime cu) (F.cuOrigUserId cu) qconvId Nothing action + targets = nubOrd $ presentUsers <> extraTargets + -- FUTUREWORK: support bots? + pushConversationEvent Nothing event (qualifyAs loc targets) [] + +addLocalUsersToRemoteConv :: + ( Member BrigAccess r, + Member MemberStore r, + Member P.TinyLog r + ) => + Remote ConvId -> + Qualified UserId -> + [UserId] -> + Sem r (Set UserId) +addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do + connStatus <- E.getConnections localUsers (Just [qAdder]) (Just Accepted) + let localUserIdsSet = Set.fromList localUsers + connected = Set.fromList $ fmap csv2From connStatus + unconnected = Set.difference localUserIdsSet connected + connectedList = Set.toList connected + + -- FUTUREWORK: Consider handling the discrepancy between the views of the + -- conversation-owning backend and the local backend + unless (Set.null unconnected) $ + P.warn $ + Log.msg ("A remote user is trying to add unconnected local users to a remote conversation" :: Text) + . Log.field "remote_user" (show qAdder) + . Log.field "local_unconnected_users" (show unconnected) + + -- Update the local view of the remote conversation by adding only those local + -- users that are connected to the adder + E.createMembersInRemoteConversation remoteConvId connectedList + pure connected + ------------------------------------------------------------------------------- -- Helpers diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 52e4ef9571..657207c210 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -28,6 +28,7 @@ import Data.Domain (Domain) import Data.Id as Id import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Extra (chunksOf, nubOrd) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as Map import Data.Misc (PlainTextPassword6, PlainTextPassword8) import Data.Qualified @@ -936,6 +937,9 @@ conversationExisted :: Sem r ConversationResponse conversationExisted lusr cnv = Existed <$> conversationView lusr cnv +getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] +getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomain) . toList + -------------------------------------------------------------------------------- -- Handling remote errors diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 5bbd2af776..f7ee605b4e 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -17,8 +17,6 @@ module Galley.Cassandra.TeamFeatures ( interpretTeamFeatureStoreToCassandra, - Cassandra, - FeatureStatusCassandra (..), getFeatureConfigMulti, ) where @@ -28,7 +26,6 @@ import qualified Cassandra as C import Control.Monad.Trans.Maybe import Data.Id import Data.Misc (HttpsUrl) -import Data.Proxy import Data.Time (NominalDiffTime) import Galley.Cassandra.Instances () import Galley.Cassandra.Store @@ -41,32 +38,204 @@ import Wire.API.Conversation.Protocol (ProtocolTag) import Wire.API.MLS.CipherSuite import Wire.API.Team.Feature -data Cassandra - -type instance TFS.FeaturePersistentConstraint Cassandra = FeatureStatusCassandra - interpretTeamFeatureStoreToCassandra :: ( Member (Embed IO) r, Member (Input ClientState) r ) => - Sem (TFS.TeamFeatureStore Cassandra ': r) a -> + Sem (TFS.TeamFeatureStore ': r) a -> Sem r a interpretTeamFeatureStoreToCassandra = interpret $ \case - TFS.GetFeatureConfig proxy tid -> embedClient $ getFeatureConfig proxy tid - TFS.GetFeatureConfigMulti proxy tids -> embedClient $ getFeatureConfigMulti proxy tids - TFS.SetFeatureConfig proxy tid wsnl -> embedClient $ setFeatureConfig proxy tid wsnl - TFS.GetFeatureLockStatus proxy tid -> embedClient $ getFeatureLockStatus proxy tid - TFS.SetFeatureLockStatus proxy tid ls -> embedClient $ setFeatureLockStatus proxy tid ls - -class FeatureStatusCassandra cfg where - getFeatureConfig :: MonadClient m => Proxy cfg -> TeamId -> m (Maybe (WithStatusNoLock cfg)) - setFeatureConfig :: MonadClient m => Proxy cfg -> TeamId -> WithStatusNoLock cfg -> m () + TFS.GetFeatureConfig sing tid -> embedClient $ getFeatureConfig sing tid + TFS.GetFeatureConfigMulti sing tids -> embedClient $ getFeatureConfigMulti sing tids + TFS.SetFeatureConfig sing tid wsnl -> embedClient $ setFeatureConfig sing tid wsnl + TFS.GetFeatureLockStatus sing tid -> embedClient $ getFeatureLockStatus sing tid + TFS.SetFeatureLockStatus sing tid ls -> embedClient $ setFeatureLockStatus sing tid ls + +getFeatureConfig :: MonadClient m => FeatureSingleton cfg -> TeamId -> m (Maybe (WithStatusNoLock cfg)) +getFeatureConfig FeatureSingletonLegalholdConfig tid = getTrivialConfigC "legalhold_status" tid +getFeatureConfig FeatureSingletonSSOConfig tid = getTrivialConfigC "sso_status" tid +getFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig tid = getTrivialConfigC "search_visibility_status" tid +getFeatureConfig FeatureSingletonValidateSAMLEmailsConfig tid = getTrivialConfigC "validate_saml_emails" tid +getFeatureConfig FeatureSingletonClassifiedDomainsConfig _tid = pure Nothing -- TODO(fisx): what's this about? +getFeatureConfig FeatureSingletonDigitalSignaturesConfig tid = getTrivialConfigC "digital_signatures" tid +getFeatureConfig FeatureSingletonAppLockConfig tid = runMaybeT $ do + (mStatus, mEnforce, mTimeout) <- + MaybeT . retry x1 $ + query1 select (params LocalQuorum (Identity tid)) + maybe mzero pure $ + WithStatusNoLock + <$> mStatus + <*> (AppLockConfig <$> mEnforce <*> mTimeout) + <*> Just FeatureTTLUnlimited + where + select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe EnforceAppLock, Maybe Int32) + select = + "select app_lock_status, app_lock_enforce, app_lock_inactivity_timeout_secs \ + \ from team_features where team_id = ?" +getFeatureConfig FeatureSingletonFileSharingConfig tid = getTrivialConfigC "file_sharing" tid +getFeatureConfig FeatureSingletonSelfDeletingMessagesConfig tid = runMaybeT $ do + (mEnabled, mTimeout) <- + MaybeT . retry x1 $ + query1 select (params LocalQuorum (Identity tid)) + maybe mzero pure $ + WithStatusNoLock + <$> mEnabled + <*> fmap SelfDeletingMessagesConfig mTimeout + <*> Just FeatureTTLUnlimited + where + select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe Int32) + select = + "select self_deleting_messages_status, self_deleting_messages_ttl\ + \ from team_features where team_id = ?" +getFeatureConfig FeatureSingletonConferenceCallingConfig tid = do + let q = query1 select (params LocalQuorum (Identity tid)) + retry x1 q <&> \case + Nothing -> Nothing + Just (Nothing, _) -> Nothing + Just (Just status, mTtl) -> Just . forgetLock . setStatus status . setWsTTL (fromMaybe FeatureTTLUnlimited mTtl) $ defFeatureStatus + where + select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe FeatureTTL) + select = + fromString $ + "select conference_calling, ttl(conference_calling) from team_features where team_id = ?" +getFeatureConfig FeatureSingletonGuestLinksConfig tid = getTrivialConfigC "guest_links_status" tid +getFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig tid = getTrivialConfigC "snd_factor_password_challenge_status" tid +getFeatureConfig FeatureSingletonSearchVisibilityInboundConfig tid = getTrivialConfigC "search_visibility_status" tid +getFeatureConfig FeatureSingletonMLSConfig tid = do + m <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) + pure $ case m of + Nothing -> Nothing + Just (status, defaultProtocol, protocolToggleUsers, allowedCipherSuites, defaultCipherSuite) -> + WithStatusNoLock + <$> status + <*> ( MLSConfig + <$> maybe (Just []) (Just . C.fromSet) protocolToggleUsers + <*> defaultProtocol + <*> maybe (Just []) (Just . C.fromSet) allowedCipherSuites + <*> defaultCipherSuite + ) + <*> Just FeatureTTLUnlimited + where + select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe ProtocolTag, Maybe (C.Set UserId), Maybe (C.Set CipherSuiteTag), Maybe CipherSuiteTag) + select = + "select mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, \ + \mls_default_ciphersuite from team_features where team_id = ?" +getFeatureConfig FeatureSingletonMlsE2EIdConfig tid = do + let q = query1 select (params LocalQuorum (Identity tid)) + retry x1 q <&> \case + Nothing -> Nothing + Just (Nothing, _, _) -> Nothing + Just (Just fs, mGracePeriod, mUrl) -> + Just $ + WithStatusNoLock + fs + (MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl) + FeatureTTLUnlimited + where + toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime + toGracePeriodOrDefault = maybe (verificationExpiration $ wsConfig defFeatureStatus) fromIntegral - -- default implementation: no lock status - getFeatureLockStatus :: MonadClient m => Proxy cfg -> TeamId -> m (Maybe LockStatus) - getFeatureLockStatus _ _tid = pure Nothing - setFeatureLockStatus :: MonadClient m => Proxy cfg -> TeamId -> LockStatus -> m () - setFeatureLockStatus _ _tid _status = pure () + select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe Int32, Maybe HttpsUrl) + select = + fromString $ + "select mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url from team_features where team_id = ?" +getFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig tid = getTrivialConfigC "expose_invitation_urls_to_team_admin" tid +getFeatureConfig FeatureSingletonOutlookCalIntegrationConfig tid = getTrivialConfigC "outlook_cal_integration_status" tid + +setFeatureConfig :: MonadClient m => FeatureSingleton cfg -> TeamId -> WithStatusNoLock cfg -> m () +setFeatureConfig FeatureSingletonLegalholdConfig tid statusNoLock = setFeatureStatusC "legalhold_status" tid (wssStatus statusNoLock) +setFeatureConfig FeatureSingletonSSOConfig tid statusNoLock = setFeatureStatusC "sso_status" tid (wssStatus statusNoLock) +setFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig tid statusNoLock = setFeatureStatusC "search_visibility_status" tid (wssStatus statusNoLock) +setFeatureConfig FeatureSingletonValidateSAMLEmailsConfig tid statusNoLock = setFeatureStatusC "validate_saml_emails" tid (wssStatus statusNoLock) +setFeatureConfig FeatureSingletonClassifiedDomainsConfig _tid _statusNoLock = pure () +setFeatureConfig FeatureSingletonDigitalSignaturesConfig tid statusNoLock = setFeatureStatusC "digital_signatures" tid (wssStatus statusNoLock) +setFeatureConfig FeatureSingletonAppLockConfig tid status = do + let enforce = applockEnforceAppLock (wssConfig status) + timeout = applockInactivityTimeoutSecs (wssConfig status) + + retry x5 $ write insert (params LocalQuorum (tid, wssStatus status, enforce, timeout)) + where + insert :: PrepQuery W (TeamId, FeatureStatus, EnforceAppLock, Int32) () + insert = + fromString $ + "insert into team_features (team_id, app_lock_status, app_lock_enforce,\ + \ app_lock_inactivity_timeout_secs) values (?, ?, ?, ?)" +setFeatureConfig FeatureSingletonFileSharingConfig tid statusNoLock = setFeatureStatusC "file_sharing" tid (wssStatus statusNoLock) +setFeatureConfig FeatureSingletonSelfDeletingMessagesConfig tid status = do + let statusValue = wssStatus status + timeout = sdmEnforcedTimeoutSeconds . wssConfig $ status + retry x5 $ write insert (params LocalQuorum (tid, statusValue, timeout)) + where + insert :: PrepQuery W (TeamId, FeatureStatus, Int32) () + insert = + "insert into team_features (team_id, self_deleting_messages_status,\ + \ self_deleting_messages_ttl) values (?, ?, ?)" +setFeatureConfig FeatureSingletonConferenceCallingConfig tid statusNoLock = + retry x5 $ write insert (params LocalQuorum (tid, wssStatus statusNoLock)) + where + renderFeatureTtl :: FeatureTTL -> String + renderFeatureTtl = \case + FeatureTTLSeconds d | d > 0 -> " using ttl " <> show d + _ -> " using ttl 0" -- 0 or unlimited (delete a column's existing TTL by setting its value to zero) + insert :: PrepQuery W (TeamId, FeatureStatus) () + insert = + fromString $ + "insert into team_features (team_id,conference_calling) values (?, ?)" + <> renderFeatureTtl (wssTTL statusNoLock) +setFeatureConfig FeatureSingletonGuestLinksConfig tid statusNoLock = setFeatureStatusC "guest_links_status" tid (wssStatus statusNoLock) +setFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig tid statusNoLock = + setFeatureStatusC "snd_factor_password_challenge_status" tid (wssStatus statusNoLock) +setFeatureConfig FeatureSingletonSearchVisibilityInboundConfig tid statusNoLock = setFeatureStatusC "search_visibility_status" tid (wssStatus statusNoLock) +setFeatureConfig FeatureSingletonMLSConfig tid statusNoLock = do + let status = wssStatus statusNoLock + let MLSConfig protocolToggleUsers defaultProtocol allowedCipherSuites defaultCipherSuite = wssConfig statusNoLock + retry x5 $ + write + insert + ( params + LocalQuorum + ( tid, + status, + defaultProtocol, + C.Set protocolToggleUsers, + C.Set allowedCipherSuites, + defaultCipherSuite + ) + ) + where + insert :: PrepQuery W (TeamId, FeatureStatus, ProtocolTag, C.Set UserId, C.Set CipherSuiteTag, CipherSuiteTag) () + insert = + "insert into team_features (team_id, mls_status, mls_default_protocol, \ + \mls_protocol_toggle_users, mls_allowed_ciphersuites, mls_default_ciphersuite) values (?, ?, ?, ?, ?, ?)" +setFeatureConfig FeatureSingletonMlsE2EIdConfig tid status = do + let statusValue = wssStatus status + vex = verificationExpiration . wssConfig $ status + mUrl = acmeDiscoveryUrl . wssConfig $ status + retry x5 $ write insert (params LocalQuorum (tid, statusValue, truncate vex, mUrl)) + where + insert :: PrepQuery W (TeamId, FeatureStatus, Int32, Maybe HttpsUrl) () + insert = + "insert into team_features (team_id, mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url) values (?, ?, ?, ?)" +setFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig tid statusNoLock = setFeatureStatusC "expose_invitation_urls_to_team_admin" tid (wssStatus statusNoLock) +setFeatureConfig FeatureSingletonOutlookCalIntegrationConfig tid statusNoLock = setFeatureStatusC "outlook_cal_integration_status" tid (wssStatus statusNoLock) + +getFeatureLockStatus :: MonadClient m => FeatureSingleton cfg -> TeamId -> m (Maybe LockStatus) +getFeatureLockStatus FeatureSingletonFileSharingConfig tid = getLockStatusC "file_sharing_lock_status" tid +getFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig tid = getLockStatusC "self_deleting_messages_lock_status" tid +getFeatureLockStatus FeatureSingletonGuestLinksConfig tid = getLockStatusC "guest_links_lock_status" tid +getFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig tid = getLockStatusC "snd_factor_password_challenge_lock_status" tid +getFeatureLockStatus FeatureSingletonMlsE2EIdConfig tid = getLockStatusC "mls_e2eid_lock_status" tid +getFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig tid = getLockStatusC "outlook_cal_integration_lock_status" tid +getFeatureLockStatus _ _ = pure Nothing + +setFeatureLockStatus :: MonadClient m => FeatureSingleton cfg -> TeamId -> LockStatus -> m () +setFeatureLockStatus FeatureSingletonFileSharingConfig tid status = setLockStatusC "file_sharing_lock_status" tid status +setFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig tid status = setLockStatusC "self_deleting_messages_lock_status" tid status +setFeatureLockStatus FeatureSingletonGuestLinksConfig tid status = setLockStatusC "guest_links_lock_status" tid status +setFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig tid status = setLockStatusC "snd_factor_password_challenge_lock_status" tid status +setFeatureLockStatus FeatureSingletonMlsE2EIdConfig tid status = setLockStatusC "mls_e2eid_lock_status" tid status +setFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig tid status = setLockStatusC "outlook_cal_integration_lock_status" tid status +setFeatureLockStatus _ _tid _status = pure () getTrivialConfigC :: forall m cfg. @@ -136,229 +305,9 @@ setLockStatusC col tid status = do getFeatureConfigMulti :: forall cfg m. - (FeatureStatusCassandra cfg, MonadClient m, MonadUnliftIO m) => - Proxy cfg -> + (MonadClient m, MonadUnliftIO m) => + FeatureSingleton cfg -> [TeamId] -> m [(TeamId, Maybe (WithStatusNoLock cfg))] getFeatureConfigMulti proxy = pooledMapConcurrentlyN 8 (\tid -> getFeatureConfig proxy tid <&> (tid,)) - -instance FeatureStatusCassandra LegalholdConfig where - getFeatureConfig _ = getTrivialConfigC "legalhold_status" - setFeatureConfig _ tid statusNoLock = setFeatureStatusC "legalhold_status" tid (wssStatus statusNoLock) - -instance FeatureStatusCassandra SSOConfig where - getFeatureConfig _ = getTrivialConfigC "sso_status" - setFeatureConfig _ tid statusNoLock = setFeatureStatusC "sso_status" tid (wssStatus statusNoLock) - -instance FeatureStatusCassandra SearchVisibilityAvailableConfig where - getFeatureConfig _ = getTrivialConfigC "search_visibility_status" - setFeatureConfig _ tid statusNoLock = setFeatureStatusC "search_visibility_status" tid (wssStatus statusNoLock) - -instance FeatureStatusCassandra ValidateSAMLEmailsConfig where - getFeatureConfig _ = getTrivialConfigC "validate_saml_emails" - setFeatureConfig _ tid statusNoLock = setFeatureStatusC "validate_saml_emails" tid (wssStatus statusNoLock) - -instance FeatureStatusCassandra ClassifiedDomainsConfig where - getFeatureConfig _ _tid = pure Nothing -- TODO(fisx): what's this about? - setFeatureConfig _ _tid _statusNoLock = pure () - -instance FeatureStatusCassandra DigitalSignaturesConfig where - getFeatureConfig _ = getTrivialConfigC "digital_signatures" - setFeatureConfig _ tid statusNoLock = setFeatureStatusC "digital_signatures" tid (wssStatus statusNoLock) - -instance FeatureStatusCassandra AppLockConfig where - getFeatureConfig _ tid = runMaybeT $ do - (mStatus, mEnforce, mTimeout) <- - MaybeT . retry x1 $ - query1 select (params LocalQuorum (Identity tid)) - maybe mzero pure $ - WithStatusNoLock - <$> mStatus - <*> (AppLockConfig <$> mEnforce <*> mTimeout) - <*> Just FeatureTTLUnlimited - where - select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe EnforceAppLock, Maybe Int32) - select = - "select app_lock_status, app_lock_enforce, app_lock_inactivity_timeout_secs \ - \ from team_features where team_id = ?" - - setFeatureConfig _ tid status = do - let enforce = applockEnforceAppLock (wssConfig status) - timeout = applockInactivityTimeoutSecs (wssConfig status) - - retry x5 $ write insert (params LocalQuorum (tid, wssStatus status, enforce, timeout)) - where - insert :: PrepQuery W (TeamId, FeatureStatus, EnforceAppLock, Int32) () - insert = - fromString $ - "insert into team_features (team_id, app_lock_status, app_lock_enforce,\ - \ app_lock_inactivity_timeout_secs) values (?, ?, ?, ?)" - -instance FeatureStatusCassandra FileSharingConfig where - getFeatureConfig _ = getTrivialConfigC "file_sharing" - setFeatureConfig _ tid statusNoLock = setFeatureStatusC "file_sharing" tid (wssStatus statusNoLock) - getFeatureLockStatus _ = getLockStatusC "file_sharing_lock_status" - setFeatureLockStatus _ = setLockStatusC "file_sharing_lock_status" - -instance FeatureStatusCassandra SelfDeletingMessagesConfig where - getFeatureConfig _ tid = runMaybeT $ do - (mEnabled, mTimeout) <- - MaybeT . retry x1 $ - query1 select (params LocalQuorum (Identity tid)) - maybe mzero pure $ - WithStatusNoLock - <$> mEnabled - <*> fmap SelfDeletingMessagesConfig mTimeout - <*> Just FeatureTTLUnlimited - where - select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe Int32) - select = - "select self_deleting_messages_status, self_deleting_messages_ttl\ - \ from team_features where team_id = ?" - - setFeatureConfig _ tid status = do - let statusValue = wssStatus status - timeout = sdmEnforcedTimeoutSeconds . wssConfig $ status - retry x5 $ write insert (params LocalQuorum (tid, statusValue, timeout)) - where - insert :: PrepQuery W (TeamId, FeatureStatus, Int32) () - insert = - "insert into team_features (team_id, self_deleting_messages_status,\ - \ self_deleting_messages_ttl) values (?, ?, ?)" - - getFeatureLockStatus _ = getLockStatusC "self_deleting_messages_lock_status" - setFeatureLockStatus _ = setLockStatusC "self_deleting_messages_lock_status" - -instance FeatureStatusCassandra ConferenceCallingConfig where - getFeatureConfig _ tid = do - let q = query1 select (params LocalQuorum (Identity tid)) - retry x1 q <&> \case - Nothing -> Nothing - Just (Nothing, _) -> Nothing - Just (Just status, mTtl) -> Just . forgetLock . setStatus status . setWsTTL (fromMaybe FeatureTTLUnlimited mTtl) $ defFeatureStatus - where - select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe FeatureTTL) - select = - fromString $ - "select conference_calling, ttl(conference_calling) from team_features where team_id = ?" - - setFeatureConfig _ tid statusNoLock = - retry x5 $ write insert (params LocalQuorum (tid, wssStatus statusNoLock)) - where - renderFeatureTtl :: FeatureTTL -> String - renderFeatureTtl = \case - FeatureTTLSeconds d | d > 0 -> " using ttl " <> show d - _ -> " using ttl 0" -- 0 or unlimited (delete a column's existing TTL by setting its value to zero) - insert :: PrepQuery W (TeamId, FeatureStatus) () - insert = - fromString $ - "insert into team_features (team_id,conference_calling) values (?, ?)" - <> renderFeatureTtl (wssTTL statusNoLock) - -instance FeatureStatusCassandra GuestLinksConfig where - getFeatureConfig _ = getTrivialConfigC "guest_links_status" - setFeatureConfig _ tid statusNoLock = setFeatureStatusC "guest_links_status" tid (wssStatus statusNoLock) - - getFeatureLockStatus _ = getLockStatusC "guest_links_lock_status" - setFeatureLockStatus _ = setLockStatusC "guest_links_lock_status" - -instance FeatureStatusCassandra SndFactorPasswordChallengeConfig where - getFeatureConfig _ = getTrivialConfigC "snd_factor_password_challenge_status" - setFeatureConfig _ tid statusNoLock = - setFeatureStatusC "snd_factor_password_challenge_status" tid (wssStatus statusNoLock) - - getFeatureLockStatus _ = getLockStatusC "snd_factor_password_challenge_lock_status" - setFeatureLockStatus _ = setLockStatusC "snd_factor_password_challenge_lock_status" - -instance FeatureStatusCassandra SearchVisibilityInboundConfig where - getFeatureConfig _ = getTrivialConfigC "search_visibility_status" - setFeatureConfig _ tid statusNoLock = setFeatureStatusC "search_visibility_status" tid (wssStatus statusNoLock) - -instance FeatureStatusCassandra MLSConfig where - getFeatureConfig _ tid = do - m <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure $ case m of - Nothing -> Nothing - Just (status, defaultProtocol, protocolToggleUsers, allowedCipherSuites, defaultCipherSuite) -> - WithStatusNoLock - <$> status - <*> ( MLSConfig - <$> maybe (Just []) (Just . C.fromSet) protocolToggleUsers - <*> defaultProtocol - <*> maybe (Just []) (Just . C.fromSet) allowedCipherSuites - <*> defaultCipherSuite - ) - <*> Just FeatureTTLUnlimited - where - select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe ProtocolTag, Maybe (C.Set UserId), Maybe (C.Set CipherSuiteTag), Maybe CipherSuiteTag) - select = - "select mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, \ - \mls_default_ciphersuite from team_features where team_id = ?" - - setFeatureConfig _ tid statusNoLock = do - let status = wssStatus statusNoLock - let MLSConfig protocolToggleUsers defaultProtocol allowedCipherSuites defaultCipherSuite = wssConfig statusNoLock - retry x5 $ - write - insert - ( params - LocalQuorum - ( tid, - status, - defaultProtocol, - C.Set protocolToggleUsers, - C.Set allowedCipherSuites, - defaultCipherSuite - ) - ) - where - insert :: PrepQuery W (TeamId, FeatureStatus, ProtocolTag, C.Set UserId, C.Set CipherSuiteTag, CipherSuiteTag) () - insert = - "insert into team_features (team_id, mls_status, mls_default_protocol, \ - \mls_protocol_toggle_users, mls_allowed_ciphersuites, mls_default_ciphersuite) values (?, ?, ?, ?, ?, ?)" - -instance FeatureStatusCassandra MlsE2EIdConfig where - getFeatureConfig _ tid = do - let q = query1 select (params LocalQuorum (Identity tid)) - retry x1 q <&> \case - Nothing -> Nothing - Just (Nothing, _, _) -> Nothing - Just (Just fs, mGracePeriod, mUrl) -> - Just $ - WithStatusNoLock - fs - (MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl) - FeatureTTLUnlimited - where - toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime - toGracePeriodOrDefault = maybe (verificationExpiration $ wsConfig defFeatureStatus) fromIntegral - - select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe Int32, Maybe HttpsUrl) - select = - fromString $ - "select mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url from team_features where team_id = ?" - - setFeatureConfig _ tid status = do - let statusValue = wssStatus status - vex = verificationExpiration . wssConfig $ status - mUrl = acmeDiscoveryUrl . wssConfig $ status - retry x5 $ write insert (params LocalQuorum (tid, statusValue, truncate vex, mUrl)) - where - insert :: PrepQuery W (TeamId, FeatureStatus, Int32, Maybe HttpsUrl) () - insert = - "insert into team_features (team_id, mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url) values (?, ?, ?, ?)" - - getFeatureLockStatus _ = getLockStatusC "mls_e2eid_lock_status" - setFeatureLockStatus _ = setLockStatusC "mls_e2eid_lock_status" - -instance FeatureStatusCassandra ExposeInvitationURLsToTeamAdminConfig where - getFeatureConfig _ = getTrivialConfigC "expose_invitation_urls_to_team_admin" - setFeatureConfig _ tid statusNoLock = setFeatureStatusC "expose_invitation_urls_to_team_admin" tid (wssStatus statusNoLock) - -instance FeatureStatusCassandra OutlookCalIntegrationConfig where - getFeatureConfig _ = getTrivialConfigC "outlook_cal_integration_status" - setFeatureConfig _ tid statusNoLock = setFeatureStatusC "outlook_cal_integration_status" tid (wssStatus statusNoLock) - - getFeatureLockStatus _ = getLockStatusC "outlook_cal_integration_lock_status" - setFeatureLockStatus _ = setLockStatusC "outlook_cal_integration_lock_status" diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 099dfb747c..61fe40bd02 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -64,7 +64,6 @@ where import Data.Id import Data.Qualified import Data.Time.Clock -import Galley.Cassandra.TeamFeatures (Cassandra) import Galley.Effects.BotAccess import Galley.Effects.BrigAccess import Galley.Effects.ClientStore @@ -121,7 +120,7 @@ type GalleyEffects1 = MemberStore, SearchVisibilityStore, ServiceStore, - TeamFeatureStore Cassandra, + TeamFeatureStore, TeamNotificationStore, TeamStore, TeamMemberStore InternalPaging, diff --git a/services/galley/src/Galley/Effects/TeamFeatureStore.hs b/services/galley/src/Galley/Effects/TeamFeatureStore.hs index 86ea0ed352..13a43eea34 100644 --- a/services/galley/src/Galley/Effects/TeamFeatureStore.hs +++ b/services/galley/src/Galley/Effects/TeamFeatureStore.hs @@ -19,7 +19,6 @@ module Galley.Effects.TeamFeatureStore ( TeamFeatureStore (..), - FeaturePersistentConstraint, getFeatureConfig, getFeatureConfigMulti, setFeatureConfig, @@ -29,42 +28,32 @@ module Galley.Effects.TeamFeatureStore where import Data.Id -import Data.Kind -import Data.Proxy import Imports import Polysemy import Wire.API.Team.Feature -type family FeaturePersistentConstraint db :: Type -> Constraint - -data TeamFeatureStore db m a where - -- the proxy argument makes sure that makeSem below generates type-inference-friendly code +data TeamFeatureStore m a where GetFeatureConfig :: - FeaturePersistentConstraint db cfg => - Proxy cfg -> + FeatureSingleton cfg -> TeamId -> - TeamFeatureStore db m (Maybe (WithStatusNoLock cfg)) + TeamFeatureStore m (Maybe (WithStatusNoLock cfg)) GetFeatureConfigMulti :: - FeaturePersistentConstraint db cfg => - Proxy cfg -> + FeatureSingleton cfg -> [TeamId] -> - TeamFeatureStore db m [(TeamId, Maybe (WithStatusNoLock cfg))] + TeamFeatureStore m [(TeamId, Maybe (WithStatusNoLock cfg))] SetFeatureConfig :: - FeaturePersistentConstraint db cfg => - Proxy cfg -> + FeatureSingleton cfg -> TeamId -> WithStatusNoLock cfg -> - TeamFeatureStore db m () + TeamFeatureStore m () GetFeatureLockStatus :: - FeaturePersistentConstraint db cfg => - Proxy cfg -> + FeatureSingleton cfg -> TeamId -> - TeamFeatureStore db m (Maybe LockStatus) + TeamFeatureStore m (Maybe LockStatus) SetFeatureLockStatus :: - FeaturePersistentConstraint db cfg => - Proxy cfg -> + FeatureSingleton cfg -> TeamId -> LockStatus -> - TeamFeatureStore db m () + TeamFeatureStore m () makeSem ''TeamFeatureStore diff --git a/services/galley/src/Galley/Types/UserList.hs b/services/galley/src/Galley/Types/UserList.hs index a4565da2c1..3dbc81444d 100644 --- a/services/galley/src/Galley/Types/UserList.hs +++ b/services/galley/src/Galley/Types/UserList.hs @@ -22,6 +22,7 @@ module Galley.Types.UserList ulAll, ulFromLocals, ulFromRemotes, + ulDiff, ) where @@ -56,3 +57,10 @@ ulFromLocals = flip UserList [] ulFromRemotes :: [Remote a] -> UserList a ulFromRemotes = UserList [] + +-- | Remove from the first list all the users that are in the second list. +ulDiff :: Eq a => UserList a -> UserList a -> UserList a +ulDiff (UserList lA rA) (UserList lB rB) = + UserList + (filter (`notElem` lB) lA) + (filter (`notElem` rB) rA) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index fd179818c6..313dadc893 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -203,6 +203,7 @@ tests s = test s "rename conversation" putConvRenameOk, test s "rename qualified conversation" putQualifiedConvRenameOk, test s "rename qualified conversation with remote members" putQualifiedConvRenameWithRemotesOk, + test s "rename qualified conversation with unavailable remote" putQualifiedConvRenameWithRemotesUnavailable, test s "rename qualified conversation failure" putQualifiedConvRenameFailure, test s "other member update role" putOtherMemberOk, test s "qualified other member update role" putQualifiedOtherMemberOk, @@ -216,6 +217,7 @@ tests s = test s "remote conversation member update (everything)" putRemoteConvMemberAllOk, test s "conversation receipt mode update" putReceiptModeOk, test s "conversation receipt mode update with remote members" putReceiptModeWithRemotesOk, + test s "conversation receipt mode update with unavailable remote members" putReceiptModeWithRemotesUnavailable, test s "remote conversation receipt mode update" putRemoteReceiptModeOk, test s "leave connect conversation" leaveConnectConversation, test s "post conversations/:cnv/otr/message: message delivery and missing clients" postCryptoMessageVerifyMsgSentAndRejectIfMissingClient, @@ -238,6 +240,7 @@ tests s = test s "convert invite to code-access conversation" postConvertCodeConv, test s "convert code to team-access conversation" postConvertTeamConv, test s "local and remote guests are removed when access changes" testAccessUpdateGuestRemoved, + test s "local and remote guests are removed when access changes remotes unavailable" testAccessUpdateGuestRemovedRemotesUnavailable, test s "team member can't join via guest link if access role removed" testTeamMemberCantJoinViaGuestLinkIfAccessRoleRemoved, test s "cannot join private conversation" postJoinConvFail, test s "revoke guest links for team conversation" testJoinTeamConvGuestLinksDisabled, @@ -1846,6 +1849,90 @@ testAccessUpdateGuestRemoved = do -- @END +testAccessUpdateGuestRemovedRemotesUnavailable :: TestM () +testAccessUpdateGuestRemovedRemotesUnavailable = do + -- alice, bob are in a team + (tid, alice, [bob]) <- createBindingTeamWithQualifiedMembers 2 + + -- charlie is a local guest + charlie <- randomQualifiedUser + connectUsers (qUnqualified alice) (pure (qUnqualified charlie)) + + -- dee is a remote guest + let remoteDomain = Domain "far-away.example.com" + dee <- Qualified <$> randomId <*> pure remoteDomain + + connectWithRemoteUser (qUnqualified alice) dee + + -- they are all in a local conversation + conv <- + responseJsonError + =<< postConvWithRemoteUsers + (qUnqualified alice) + Nothing + defNewProteusConv + { newConvQualifiedUsers = [bob, charlie, dee], + newConvTeam = Just (ConvTeamInfo tid) + } + do + -- conversation access role changes to team only + (_, reqs) <- withTempMockFederator' (throw $ MockErrorResponse HTTP.status503 "Down for maintenance") $ do + -- This request should still succeed even with an unresponsive federation member. + putQualifiedAccessUpdate + (qUnqualified alice) + (cnvQualifiedId conv) + (ConversationAccessData mempty (Set.fromList [TeamMemberAccessRole])) + !!! const 200 === statusCode + -- charlie and dee are kicked out + -- + -- note that removing users happens asynchronously, so this check should + -- happen while the mock federator is still available + WS.assertMatchN_ (5 # Second) [wsA, wsB, wsC] $ + wsAssertMembersLeave (cnvQualifiedId conv) alice [charlie] + WS.assertMatchN_ (5 # Second) [wsA, wsB, wsC] $ + wsAssertMembersLeave (cnvQualifiedId conv) alice [dee] + + let compareLists [] ys = [] @?= ys + compareLists (x : xs) ys = case break (== x) ys of + (ys1, _ : ys2) -> compareLists xs (ys1 <> ys2) + _ -> assertFailure $ "Could not find " <> show x <> " in " <> show ys + liftIO $ + compareLists + ( map + ( \fr -> do + cu <- eitherDecode (frBody fr) + pure (F.cuOrigUserId cu, F.cuAction cu) + ) + ( filter + ( \fr -> + frComponent fr == Galley + && frRPC fr == "on-conversation-updated" + ) + reqs + ) + ) + [ Right (alice, SomeConversationAction (sing @'ConversationRemoveMembersTag) (pure charlie)), + Right (alice, SomeConversationAction (sing @'ConversationRemoveMembersTag) (pure dee)), + Right + ( alice, + SomeConversationAction + (sing @'ConversationAccessDataTag) + ConversationAccessData + { cupAccess = mempty, + cupAccessRoles = Set.fromList [TeamMemberAccessRole] + } + ) + ] + -- only alice and bob remain + conv2 <- + responseJsonError + =<< getConvQualified (qUnqualified alice) (cnvQualifiedId conv) + postConv alice [] (Just "remote gossip") [] Nothing Nothing let qconvId = Qualified convId localDomain - postQualifiedMembers alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 403 === statusCode const (Right (Just "not-connected")) === fmap (view (at "label")) . responseJsonEither @Object @@ -2662,7 +2749,7 @@ testAddRemoteMember = do (resp, reqs) <- withTempMockFederator' (respond remoteBob) $ - postQualifiedMembers alice (remoteBob :| []) convId + postQualifiedMembers alice (remoteBob :| []) qconvId postTeamConv tid alice [] (Just "remote gossip") [] Nothing Nothing - let _qconvId = Qualified convId localDomain + let qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob @@ -2708,7 +2795,7 @@ testDeleteTeamConversationWithRemoteMembers = do ("on-new-remote-conversation" ~> EmptyResponse) <|> ("on-conversation-updated" ~> ()) (_, received) <- withTempMockFederator' mock $ do - postQualifiedMembers alice (remoteBob :| []) convId + postQualifiedMembers alice (remoteBob :| []) qconvId !!! const 200 === statusCode deleteTeamConv tid convId alice @@ -2734,6 +2821,7 @@ testDeleteTeamConversationWithUnavailableRemoteMembers = do remoteBob = Qualified bobId remoteDomain convId <- decodeConvId <$> postTeamConv tid alice [] (Just "remote gossip") [] Nothing Nothing + let qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob @@ -2743,11 +2831,11 @@ testDeleteTeamConversationWithUnavailableRemoteMembers = do <|> (guardRPC "on-conversation-updated" *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")) <|> (guardRPC "delete-team-conversation" *> throw (MockErrorResponse HTTP.status503 "Down for maintenance.")) (_, received) <- withTempMockFederator' mock $ do - postQualifiedMembers alice (remoteBob :| []) convId - !!! const 503 === statusCode + postQualifiedMembers alice (remoteBob :| []) qconvId + !!! const 200 === statusCode deleteTeamConv tid convId alice - !!! const 503 === statusCode + !!! const 200 === statusCode liftIO $ do let convUpdates = mapMaybe (eitherToMaybe . parseFedRequest) received convUpdate <- case filter ((== SomeConversationAction (sing @'ConversationDeleteTag) ()) . cuAction) convUpdates of @@ -2964,10 +3052,12 @@ testAddRemoteMemberInvalidDomain = do bobId <- randomId let remoteBob = Qualified bobId (Domain "invalid.example.com") convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing + localDomain <- viewFederationDomain + let qconvId = Qualified convId localDomain connectWithRemoteUser alice remoteBob - postQualifiedMembers alice (remoteBob :| []) convId + postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 422 === statusCode const (Just "/federation/api-version") @@ -2982,14 +3072,13 @@ testAddRemoteMemberFederationDisabled = do alice <- randomUser remoteBob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId qconvId <- decodeQualifiedConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing - let convId = qUnqualified qconvId connectWithRemoteUser alice remoteBob -- federator endpoint not configured is equivalent to federation being disabled -- This is the case on staging/production in May 2021. let federatorNotConfigured = optFederator .~ Nothing withSettingsOverrides federatorNotConfigured $ - postQualifiedMembers alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 400 === statusCode const (Right "federation-not-enabled") === fmap label . responseJsonEither @@ -3002,7 +3091,6 @@ testAddRemoteMemberFederationUnavailable = do alice <- randomUser remoteBob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId qconvId <- decodeQualifiedConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing - let convId = qUnqualified qconvId connectWithRemoteUser alice remoteBob -- federator endpoint being configured in brig and/or galley, but not being @@ -3011,7 +3099,7 @@ testAddRemoteMemberFederationUnavailable = do -- Port 1 should always be wrong hopefully. let federatorUnavailable = optFederator ?~ Endpoint "127.0.0.1" 1 withSettingsOverrides federatorUnavailable $ - postQualifiedMembers alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 500 === statusCode const (Right "federation-not-available") === fmap label . responseJsonEither @@ -3350,7 +3438,7 @@ leaveRemoteConvQualifiedOk = do qBob = Qualified bob remoteDomain let mockedFederatedGalleyResponse = do guardComponent Galley - mockReply (F.LeaveConversationResponse (Right ())) + mockReply (F.LeaveConversationResponse (Right mempty)) mockResponses = mockedFederatedBrigResponse [(qBob, "Bob")] <|> mockedFederatedGalleyResponse @@ -3539,6 +3627,46 @@ putQualifiedConvRenameWithRemotesOk = do evtFrom e @?= qbob evtData e @?= EdConvRename (ConversationRename "gossip++") +putQualifiedConvRenameWithRemotesUnavailable :: TestM () +putQualifiedConvRenameWithRemotesUnavailable = do + c <- view tsCannon + let remoteDomain = Domain "alice.example.com" + qalice <- Qualified <$> randomId <*> pure remoteDomain + qbob <- randomQualifiedUser + let bob = qUnqualified qbob + + connectWithRemoteUser bob qalice + + resp <- + postConvWithRemoteUsers + bob + Nothing + defNewProteusConv {newConvQualifiedUsers = [qalice]} + do + (_, requests) <- + withTempMockFederator' (throw $ MockErrorResponse HTTP.status503 "Down for maintenance") $ + putQualifiedConversationName bob qconv "gossip++" !!! const 200 === statusCode + + req <- assertOne requests + liftIO $ do + frTargetDomain req @?= remoteDomain + frComponent req @?= Galley + frRPC req @?= "on-conversation-updated" + Right cu <- pure . eitherDecode . frBody $ req + F.cuConvId cu @?= qUnqualified qconv + F.cuAction cu @?= SomeConversationAction (sing @'ConversationRenameTag) (ConversationRename "gossip++") + + void . liftIO . WS.assertMatch (5 # Second) wsB $ \n -> do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= qconv + evtType e @?= ConvRename + evtFrom e @?= qbob + evtData e @?= EdConvRename (ConversationRename "gossip++") + putConvDeprecatedRenameOk :: TestM () putConvDeprecatedRenameOk = do c <- view tsCannon @@ -3963,7 +4091,7 @@ putRemoteReceiptModeOk = do cuAction = SomeConversationAction (sing @'ConversationReceiptModeUpdateTag) action } - let mockResponse = mockReply (ConversationUpdateResponseUpdate responseConvUpdate) + let mockResponse = mockReply (ConversationUpdateResponseUpdate responseConvUpdate mempty) WS.bracketR c adam $ \wsAdam -> do (res, federatedRequests) <- withTempMockFederator' mockResponse $ do @@ -4027,6 +4155,48 @@ putReceiptModeWithRemotesOk = do @?= EdConvReceiptModeUpdate (ConversationReceiptModeUpdate (ReceiptMode 43)) +putReceiptModeWithRemotesUnavailable :: TestM () +putReceiptModeWithRemotesUnavailable = do + c <- view tsCannon + let remoteDomain = Domain "alice.example.com" + qalice <- Qualified <$> randomId <*> pure remoteDomain + qbob <- randomQualifiedUser + let bob = qUnqualified qbob + + connectWithRemoteUser bob qalice + + resp <- + postConvWithRemoteUsers + bob + Nothing + defNewProteusConv {newConvQualifiedUsers = [qalice]} + let qconv = decodeQualifiedConvId resp + + WS.bracketR c bob $ \wsB -> do + (_, requests) <- + withTempMockFederator' (throw $ MockErrorResponse HTTP.status503 "Down for maintenance") $ + putQualifiedReceiptMode bob qconv (ReceiptMode 43) !!! const 200 === statusCode + + req <- assertOne requests + liftIO $ do + frTargetDomain req @?= remoteDomain + frComponent req @?= Galley + frRPC req @?= "on-conversation-updated" + Right cu <- pure . eitherDecode . frBody $ req + F.cuConvId cu @?= qUnqualified qconv + F.cuAction cu + @?= SomeConversationAction (sing @'ConversationReceiptModeUpdateTag) (ConversationReceiptModeUpdate (ReceiptMode 43)) + + void . liftIO . WS.assertMatch (5 # Second) wsB $ \n -> do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= qconv + evtType e @?= ConvReceiptModeUpdate + evtFrom e @?= qbob + evtData e + @?= EdConvReceiptModeUpdate + (ConversationReceiptModeUpdate (ReceiptMode 43)) + postTypingIndicatorsV2 :: TestM () postTypingIndicatorsV2 = do c <- view tsCannon @@ -4239,7 +4409,7 @@ removeUser = do do guard (d `elem` [bDomain, cDomain]) asum - [ "leave-conversation" ~> F.LeaveConversationResponse (Right ()), + [ "leave-conversation" ~> F.LeaveConversationResponse (Right mempty), "on-conversation-updated" ~> () ] ] diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index f05cfe537e..d65fa2d10e 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -21,6 +21,7 @@ module API.Federation where import API.Util import Bilge hiding (head) import Bilge.Assert +import Control.Exception import Control.Lens hiding ((#)) import qualified Data.Aeson as A import Data.ByteString.Conversion (toByteString') @@ -42,6 +43,7 @@ import Data.Timeout (TimeoutUnit (..), (#)) import Data.UUID.V4 (nextRandom) import Federator.MockServer import Imports +import qualified Network.HTTP.Types as Http import Test.QuickCheck (arbitrary, generate) import Test.Tasty import qualified Test.Tasty.Cannon as WS @@ -86,7 +88,11 @@ tests s = test s "POST /federation/on-message-sent : Receive a message from another backend" onMessageSent, test s "POST /federation/send-message : Post a message sent from another backend" sendMessage, test s "POST /federation/on-user-deleted-conversations : Remove deleted remote user from local conversations" onUserDeleted, - test s "POST /federation/update-conversation : Update local conversation by a remote admin " updateConversationByRemoteAdmin + test s "POST /federation/update-conversation : Update local conversation by a remote admin " updateConversationByRemoteAdmin, + test s "POST /federation/on-conversation-updated : Notify local user about conversation rename with an unavailable federator" notifyConvRenameUnavailable, + test s "POST /federation/on-conversation-updated : Notify local user about message timer update with an unavailable federator" notifyMessageTimerUnavailable, + test s "POST /federation/on-conversation-updated : Notify local user about receipt mode update with an unavailable federator" notifyReceiptModeUnavailable, + test s "POST /federation/on-conversation-updated : Notify local user about access update with an unavailable federator" notifyAccessUnavailable ] getConversationsAllFound :: TestM () @@ -473,6 +479,50 @@ notifyUpdate extras action etype edata = do evtData e @?= edata WS.assertNoEvent (1 # Second) [wsC] +notifyUpdateUnavailable :: [Qualified UserId] -> SomeConversationAction -> EventType -> EventData -> TestM () +notifyUpdateUnavailable extras action etype edata = do + c <- view tsCannon + qalice <- randomQualifiedUser + let alice = qUnqualified qalice + bob <- randomId + charlie <- randomUser + conv <- randomId + let bdom = Domain "bob.example.com" + qbob = Qualified bob bdom + qconv = Qualified conv bdom + mkMember quid = OtherMember quid Nothing roleNameWireMember + fedGalleyClient <- view tsFedGalleyClient + + connectWithRemoteUser alice qbob + registerRemoteConv + qconv + bob + (Just "gossip") + (Set.fromList (map mkMember (qalice : extras))) + + now <- liftIO getCurrentTime + let cu = + FedGalley.ConversationUpdate + { FedGalley.cuTime = now, + FedGalley.cuOrigUserId = qbob, + FedGalley.cuConvId = conv, + FedGalley.cuAlreadyPresentUsers = [alice, charlie], + FedGalley.cuAction = action + } + WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do + ((), _fedRequests) <- + withTempMockFederator' (throw $ MockErrorResponse Http.status500 "Down for maintenance") $ + runFedClient @"on-conversation-updated" fedGalleyClient bdom cu + liftIO $ do + WS.assertMatch_ (5 # Second) wsA $ \n -> do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= qconv + evtType e @?= etype + evtFrom e @?= qbob + evtData e @?= edata + WS.assertNoEvent (1 # Second) [wsC] + notifyConvRename :: TestM () notifyConvRename = do let d = ConversationRename "gossip++" @@ -505,6 +555,38 @@ notifyAccess = do ConvAccessUpdate (EdConvAccessUpdate d) +notifyConvRenameUnavailable :: TestM () +notifyConvRenameUnavailable = do + let d = ConversationRename "gossip++" + notifyUpdateUnavailable [] (SomeConversationAction (sing @'ConversationRenameTag) d) ConvRename (EdConvRename d) + +notifyMessageTimerUnavailable :: TestM () +notifyMessageTimerUnavailable = do + let d = ConversationMessageTimerUpdate (Just 5000) + notifyUpdateUnavailable + [] + (SomeConversationAction (sing @'ConversationMessageTimerUpdateTag) d) + ConvMessageTimerUpdate + (EdConvMessageTimerUpdate d) + +notifyReceiptModeUnavailable :: TestM () +notifyReceiptModeUnavailable = do + let d = ConversationReceiptModeUpdate (ReceiptMode 42) + notifyUpdateUnavailable + [] + (SomeConversationAction (sing @'ConversationReceiptModeUpdateTag) d) + ConvReceiptModeUpdate + (EdConvReceiptModeUpdate d) + +notifyAccessUnavailable :: TestM () +notifyAccessUnavailable = do + let d = ConversationAccessData (Set.fromList [InviteAccess, LinkAccess]) (Set.fromList [TeamMemberAccessRole]) + notifyUpdateUnavailable + [] + (SomeConversationAction (sing @'ConversationAccessDataTag) d) + ConvAccessUpdate + (EdConvAccessUpdate d) + notifyMemberUpdate :: TestM () notifyMemberUpdate = do qdee <- randomQualifiedUser @@ -680,7 +762,7 @@ leaveConversationSuccess = do assertFailure ("Expected ConversationUpdateResponseUpdate but got " <> show err) ConversationUpdateResponseNoChanges -> assertFailure "Expected ConversationUpdateResponseUpdate but got ConversationUpdateResponseNoChanges" - ConversationUpdateResponseUpdate up -> pure up + ConversationUpdateResponseUpdate up _ftp -> pure up liftIO $ do cuOrigUserId cnvUpdate' @?= qbob diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 970378798e..7e8fc92ba2 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -25,7 +25,6 @@ import API.Util import Bilge hiding (empty, head) import Bilge.Assert import Cassandra hiding (Set) -import Control.Exception (throw) import Control.Lens (view) import Control.Lens.Extras import qualified Control.Monad.State as State @@ -48,7 +47,6 @@ import qualified Data.Text as T import Data.Time import Federator.MockServer hiding (withTempMockFederator) import Imports -import qualified Network.HTTP.Types.Status as HTTP import qualified Network.Wai.Utilities.Error as Wai import Test.Tasty import Test.Tasty.Cannon (TimeoutUnit (Second), (#)) @@ -67,13 +65,13 @@ import Wire.API.Federation.API.Galley import Wire.API.MLS.CipherSuite import Wire.API.MLS.Credential import Wire.API.MLS.Keys -import Wire.API.MLS.Message import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation import Wire.API.MLS.Welcome import Wire.API.Message import Wire.API.Routes.MultiTablePaging import Wire.API.Routes.Version +import Wire.API.Unreachable import Wire.API.User.Client tests :: IO TestSetup -> TestTree @@ -1175,12 +1173,11 @@ testAppMessage2 = do testAppMessageSomeReachable :: TestM () testAppMessageSomeReachable = do + let bobDomain = Domain "bob.example.com" + charlieDomain = Domain "charlie.example.com" users@[_alice, bob, charlie] <- - createAndConnectUsers - [ Nothing, - Just "bob.example.com", - Just "charlie.example.com" - ] + createAndConnectUsers $ + domainText <$$> [Nothing, Just bobDomain, Just charlieDomain] void $ runMLSTest $ do [alice1, bob1, charlie1] <- @@ -1189,27 +1186,25 @@ testAppMessageSomeReachable = do void $ setupMLSGroup alice1 commit <- createAddCommit alice1 [bob, charlie] - let mocks = + let commitMocks = receiveCommitMockByDomain [bob1, charlie1] <|> welcomeMock - ([event], _) <- - withTempMockFederator' mocks $ do - sendAndConsumeCommit commit + (([event], ftpCommit), _) <- + withTempMockFederator' commitMocks $ do + sendAndConsumeCommitFederated commit + liftIO $ ftpCommit @?= mempty let unreachables = Set.singleton (Domain "charlie.example.com") - withTempMockFederator' (mockUnreachableFor unreachables) $ do + let sendMocks = + messageSentMockByDomain [bobDomain] + <|> mlsMockUnreachableFor unreachables + + withTempMockFederator' sendMocks $ do message <- createApplicationMessage alice1 "hi, bob!" - (_, us) <- sendAndConsumeMessage message + (_, ftp) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - us @?= UnreachableUsers [charlie] - where - mockUnreachableFor :: Set Domain -> Mock LByteString - mockUnreachableFor backends = do - r <- getRequest - if Set.member (frTargetDomain r) backends - then throw (MockErrorResponse HTTP.status503 "Down for maintenance.") - else mockReply ("RemoteMLSMessageOk" :: String) + ftp @?= unreachableFromList [charlie] testAppMessageUnreachable :: TestM () testAppMessageUnreachable = do @@ -1228,10 +1223,10 @@ testAppMessageUnreachable = do sendAndConsumeCommit commit message <- createApplicationMessage alice1 "hi, bob!" - (_, us) <- sendAndConsumeMessage message + (_, ftp) <- sendAndConsumeMessage message liftIO $ do assertBool "Event should be member join" $ is _EdMembersJoin (evtData event) - us @?= UnreachableUsers [bob] + ftp @?= unreachableFromList [bob] testRemoteToRemote :: TestM () testRemoteToRemote = do @@ -2194,7 +2189,7 @@ testAddUserToRemoteConvWithBundle = do commit <- createAddCommit bob1 [charlie] commitBundle <- createBundle commit - let mock = "send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUsers []) + let mock = "send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] mempty (_, reqs) <- withTempMockFederator' mock $ do void $ sendAndConsumeCommitBundle commit @@ -2596,7 +2591,7 @@ testJoinRemoteSubConv = do -- bob joins subconversation let pgs = mpPublicGroupState initialCommit let mock = - ("send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUsers [])) + ("send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] Nothing) <|> queryGroupStateMock (fold pgs) bob <|> sendMessageMock (_, reqs) <- withTempMockFederator' mock $ do @@ -3076,7 +3071,7 @@ testDeleteRemoteParentOfSubConv = do let pgs = mpPublicGroupState initialCommit let mock = - ("send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUsers [])) + ("send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] Nothing) <|> queryGroupStateMock (fold pgs) bob <|> sendMessageMock void $ withTempMockFederator' mock $ do @@ -3346,7 +3341,7 @@ testLeaveRemoteSubConv = do let pgs = mpPublicGroupState initialCommit let mock = - ("send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] (UnreachableUsers [])) + ("send-mls-commit-bundle" ~> MLSMessageResponseUpdates [] Nothing) <|> queryGroupStateMock (fold pgs) bob <|> sendMessageMock <|> ("leave-sub-conversation" ~> LeaveSubConversationResponseOk) diff --git a/services/galley/test/integration/API/MLS/Mocks.hs b/services/galley/test/integration/API/MLS/Mocks.hs index 79d92f32ff..5e816bb9d3 100644 --- a/services/galley/test/integration/API/MLS/Mocks.hs +++ b/services/galley/test/integration/API/MLS/Mocks.hs @@ -19,14 +19,18 @@ module API.MLS.Mocks ( receiveCommitMock, receiveCommitMockByDomain, messageSentMock, + messageSentMockByDomain, welcomeMock, + welcomeMockByDomain, sendMessageMock, claimKeyPackagesMock, queryGroupStateMock, deleteMLSConvMock, + mlsMockUnreachableFor, ) where +import Data.Domain import Data.Id import Data.Json.Util import Data.Qualified @@ -38,7 +42,6 @@ import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage -import Wire.API.MLS.Message import Wire.API.User.Client receiveCommitMock :: [ClientIdentity] -> Mock LByteString @@ -55,29 +58,35 @@ receiveCommitMock clients = receiveCommitMockByDomain :: [ClientIdentity] -> Mock LByteString receiveCommitMockByDomain clients = do - r <- getRequest - let fClients = filter (\c -> frTargetDomain r == ciDomain c) clients - asum - [ "on-conversation-updated" ~> (), - "on-new-remote-conversation" ~> EmptyResponse, - "get-mls-clients" ~> - Set.fromList - ( map (flip ClientInfo True . ciClient) fClients - ) - ] + domain <- frTargetDomain <$> getRequest + guard (domain `elem` (ciDomain <$> clients)) + let fClients = filter (\c -> domain == ciDomain c) clients + receiveCommitMock fClients messageSentMock :: Mock LByteString messageSentMock = "on-mls-message-sent" ~> RemoteMLSMessageOk +messageSentMockByDomain :: [Domain] -> Mock LByteString +messageSentMockByDomain reachables = do + domain <- frTargetDomain <$> getRequest + guard (domain `elem` reachables) + messageSentMock + welcomeMock :: Mock LByteString welcomeMock = "mls-welcome" ~> MLSWelcomeSent +welcomeMockByDomain :: [Domain] -> Mock LByteString +welcomeMockByDomain reachables = do + domain <- frTargetDomain <$> getRequest + guard (domain `elem` reachables) + welcomeMock + sendMessageMock :: Mock LByteString sendMessageMock = "send-mls-message" ~> MLSMessageResponseUpdates [] - (UnreachableUsers []) + mempty claimKeyPackagesMock :: KeyPackageBundle -> Mock LByteString claimKeyPackagesMock kpb = "claim-key-packages" ~> kpb @@ -98,3 +107,6 @@ deleteMLSConvMock = "on-new-remote-subconversation" ~> EmptyResponse, "on-conversation-updated" ~> EmptyResponse ] + +mlsMockUnreachableFor :: Set Domain -> Mock LByteString +mlsMockUnreachableFor = mockUnreachableFor "RemoteMLSMessageOk" diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index bb59cb8cdb..69177fe68d 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -82,6 +82,7 @@ import Wire.API.MLS.Message import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation import Wire.API.MLS.SubConversation +import Wire.API.Unreachable import Wire.API.User.Client import Wire.API.User.Client.Prekey @@ -926,7 +927,7 @@ consumeMessage1 cid msg = do -- | Send an MLS message and simulate clients receiving it. If the message is a -- commit, the 'sendAndConsumeCommit' function should be used instead. -sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], UnreachableUsers) +sendAndConsumeMessage :: HasCallStack => MessagePackage -> MLSTest ([Event], Maybe UnreachableUsers) sendAndConsumeMessage mp = do res <- fmap (mmssEvents Tuple.&&& mmssUnreachableUsers) $ @@ -948,8 +949,17 @@ sendAndConsumeCommit :: HasCallStack => MessagePackage -> MLSTest [Event] -sendAndConsumeCommit mp = do - (events, _) <- sendAndConsumeMessage mp +sendAndConsumeCommit = fmap fst . sendAndConsumeCommitFederated + +-- | Send an MLS commit message, simulate clients receiving it, and update the +-- test state accordingly. Also return lists of federated users that a message +-- could not be sent to. +sendAndConsumeCommitFederated :: + HasCallStack => + MessagePackage -> + MLSTest ([Event], Maybe UnreachableUsers) +sendAndConsumeCommitFederated mp = do + resp <- sendAndConsumeMessage mp -- increment epoch and add new clients State.modify $ \mls -> @@ -959,7 +969,7 @@ sendAndConsumeCommit mp = do mlsNewMembers = mempty } - pure events + pure resp mkBundle :: MessagePackage -> Either Text CommitBundle mkBundle mp = do diff --git a/services/galley/test/integration/API/MessageTimer.hs b/services/galley/test/integration/API/MessageTimer.hs index d1354b1e0a..696fcb7d5f 100644 --- a/services/galley/test/integration/API/MessageTimer.hs +++ b/services/galley/test/integration/API/MessageTimer.hs @@ -23,6 +23,7 @@ where import API.Util import Bilge hiding (timeout) import Bilge.Assert +import Control.Exception import Control.Lens (view) import Data.Aeson (eitherDecode) import Data.Domain @@ -34,6 +35,7 @@ import Data.Qualified import Data.Singletons import Federator.MockServer import Imports hiding (head) +import qualified Network.HTTP.Types as Http import Network.Wai.Utilities.Error import Test.Tasty import Test.Tasty.Cannon (TimeoutUnit (..), (#)) @@ -61,6 +63,7 @@ tests s = test s "timer can be changed" messageTimerChange, test s "timer can be changed with the qualified endpoint" messageTimerChangeQualified, test s "timer changes are propagated to remote users" messageTimerChangeWithRemotes, + test s "timer changes unavailable remotes" messageTimerUnavailableRemotes, test s "timer can't be set by conv member without allowed action" messageTimerChangeWithoutAllowedAction, test s "timer can't be set in 1:1 conversations" messageTimerChangeO2O, test s "setting the timer generates an event" messageTimerEvent @@ -179,6 +182,46 @@ messageTimerChangeWithRemotes = do evtFrom e @?= qbob evtData e @?= EdConvMessageTimerUpdate (ConversationMessageTimerUpdate timer1sec) +messageTimerUnavailableRemotes :: TestM () +messageTimerUnavailableRemotes = do + c <- view tsCannon + let remoteDomain = Domain "alice.example.com" + qalice <- Qualified <$> randomId <*> pure remoteDomain + qbob <- randomQualifiedUser + let bob = qUnqualified qbob + connectWithRemoteUser bob qalice + + resp <- + postConvWithRemoteUsers + bob + Nothing + defNewProteusConv {newConvQualifiedUsers = [qalice]} + let qconv = decodeQualifiedConvId resp + + WS.bracketR c bob $ \wsB -> do + (_, requests) <- + withTempMockFederator' (throw $ MockErrorResponse Http.status503 "Down for maintenance") $ + putMessageTimerUpdateQualified bob qconv (ConversationMessageTimerUpdate timer1sec) + !!! const 200 === statusCode + + req <- assertOne requests + liftIO $ do + frTargetDomain req @?= remoteDomain + frComponent req @?= Galley + frRPC req @?= "on-conversation-updated" + Right cu <- pure . eitherDecode . frBody $ req + F.cuConvId cu @?= qUnqualified qconv + F.cuAction cu + @?= SomeConversationAction (sing @'ConversationMessageTimerUpdateTag) (ConversationMessageTimerUpdate timer1sec) + + void . liftIO . WS.assertMatch (5 # Second) wsB $ \n -> do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= qconv + evtType e @?= ConvMessageTimerUpdate + evtFrom e @?= qbob + evtData e @?= EdConvMessageTimerUpdate (ConversationMessageTimerUpdate timer1sec) + messageTimerChangeWithoutAllowedAction :: TestM () messageTimerChangeWithoutAllowedAction = do -- Create a team and a guest user diff --git a/services/galley/test/integration/API/Roles.hs b/services/galley/test/integration/API/Roles.hs index 5b9847cefc..2eabd8deb9 100644 --- a/services/galley/test/integration/API/Roles.hs +++ b/services/galley/test/integration/API/Roles.hs @@ -20,6 +20,7 @@ module API.Roles where import API.Util import Bilge hiding (timeout) import Bilge.Assert +import Control.Exception import Control.Lens (view) import Data.Aeson hiding (json) import Data.ByteString.Conversion (toByteString') @@ -32,6 +33,7 @@ import qualified Data.Set as Set import Data.Singletons import Federator.MockServer import Imports +import qualified Network.HTTP.Types as Http import Network.Wai.Utilities.Error import Test.Tasty import Test.Tasty.Cannon (TimeoutUnit (..), (#)) @@ -54,6 +56,7 @@ tests s = [ test s "conversation roles admin (and downgrade)" handleConversationRoleAdmin, test s "conversation roles member (and upgrade)" handleConversationRoleMember, test s "conversation role update with remote users present" roleUpdateWithRemotes, + test s "conversation role update with remote users present remotes unavailable" roleUpdateWithRemotesUnavailable, test s "conversation access update with remote users present" accessUpdateWithRemotes, test s "conversation role update of remote member" roleUpdateRemoteMember, test s "get all conversation roles" testAllConversationRoles, @@ -284,6 +287,65 @@ roleUpdateWithRemotes = do evtFrom e @?= qbob evtData e @?= EdMemberUpdate mu +roleUpdateWithRemotesUnavailable :: TestM () +roleUpdateWithRemotesUnavailable = do + c <- view tsCannon + let remoteDomain = Domain "alice.example.com" + qalice <- Qualified <$> randomId <*> pure remoteDomain + qbob <- randomQualifiedUser + qcharlie <- randomQualifiedUser + let bob = qUnqualified qbob + charlie = qUnqualified qcharlie + + connectUsers bob (singleton charlie) + connectWithRemoteUser bob qalice + resp <- + postConvWithRemoteUsers + bob + Nothing + defNewProteusConv {newConvQualifiedUsers = [qalice, qcharlie]} + let qconv = decodeQualifiedConvId resp + + WS.bracketR2 c bob charlie $ \(wsB, wsC) -> do + (_, requests) <- + withTempMockFederator' (throw $ MockErrorResponse Http.status503 "Down for maintenance") $ + putOtherMemberQualified + bob + qcharlie + (OtherMemberUpdate (Just roleNameWireAdmin)) + qconv + !!! const 200 === statusCode + + req <- assertOne requests + let mu = + MemberUpdateData + { misTarget = qcharlie, + misOtrMutedStatus = Nothing, + misOtrMutedRef = Nothing, + misOtrArchived = Nothing, + misOtrArchivedRef = Nothing, + misHidden = Nothing, + misHiddenRef = Nothing, + misConvRoleName = Just roleNameWireAdmin + } + liftIO $ do + frTargetDomain req @?= remoteDomain + frComponent req @?= Galley + frRPC req @?= "on-conversation-updated" + Right cu <- pure . eitherDecode . frBody $ req + F.cuConvId cu @?= qUnqualified qconv + F.cuAction cu + @?= SomeConversationAction (sing @'ConversationMemberUpdateTag) (ConversationMemberUpdate qcharlie (OtherMemberUpdate (Just roleNameWireAdmin))) + F.cuAlreadyPresentUsers cu @?= [qUnqualified qalice] + + liftIO . WS.assertMatchN_ (5 # Second) [wsB, wsC] $ \n -> do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= qconv + evtType e @?= MemberStateUpdate + evtFrom e @?= qbob + evtData e @?= EdMemberUpdate mu + accessUpdateWithRemotes :: TestM () accessUpdateWithRemotes = do c <- view tsCannon diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 1f568245f3..7936d6b5cf 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -1074,7 +1074,7 @@ testNoConsentCannotBeInvited = do >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") localdomain <- viewFederationDomain - API.Util.postQualifiedMembers userLHNotActivated (Qualified peer2 localdomain :| []) convId + API.Util.postQualifiedMembers userLHNotActivated (Qualified peer2 localdomain :| []) qconvId >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") testCannotCreateGroupWithUsersInConflict :: HasCallStack => TestM () diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 0d35e8fafe..1f6e082c8d 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -1155,17 +1155,22 @@ listRemoteConvs remoteDomain uid = do pure $ filter (\qcnv -> qDomain qcnv == remoteDomain) allConvs postQualifiedMembers :: - (MonadReader TestSetup m, MonadHttp m) => + (MonadReader TestSetup m, MonadHttp m, HasGalley m) => UserId -> NonEmpty (Qualified UserId) -> - ConvId -> + Qualified ConvId -> m ResponseLBS postQualifiedMembers zusr invitees conv = do - g <- view tsUnversionedGalley + g <- viewGalley let invite = InviteQualified invitees roleNameWireAdmin post $ g - . paths ["v1", "conversations", toByteString' conv, "members", "v2"] + . paths + [ "conversations", + toByteString' . qDomain $ conv, + toByteString' . qUnqualified $ conv, + "members" + ] . zUser zusr . zConn "conn" . zType "access" @@ -2326,8 +2331,8 @@ assertMismatchQualified :: Client.QualifiedUserClients -> Client.QualifiedUserClients -> Assertions () -assertMismatchQualified failedToSend missing redundant deleted = do - assertExpected "failed to send" failedToSend (fmap mssFailedToSend . responseJsonMaybe) +assertMismatchQualified failureToSend missing redundant deleted = do + assertExpected "failed to send" failureToSend (fmap mssFailedToSend . responseJsonMaybe) assertExpected "missing" missing (fmap mssMissingClients . responseJsonMaybe) assertExpected "redundant" redundant (fmap mssRedundantClients . responseJsonMaybe) assertExpected "deleted" deleted (fmap mssDeletedClients . responseJsonMaybe) diff --git a/services/run-services b/services/run-services index 47d1c555bc..df406112ba 100755 --- a/services/run-services +++ b/services/run-services @@ -182,6 +182,26 @@ class Instance: if 'remoteDomains' in data: data['remoteDomains'] = remoteDomains + if 'aws' in data: + if 'userJournalQueue' in data['aws']: + data['aws']['userJournalQueue'] = f"integration-user-events.fifo{suffix}" + if 'prekeyTable' in data['aws']: + data['aws']['prekeyTable'] = f"integration-brig-prekeys{suffix}" + if 's3Bucket' in data['aws']: + data['aws']['s3Bucket'] = f"dummy-bucket{suffix}" + if 'queueName' in data['aws']: + data['aws']['queueName'] = f"integration-gundeck-events{suffix}" + + if 'internalEvents' in data and 'queueName' in data['internalEvents']: + data['internalEvents']['queueName'] = f"integration-brig-events-internal{suffix}" + + if 'emailSMS' in data: + data['emailSMS']['email']['sesQueue'] = f"integration-brig-events{suffix}" + data['emailSMS']['general']['emailSender'] = f"backend-integration{suffix}@wire.com" + + if 'journal' in data: + data['journal']['queueName'] = f"integration-team-events.fifo{suffix}" + # set log level if self.service.level is not None: if 'logLevel' in data: @@ -371,7 +391,7 @@ def start_backend(services, suffix, domain, remoteDomains, backend_name): return instances -ENABLE_FEDERATION = os.environ.get("INTEGRATION_FEDERATION_TESTS") == "1" +ENABLE_FEDERATION = True LEVEL = os.environ.get("INTEGRATION_LEVEL") BRIG = Service("brig", Colors.GREEN).with_level(LEVEL) GALLEY = Service("galley", Colors.YELLOW).with_level(LEVEL) @@ -386,6 +406,7 @@ FEDERATOR = Service("federator", Colors.BLUE, check_status=False).with_level(LEVEL) STERN = Service("stern", Colors.YELLOW).with_level(LEVEL) PROXY = Service("proxy", Colors.RED).with_level(LEVEL) +BACKGROUND_WORKER = Service("background-worker", Colors.RED, check_status=False).with_level(LEVEL) NGINZ = Nginz(Colors.PURPLEISH) if __name__ == '__main__': @@ -399,8 +420,8 @@ if __name__ == '__main__': 'AWS_REGION': "eu-west-1", 'AWS_ACCESS_KEY_ID': "dummykey", 'AWS_SECRET_ACCESS_KEY': "dummysecret", - 'RABBITMQ_USERNAME': 'guest', - 'RABBITMQ_PASSWORD': 'alpaca-grapefruit' + 'RABBITMQ_USERNAME': os.environ.get("RABBITMQ_USERNAME"), + 'RABBITMQ_PASSWORD': os.environ.get("RABBITMQ_PASSWORD") } backend_a = [ @@ -414,6 +435,7 @@ if __name__ == '__main__': Instance(STERN, 8091), DummyInstance(PROXY, 8087), FederatorInstance(8097, 8098), + Instance(BACKGROUND_WORKER, 0), NginzInstance( local_port=8080, http2_port=8090, @@ -431,6 +453,7 @@ if __name__ == '__main__': Instance(SPAR, 9088), DummyInstance(PROXY, 9087), FederatorInstance(9097, 9098), + Instance(BACKGROUND_WORKER, 0), NginzInstance( local_port=9080, http2_port=9090, diff --git a/services/start-services-only.sh b/services/start-services-only.sh index 374e12f285..db5d23fd3b 100755 --- a/services/start-services-only.sh +++ b/services/start-services-only.sh @@ -1,10 +1,5 @@ #!/usr/bin/env bash -# Run all haskell services without immediately starting a test executable. -# Can be useful for manually poking at the API. -set -eo pipefail - SERVICES_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" - -# call run-services, show a message, then sleep (instead of executing a test executable) -exec "$SERVICES_DIR/run-services" +echo -e "\n\n\n*** $0 is deprecated. please run '$SERVICES_DIR/run-services' instead.\n\n\n" +exit 1 diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index f5b671e0db..c9b4be4220 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -165,6 +165,10 @@ sitemap' = :<|> Named @"post-team-billing-info" setTeamBillingInfo :<|> Named @"get-consent-log" getConsentLog :<|> Named @"get-user-meta-info" getUserData + :<|> Named @"register-oauth-client" Intra.registerOAuthClient + :<|> Named @"get-oauth-client" Intra.getOAuthClient + :<|> Named @"update-oauth-client" Intra.updateOAuthClient + :<|> Named @"delete-oauth-client" Intra.deleteOAuthClient sitemapInternal :: Servant.Server SternAPIInternal sitemapInternal = diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs index 4318a88e8e..af94471b03 100644 --- a/tools/stern/src/Stern/API/Routes.hs +++ b/tools/stern/src/Stern/API/Routes.hs @@ -43,6 +43,7 @@ import Servant.Swagger (HasSwagger (toSwagger)) import Servant.Swagger.Internal.Orphans () import Servant.Swagger.UI import Stern.Types +import Wire.API.OAuth import Wire.API.Routes.Internal.Brig.Connection (ConnectionStatus) import qualified Wire.API.Routes.Internal.Brig.EJPD as EJPD import Wire.API.Routes.Named @@ -380,6 +381,43 @@ type SternAPI = :> QueryParam' [Required, Strict, Description "A valid UserId"] "id" UserId :> Post '[JSON] UserMetaInfo ) + :<|> Named + "register-oauth-client" + ( Summary "Register an OAuth client" + :> "i" + :> "oauth" + :> "clients" + :> ReqBody '[JSON] OAuthClientConfig + :> Post '[JSON] OAuthClientCredentials + ) + :<|> Named + "get-oauth-client" + ( Summary "Get OAuth client by id" + :> "i" + :> "oauth" + :> "clients" + :> Capture "id" OAuthClientId + :> Get '[JSON] OAuthClient + ) + :<|> Named + "update-oauth-client" + ( Summary "Update OAuth client" + :> "i" + :> "oauth" + :> "clients" + :> Capture "id" OAuthClientId + :> ReqBody '[JSON] OAuthClientConfig + :> Put '[JSON] OAuthClient + ) + :<|> Named + "delete-oauth-client" + ( Summary "Delete OAuth client" + :> "i" + :> "oauth" + :> "clients" + :> Capture "id" OAuthClientId + :> Delete '[JSON] () + ) ------------------------------------------------------------------------------- -- Swagger diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 8a38eaf08e..e9c7e95964 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -59,6 +59,10 @@ module Stern.Intra getUserClients, getUserCookies, getUserNotifications, + registerOAuthClient, + getOAuthClient, + updateOAuthClient, + deleteOAuthClient, ) where @@ -98,6 +102,7 @@ import UnliftIO.Exception hiding (Handler) import Wire.API.Connection import Wire.API.Conversation import Wire.API.Internal.Notification +import Wire.API.OAuth (OAuthClient, OAuthClientConfig, OAuthClientCredentials) import Wire.API.Properties import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Routes.Internal.Brig.EJPD as EJPD @@ -813,7 +818,7 @@ getUserProperties uid = do b ( method GET . header "Z-User" (toByteString' uid) - . versionedPaths ["/properties", toByteString' x] + . versionedPaths ["properties", toByteString' x] . expect2xx ) info $ msg ("Response" ++ show r) @@ -853,3 +858,64 @@ getUserNotifications uid = do 404 -> parseResponse (mkError status502 "bad-upstream") r _ -> throwE (mkError status502 "bad-upstream" "") batchSize = 100 :: Int + +registerOAuthClient :: OAuthClientConfig -> Handler OAuthClientCredentials +registerOAuthClient conf = do + b <- view brig + r <- + catchRpcErrors $ + rpc' + "brig" + b + ( method POST + . Bilge.paths ["i", "oauth", "clients"] + . Bilge.json conf + . contentJson + . expect2xx + ) + parseResponse (mkError status502 "bad-upstream") r + +getOAuthClient :: OAuthClientId -> Handler OAuthClient +getOAuthClient cid = do + b <- view brig + r <- + rpc' + "brig" + b + ( method GET + . Bilge.paths ["i", "oauth", "clients", toByteString' cid] + ) + case statusCode r of + 200 -> parseResponse (mkError status502 "bad-upstream") r + 404 -> throwE (mkError status404 "bad-upstream" "not-found") + _ -> throwE (mkError status502 "bad-upstream" (cs $ show r)) + +updateOAuthClient :: OAuthClientId -> OAuthClientConfig -> Handler OAuthClient +updateOAuthClient cid conf = do + b <- view brig + r <- + catchRpcErrors $ + rpc' + "brig" + b + ( method PUT + . Bilge.paths ["i", "oauth", "clients", toByteString' cid] + . Bilge.json conf + . contentJson + . expect2xx + ) + parseResponse (mkError status502 "bad-upstream") r + +deleteOAuthClient :: OAuthClientId -> Handler () +deleteOAuthClient cid = do + b <- view brig + r <- + catchRpcErrors $ + rpc' + "brig" + b + ( method DELETE + . Bilge.paths ["i", "oauth", "clients", toByteString' cid] + . expect2xx + ) + parseResponse (mkError status502 "bad-upstream") r diff --git a/tools/stern/test/integration/API.hs b/tools/stern/test/integration/API.hs index 0ef9daa1d9..7b67d1062d 100644 --- a/tools/stern/test/integration/API.hs +++ b/tools/stern/test/integration/API.hs @@ -27,10 +27,11 @@ import Bilge.Assert import Brig.Types.Intra import Control.Applicative import Control.Lens hiding ((.=)) -import Data.Aeson (ToJSON) +import Data.Aeson (ToJSON, Value) import Data.ByteString.Conversion import Data.Handle import Data.Id +import Data.Range (unsafeRange) import Data.Schema import qualified Data.Set as Set import Data.String.Conversions @@ -42,6 +43,8 @@ import Test.Tasty import Test.Tasty.HUnit import TestSetup import Util +import Wire.API.OAuth (OAuthApplicationName (OAuthApplicationName), OAuthClientConfig (..), OAuthClientCredentials (..)) +import Wire.API.Properties (PropertyKey) import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Routes.Internal.Brig.EJPD as EJPD import Wire.API.Routes.Internal.Galley.TeamsIntra (tdStatus) @@ -92,7 +95,8 @@ tests s = test s "GET /i/consent" testGetConsentLog, test s "GET /teams/:id" testGetTeamInfo, test s "GET i/user/meta-info?id=..." testGetUserMetaInfo, - test s "/teams/:tid/search-visibility" testSearchVisibility + test s "/teams/:tid/search-visibility" testSearchVisibility, + test s "i/oauth/clients" testCrudOAuthClient -- The following endpoints can not be tested because they require ibis: -- - `GET /teams/:tid/billing` -- - `GET /teams/:tid/invoice/:inr` @@ -100,6 +104,25 @@ tests s = -- - `POST /teams/:tid/billing` ] +testCrudOAuthClient :: TestM () +testCrudOAuthClient = do + let url = fromMaybe (error "invalid url") . fromByteString $ "https://example.com" + let name = OAuthApplicationName (unsafeRange "foobar") + cred <- registerOAuthClient (OAuthClientConfig name url) + c <- getOAuthClient cred.clientId + liftIO $ do + c.applicationName @?= name + c.redirectUrl @?= url + let newName = OAuthApplicationName (unsafeRange "barfoo") + let newUrl = fromMaybe (error "invalid url") . fromByteString $ "https://example.org" + updateOAuthClient cred.clientId (OAuthClientConfig newName newUrl) + c' <- getOAuthClient cred.clientId + liftIO $ do + c'.applicationName @?= newName + c'.redirectUrl @?= newUrl + deleteOAuthClient cred.clientId + getOAuthClient' cred.clientId !!! const 404 === statusCode + testSearchVisibility :: TestM () testSearchVisibility = do (_, tid, _) <- createTeamWithNMembers 10 @@ -116,6 +139,8 @@ testSearchVisibility = do testGetUserMetaInfo :: TestM () testGetUserMetaInfo = do uid <- randomUser + let k = fromMaybe (error "invalid property key") $ fromByteString "WIRE_RECEIPT_MODE" + putUserProperty uid k "bar" -- Just make sure this returns a 200 void $ getUserMetaInfo uid @@ -615,3 +640,35 @@ unlockFeature :: unlockFeature tid = do g <- view tsGalley void $ put (g . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg, "unlocked"] . expect2xx) + +putUserProperty :: UserId -> PropertyKey -> Value -> TestM () +putUserProperty uid k v = do + b <- view tsBrig + void $ put (b . paths ["properties", toByteString' k] . json v . zUser uid . zConn "123" . expect2xx) + +registerOAuthClient :: OAuthClientConfig -> TestM OAuthClientCredentials +registerOAuthClient cfg = do + s <- view tsStern + r <- post (s . paths ["i", "oauth", "clients"] . json cfg . expect2xx) + pure $ responseJsonUnsafe r + +getOAuthClient' :: OAuthClientId -> TestM ResponseLBS +getOAuthClient' cid = do + s <- view tsStern + get (s . paths ["i", "oauth", "clients", toByteString' cid]) + +getOAuthClient :: OAuthClientId -> TestM OAuthClientConfig +getOAuthClient cid = do + s <- view tsStern + r <- get (s . paths ["i", "oauth", "clients", toByteString' cid] . expect2xx) + pure $ responseJsonUnsafe r + +updateOAuthClient :: OAuthClientId -> OAuthClientConfig -> TestM () +updateOAuthClient cid cfg = do + s <- view tsStern + void $ put (s . paths ["i", "oauth", "clients", toByteString' cid] . json cfg . expect2xx) + +deleteOAuthClient :: OAuthClientId -> TestM () +deleteOAuthClient cid = do + s <- view tsStern + void $ delete (s . paths ["i", "oauth", "clients", toByteString' cid] . expect2xx) diff --git a/treefmt.toml b/treefmt.toml index be1eb7bf18..f36b090100 100644 --- a/treefmt.toml +++ b/treefmt.toml @@ -13,9 +13,7 @@ excludes = [ "services/nginz/third_party/", "libs/wire-api/test/golden/gentests.sh", "changelog.d/mk-changelog.sh", - "hack/bin/integration-teardown.sh", "hack/bin/diff-failure.sh", - "hack/bin/integration-setup.sh", "hack/bin/python3.sh", "hack/bin/cabal-run-tests.sh", "hack/bin/integration-teardown-federation.sh",