diff --git a/CHANGELOG.md b/CHANGELOG.md index 630d52ebf78..d56150a7ffd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,49 @@ +# [2022-07-12] (Chart Release 4.19.0) + +## Release notes + + +* Deploy spar before galley (#2543) + +* Upgrade team-settings version to 4.11.0-v0.31.1-0-9e64150 (#2180) + + +## API changes + + +* Restore PUT /v2/connections endpoint (#2539) + + +## Features + + +* 2nd factor authentication code generation is rate limited now (#2522) + +* The team member CSV export now fills `created_on` for SCIM users (#2543) + + +## Internal changes + + +* Add Helm chart for inbucket. Inbucket is a SMTP server that does not relay, but instead display received mail in a webapp and make them accessible via an API. (#2544) + +* Bump saml2-web-sso (#2545, #2546) + +* use checkedConnectCluster to avoid dropping requests to Redis when Gundeck reconnects to the Redis cluster (#2542) + +* Do not log polysemy errors in Galley (#2531) + +* Remove old crypto-cli tool from the ubuntu image (#2538) + + +## Federation changes + + +* Added new-remote-conversation RPC, used to notify a backend of a remote conversation the first time any user from that backend is added to it. (#2378) + +* Added federation endpoint `send-mls-message` used to send messages to remote converesations (#2378) + + # [2022-07-05] (Chart Release 4.18.0) ## Release notes diff --git a/Makefile b/Makefile index 6b6852351ff..f8a383828f8 100644 --- a/Makefile +++ b/Makefile @@ -13,7 +13,7 @@ CHARTS_INTEGRATION := wire-server databases-ephemeral redis-cluster fake-aws # (e.g. move charts/brig to charts/wire-server/brig) # this list could be generated from the folder names under ./charts/ like so: # CHARTS_RELEASE := $(shell find charts/ -maxdepth 1 -type d | xargs -n 1 basename | grep -v charts) -CHARTS_RELEASE := wire-server redis-ephemeral redis-cluster databases-ephemeral fake-aws fake-aws-s3 fake-aws-sqs aws-ingress fluent-bit kibana backoffice calling-test demo-smtp elasticsearch-curator elasticsearch-external elasticsearch-ephemeral minio-external cassandra-external nginx-ingress-controller nginx-ingress-services reaper wire-server-metrics sftd restund coturn +CHARTS_RELEASE := wire-server redis-ephemeral redis-cluster databases-ephemeral fake-aws fake-aws-s3 fake-aws-sqs aws-ingress fluent-bit kibana backoffice calling-test demo-smtp elasticsearch-curator elasticsearch-external elasticsearch-ephemeral minio-external cassandra-external nginx-ingress-controller nginx-ingress-services reaper wire-server-metrics sftd restund coturn inbucket BUILDAH_PUSH ?= 0 KIND_CLUSTER_NAME := wire-server BUILDAH_KIND_LOAD ?= 1 @@ -409,6 +409,10 @@ charts-integration: $(foreach chartName,$(CHARTS_INTEGRATION),chart-$(chartName) charts-serve: charts-integration ./hack/bin/serve-charts.sh $(CHARTS_INTEGRATION) +.PHONY: charts-serve-all +charts-serve-all: $(foreach chartName,$(CHARTS_RELEASE),chart-$(chartName)) + ./hack/bin/serve-charts.sh $(CHARTS_RELEASE) + # Usecase for this make target: # 1. for releases of helm charts # 2. for testing helm charts more generally diff --git a/build/ubuntu/Dockerfile.deps b/build/ubuntu/Dockerfile.deps index c2999b35e00..0164d3a6ba6 100644 --- a/build/ubuntu/Dockerfile.deps +++ b/build/ubuntu/Dockerfile.deps @@ -10,14 +10,6 @@ RUN export DEBIAN_FRONTEND=noninteractive && \ export SODIUM_USE_PKG_CONFIG=1 && \ cargo build --release -# FUTUREWORK: remove core-crypto once #2508 is merged -# compile legacy core-crypto cli tool -RUN cd /tmp && \ - apt-get install -y libssl-dev && \ - git clone -b cli https://github.com/wireapp/core-crypto && \ - cd core-crypto/cli && \ - cargo build --release - # compile mls-test-cli tool RUN cd /tmp && \ git clone https://github.com/wireapp/mls-test-cli && \ @@ -29,9 +21,8 @@ FROM ubuntu:20.04 COPY --from=cryptobox-builder /tmp/cryptobox-c/target/release/libcryptobox.so /usr/lib -# FUTUREWORK: only copy crypto-cli and mls-test-cli executables if we are building an +# FUTUREWORK: only copy mls-test-cli executables if we are building an # integration test image -COPY --from=cryptobox-builder /tmp/core-crypto/cli/target/release/crypto-cli /usr/bin COPY --from=cryptobox-builder /tmp/mls-test-cli/target/release/mls-test-cli /usr/bin RUN export DEBIAN_FRONTEND=noninteractive && \ diff --git a/cabal.project b/cabal.project index c515c73ee82..8c2563decc8 100644 --- a/cabal.project +++ b/cabal.project @@ -142,7 +142,7 @@ source-repository-package source-repository-package type: git location: https://github.com/wireapp/saml2-web-sso - tag: 4227e38be5c0810012dc472fc6931f6087fbce68 + tag: 74371cd775cb98d6cf85f6e182244a3c4fd48702 source-repository-package type: git diff --git a/cassandra-schema.cql b/cassandra-schema.cql index a053e0551c3..7f4fb97cbf8 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -1214,6 +1214,27 @@ CREATE TABLE brig_test.user ( AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; +CREATE TABLE brig_test.vcodes_throttle ( + key ascii, + scope int, + initial_delay int, + PRIMARY KEY (key, scope) +) WITH CLUSTERING ORDER BY (scope ASC) + AND bloom_filter_fp_chance = 0.01 + AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} + AND comment = '' + AND compaction = {'class': 'org.apache.cassandra.db.compaction.SizeTieredCompactionStrategy', 'max_threshold': '32', 'min_threshold': '4'} + AND compression = {'chunk_length_in_kb': '64', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'} + AND crc_check_chance = 1.0 + AND dclocal_read_repair_chance = 0.1 + AND default_time_to_live = 0 + AND gc_grace_seconds = 864000 + AND max_index_interval = 2048 + AND memtable_flush_period_in_ms = 0 + AND min_index_interval = 128 + AND read_repair_chance = 0.0 + AND speculative_retry = '99PERCENTILE'; + CREATE TABLE brig_test.properties ( user uuid, key ascii, diff --git a/charts/brig/templates/configmap.yaml b/charts/brig/templates/configmap.yaml index 210fa59a26c..1b7a529d59c 100644 --- a/charts/brig/templates/configmap.yaml +++ b/charts/brig/templates/configmap.yaml @@ -282,5 +282,8 @@ data: {{- if .setCustomerExtensions }} setCustomerExtensions: {{ toYaml .setCustomerExtensions | nindent 8 }} {{- end }} + {{- if .set2FACodeGenerationDelaySecs }} + set2FACodeGenerationDelaySecs: {{ .set2FACodeGenerationDelaySecs }} + {{- end }} {{- end }} {{- end }} diff --git a/charts/brig/templates/tests/configmap.yaml b/charts/brig/templates/tests/configmap.yaml index 5ebf029a33a..45964c933c9 100644 --- a/charts/brig/templates/tests/configmap.yaml +++ b/charts/brig/templates/tests/configmap.yaml @@ -69,6 +69,10 @@ data: host: cargohold.{{ .Release.Namespace }}-fed2.svc.cluster.local port: 8080 + cannon: + host: cannon.{{ .Release.Namespace }}-fed2.svc.cluster.local + port: 8080 + # TODO remove this federator: host: federator.{{ .Release.Namespace }}-fed2.svc.cluster.local diff --git a/charts/brig/values.yaml b/charts/brig/values.yaml index 82d215da491..2e07ad7090c 100644 --- a/charts/brig/values.yaml +++ b/charts/brig/values.yaml @@ -84,6 +84,7 @@ config: # setCustomerExtensions: # domainsBlockedForRegistration: # - example.com + set2FACodeGenerationDelaySecs: 300 # 5 minutes smtp: passwordFile: /etc/wire/brig/secrets/smtp-password.txt proxy: {} diff --git a/charts/inbucket/Chart.yaml b/charts/inbucket/Chart.yaml new file mode 100644 index 00000000000..9c440f0ab9d --- /dev/null +++ b/charts/inbucket/Chart.yaml @@ -0,0 +1,10 @@ +apiVersion: v1 +name: inbucket +version: 0.0.42 +description: Inbucket is an email testing application; it will accept messages for any email address and make them available to view via a web interface. +home: https://www.inbucket.org/ +sources: + - https://github.com/inbucket/inbucket + - https://artifacthub.io/packages/helm/inbucket/inbucket + - https://hub.docker.com/r/inbucket/inbucket +appVersion: 3.0.0 diff --git a/charts/inbucket/README.md b/charts/inbucket/README.md new file mode 100644 index 00000000000..8fd97254a2d --- /dev/null +++ b/charts/inbucket/README.md @@ -0,0 +1,10 @@ +# Inbucket chart + +[*Inbucket*](https://www.inbucket.org/) is a fake SMTP server that provides all +captured eMails via a webapp and a REST API. At *Wire* it is used in testing +environments to not have to deal with concrete SMTP server configurations. +Especially, it saves us to care about topics like *SPAM filters* and *server +grey & black listing*. + +This chart exists to adjust the [`inbucket/inbucket` +chart](https://artifacthub.io/packages/helm/inbucket/inbucket) to our needs. diff --git a/charts/inbucket/requirements.yaml b/charts/inbucket/requirements.yaml new file mode 100644 index 00000000000..2478ba341c0 --- /dev/null +++ b/charts/inbucket/requirements.yaml @@ -0,0 +1,4 @@ +dependencies: +- name: inbucket + version: 2.0.1 + repository: https://inbucket.github.io/inbucket-community diff --git a/charts/inbucket/templates/ingress.yaml b/charts/inbucket/templates/ingress.yaml new file mode 100644 index 00000000000..7be2a320c28 --- /dev/null +++ b/charts/inbucket/templates/ingress.yaml @@ -0,0 +1,19 @@ +apiVersion: extensions/v1beta1 +kind: Ingress +metadata: + name: "inbucket" + namespace: {{ .Release.Namespace }} + labels: + app.kubernetes.io/name: {{ include "inbucket.name" . }} + app.kubernetes.io/instance: {{ .Release.Name }} + app.kubernetes.io/managed-by: {{ .Release.Service }} + helm.sh/chart: {{ include "inbucket.chart" . }} +spec: + rules: + - host: {{ required "must specify host" .Values.host | quote }} + http: + paths: + - path: / + backend: + serviceName: {{ include "inbucket.fullname" . }} + servicePort: http diff --git a/charts/inbucket/values.yaml b/charts/inbucket/values.yaml new file mode 100644 index 00000000000..626051a534c --- /dev/null +++ b/charts/inbucket/values.yaml @@ -0,0 +1,13 @@ +# Fully qualified domain name (FQDN) of the domain where to serve inbucket. +# E.g. 'inbucket.my-test-env.wire.link' +host: + +# Configure the inbucket "parent" chart +inbucket: + image: + tag: 3.0.2 + + extraEnv: + INBUCKET_WEB_GREETINGFILE: "/config/greeting.html" + INBUCKET_MAILBOXNAMING: full + INBUCKET_STORAGE_RETENTIONPERIOD: "72h" diff --git a/charts/team-settings/values.yaml b/charts/team-settings/values.yaml index abdcfdd60fa..65cd0bc57fd 100644 --- a/charts/team-settings/values.yaml +++ b/charts/team-settings/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/team-settings - tag: "4.10.0-v0.29.7-0-3be8ca3" + tag: "4.11.0-v0.31.1-0-9e64150" service: https: externalPort: 443 diff --git a/docs/src/how-to/administrate/backup-disaster-recovery.md b/docs/src/how-to/administrate/backup-disaster-recovery.md new file mode 100644 index 00000000000..5d525b66017 --- /dev/null +++ b/docs/src/how-to/administrate/backup-disaster-recovery.md @@ -0,0 +1,331 @@ +# Backup and disaster recovery + +## Introduction + +While you might never use them, your backup plan (and the corresponding disaster recovery steps) are possibly your most important procedure. + +You should: + +1. Write it up fully +2. Test it from beginning to end, simulating an actual disaster +3. Run backups on a regular basis, ideally automatically + +This page explains in detail how to properly backup an on-premise Wire installation, and how to recover from your backup if you ever need to. + +Note that you should not trust this page (or your execution of it) to allow for a proper backup and restore, therefore, you should immediately (before it becomes critical to do so) back up your Wire installation **and** attempt (as a test) to restore it. This will ensure that you can **in fact** backup and restore Wire, and will catch any problem in the process before any problem becomes damaging to you. + +## Backing up + +By nature, a significant part of a Wire installation is ephemeral, and not meant to be stored long-term or recovered: in case of trouble, those parts can just be started fresh with minimal impact on user experience. + +The exceptions to this rule, are what you want to back up. In particular: + +* Your "wire-server" installation folder (used during the installation procedure) +* Your Cassandra database +* Your Minio data + +If you save these, you can then whenever needed, create a fresh installation of Wire, re-import/re-install them on top of it, and get back to a working state. + +Here is how to back up each: + +### Backing up Wire-server + +To backup the wire-server folder, we simply use ssh to read it from the server in which it is installed: + + ssh user@my-wire-server.your-domain.com 'cd /path/to/my/folder/for/wire-server/ && tar -cf - wire-server | gzip -9' > wire-server-backup.tar.gz + +Where : + +* `user` is the user you used to install Wire on this server, typically `wire` or `root` +* `my-wire-server.your-domain.com` is the domain name or IP address for the server with your Wire install +* `/path/to/my/folder/for/wire-server/` is the (absolute) path, on the server, where your wire-server folder is located +* `wire-server` is the name of the folder for your wire-server install, typically (as per instructions) simply `wire-server` +* `wire-server-backup.tar.gz` is the name of the file in which your wire-server folder will be stored + +Once the command is done executing, make sure the file exists and is not empty with: + + file wire-server-backup.tar.gz # Should say the file type is a TAR archive + ls -lh wire-server-backup.tar.gz # Should show a file size other than 0 + tar tvf wire-server-backup.tar.gz # Should list the files inside your wire-server folder correctly + +Now simply save this file in multiple locations as per your normal company backup procedures, and repeat this procedure on a regular basis as is appropriate. + +### Backing up Cassandra + +Cassandra stores things such as user profiles/accounts, conversations, etc. It is the most critical data to backup/store/recover. + +To backup your Cassandra database, do as follows: + +You can read general information about connecting to your Cassandra node on [this page](/how-to/administrate/cassandra) + +In particular, SSH into the Cassandra Virtual Machine with: + + ssh user@cassandra-vm.your-domain.com + +Where: + +* `user` is the user you used to install Wire on this server, typically `wire` or `root` +* `cassandra-vm.your-domain.com` is the domain name or IP address for the server with your Cassandra node + +Make sure (while connected via ssh) your Cassandra installation is doing well with: + + nodetool status + + +You should see a list of nodes like this: + + Datacenter: datacenter1 + ======================= + Status=Up/Down + |/ State=Normal/Leaving/Joining/Moving + -- Address Load Tokens Owns (effective) Host ID Rack + UN 192.168.220.13 9.51MiB 256 100.0% 3dba71c8-eea7-4e35-8f35-4386e7944894 rack1 + UN 192.168.220.23 9.53MiB 256 100.0% 3af56f1f-7685-4b5b-b73f-efdaa371e96e rack1 + UN 192.168.220.33 9.55MiB 256 100.0% RANDOMLY-MADE-UUID-GOES-INTHISPLACE! rack1 + +As per the [Cassandra documentation](https://cassandra.apache.org/doc/latest/cassandra/operating/backups.html) to backup your database, you will use the `nodetool snapshot` command. + +First we need to edit the `cassandra.yaml` file (which you can if needed find with `find -name cassandra.yaml`) has `auto_snapshot` set to `false`: + + auto_snapshot: false + +Same with: `snapshot_before_compaction` + + snapshot_before_compaction: false + +After editing the file, make sure you restart cassandra with: + + sudo service cassandra restart + +You can find a list of all keyspaces by doing: + + ls /mnt/cassandra/data/ + +Now (while connected via ssh, as per above), use nodetool to actually generate a snapshot of all tables: + + nodetool snapshot --tag catalog-ks catalogkeyspace + +This should succesfully save the snapshots to the disk. + +You should now be able to find your snapshots in the snapshots list with: + + nodetool listsnapshots + +To actually save the files, you'll need to locate them with: + + find -name snapshots + +Which should give you a list of paths to snapshots, such as: + + /mnt/cassandra/data/data/catalogkeyspace/journal-296a2d30c22a11e9b1350d927649052c/snapshots + /mnt/cassandra/data/data/catalogkeyspace/magazine-446eae30c22a11e9b1350d927649052c/snapshots + +Now to create a (local) backup of these snapshots, we use `ssh` the same way we did above for `wire-server`: + + ssh user@cassandra-vm.your-domain.com 'cd /mnt/cassandra/data/data/catalogkeyspace/journal-296a2d30c22a11e9b1350d927649052c/ && tar -cf - snapshots | gzip -9' > cassandra-catalogkeyspace-journal-backup.tar.gz + +Where : + +* `user` is the user you used to install Wire on this server, typically `wire` or `root` +* `cassandra-vm.your-domain.com` is the domain name or IP address for the server with your Wire install +* `/mnt/cassandra/` is the (absolute) path, on the server, where your cassandra folder is located, to which you add the location of the specific snapshot, found with `find` above + +Repeat this for each of the snapshots. + +Now simply save these files in multiple locations as per your normal company backup procedures, and repeat this procedure on a regular basis as is appropriate. + +### Batch Cassandra backup + +The backup procedure above presumes manually backing up each Cassandra snapshot serially one by one. + +If you want to back all files at once, you can use the `find` command to find all snapshots and pack them into a single archive: + + ssh user@cassandra-vm.your-domain.com 'find /mnt/cassandra/ -name "snapshots" -print0 | tar -cvf - --null -T - | gzip -9 ' > cassandra-batch.tar.gz + +* `user` is the user you used to install Wire on this server, typically `wire` or `root` +* `cassandra-vm.your-domain.com` is the domain name or IP address for the server with your Wire install +* `/mnt/cassandra/` is the (absolute) path, on the server, where your cassandra folder is located, to which you add the location of the specific snapshot, found with `find` above +* `cassandra-batch.tar.gz` is the local file everything will be written to + +This will (over ssh) find all `snapshot` folders in the `cassandra` folder, pack them into a tar file, gzip it to save space, and output it to a local file. + +### Backing up MinIO + +MinIO emulates an Amazon-S3-compatible file-storage setup, and is used by Wire to store things such as file attachments, images etc. + +If your specific installation is using the actual Amazon file storage (and not a local emulated alternative), you should skip this section (but still actually backup whatever you are using). + +Similarly to Cassandra, to create a backup you need to SSH into the Virtual Machine running MinIO in your installation: + +You can read general information about your MinIO node on [this page](/how-to/administrate/minio). + +SSH into the MinIO Virtual Machine with: + + ssh user@minio-vm.your-domain.com + +Where: + +* `user` is the user you used to install Wire on this server, typically `wire` or `root` +* `minio-vm.your-domain.com` is the domain name or IP address for the server with your MinIO node + +To backup the MinIO data, we need to backup two servers over SSH, the same way we did for Cassandra and wire-server: + + ssh user@my-minio-server.your-domain.com 'cd /var/lib/ && tar -cf - minio-server1 | gzip -9' > minio-server1-backup.tar.gz + ssh user@my-minio-server.your-domain.com 'cd /var/lib/ && tar -cf - minio-server2 | gzip -9' > minio-server2-backup.tar.gz + +Where: + +* `user` is the user you used to install Wire on this server, typically `wire` or `root` +* `my-minio-server.your-domain.com` is the domain name or IP address for the MinIO Virtual Machine +* `minio-server[number]-backup.tar.gz` is the name of the file in which each minio data folder will be stored + +### Automated regular backups + +It is important to back up as often as possible. You can use `cron` to automatically run your backup commands on a regular basis. + +For example, you can create the following shell script, and write it to `/home/myuser/backup/wire-backup.sh`: + + #!/bin/sh + # Make the folder if it does not exist yet + mkdir -p /home/myuser/backup/data/ + + # Back up wire-server folder + ssh user@my-wire-server.your-domain.com 'cd /path/to/my/folder/for/wire-server/ && tar -cf - wire-server | gzip -9' > /home/myuser/backup/data/wire-server-backup.tar.gz + + # Cause Cassandra to generate new snapshots + ssh user@cassandra-vm.your-domain.com 'nodetool snapshot --tag catalog-ks catalogkeyspace` + + # Backup Cassandra snapshots to a file + ssh user@cassandra-vm.your-domain.com 'find /mnt/cassandra/ -name "snapshots" -print0 | tar -cvf - --null -T - | gzip -9 ' > /home/myuser/backup/data/cassandra-batch.tar.gz + + # Backup MinIO files + ssh user@my-minio-server.your-domain.com 'cd /var/lib/ && tar -cf - minio-server1 | gzip -9' > /home/myuser/backup/data/minio-server1-backup.tar.gz + ssh user@my-minio-server.your-domain.com 'cd /var/lib/ && tar -cf - minio-server2 | gzip -9' > /home/myuser/backup/data/minio-server2-backup.tar.gz + + # Tar all backup files into a single unified archive + tar -cf /home/myuser/backup/full-backup.tar /home/myuser/backup/data/* + + # Make remote copies of this single file to remote hosts for redundancy + scp /home/myuser/backup/full-backup.tar user@remote-redundancy-host-one.your-domain.com:/path/to/backup/folder/ + scp /home/myuser/backup/full-backup.tar user@remote-redundancy-host-two.your-domain.com:/path/to/backup/folder/ + +Make the file executable with: + + chmod +x /home/myuser/backup/wire-backup.sh + +You can then manually run the file with: + + ./home/myuser/backup/wire-backup.sh + +As a test, run the script manually to make sure it actually properly does its job without any errors. + +Then, you can add this to your cron file (by running `crontab -e`) to make sure this commands gets executed on a regular basis (here we will use an hourly backup): + + # Edit this file to introduce tasks to be run by cron. + # + # m h dom mon dow command + @hourly /home/myuser/backup/wire-backup.sh + +Your backup should now happen every hour automatically, ensuring you always have a backup at least an hour fresh in case of an emergency. + +There are ways to have incremental backups and to do more complex/refined backup procedure, but those are beyond the scope of this document. You should check out [Borg](https://borgbackup.readthedocs.io/en/stable/). + +You should also set up your monitoring software (for example [Nagios](https://www.nagios.org/)) to check whether your backup file is [older than an hour](https://support.nagios.com/kb/article/file-and-folder-checks-783.html#file_modified), and if it is (meaning something went wrong), warn you immediately. + +## Recovery procedure + +If the worse has happened, and you need to recover/restore your Wire installation, you will need to do the following: + +1. Create a new Wire installation from scratch (following this website or other customer-specific on-premise instructions you used the first time around). +2. While creating this new wire installation, instead of using a fresh/empty `wire-server` folder, you use the `wire-server` folder you backed up above (as it contains your `values` and `secret` files among other important files). +3. Restore your Cassandra backup files over your new Cassandra installation. +4. Restore your MinIO backup files over your new MinIO installation. +5. Restart all services. +6. Ensure all services are functioning correctly + +### Restoring Wire-Server from a backup + +If you correctly backup up your `wire-server` installation, you should have access to a file named `wire-server-backup.tar.gz` (see above). + +You can extract this file to the remote machine with the following command: + + cat wire-server-backup.tar.gz | ssh user@my-wire-server.your-domain.com "cd /path/to/my/folder/for/wire-server/ && tar zxvf -" + +Where : + +* `wire-server-backup.tar.gz` is the name of the file in which your wire-server folder has been stored +* `my-wire-server.your-domain.com` is the domain name or IP address for the server with your Wire install +* `user` is the user you used to install Wire on this server, typically `wire` or `root` +* `/path/to/my/folder/for/wire-server/` is the (absolute) path, on the server, where your wire-server folder is located + +Now all files should be in their proper place, with the proper values, and you should be able to run the required ansible/helm commands that will result in a full installation of Wire. + +### Restoring Cassandra from a backup + +If you correctly backed up your Cassandra database, you should have a series of `snapshot` files, which you now need to restore over your "fresh" (ie. empty) Cassandra installation. + +[This page from the Cassandra documentation](https://docs.datastax.com/en/cassandra-oss/3.0/cassandra/operations/opsBackupSnapshotRestore.html) goes over how to restore from snapshots. + +You should have lots of snapshots from the backup process. This example will go over how to restore one of the snapshots, but you should do this process for **each and every** snapshot you backup up. + +First, transfer and extract the snapshot to the Cassandra Virtual Machine: + + cat cassandra-catalogkeyspace-journal-backup.tar.gz | ssh user@cassandra-vm.your-domain.com "cd /mnt/cassandra/data/data/catalogkeyspace/journal-296a2d30c22a11e9b1350d927649052c/ && tar zxvf -" + +Now the folder `/mnt/cassandra/data/data/catalogkeyspace/journal-296a2d30c22a11e9b1350d927649052c/snapshots/` should contain your snapshot. + +Next, ssh into the Cassandra Virtual Machine and cd to the snapshot folder: + + ssh user@cassandra-vm.your-domain.com + cd /mnt/cassandra/data/data/catalogkeyspace/journal-296a2d30c22a11e9b1350d927649052c/ + +Next run + + ls -lh + +This will show you a list of the snapshots available: + + drwxr-xr-x 2 cassandra cassandra 4.0K May 26 14:45 1653752714460 + drwxr-xr-x 2 cassandra cassandra 4.0K May 28 17:46 1653752759667 + +Select the most recent one (here it is `1653752759667`). + +Finally, use the `sstableloader` file to load the snapshot to Cassandra: + + sstableloader -d localhost /mnt/cassandra/data/data/catalogkeyspace/journal-296a2d30c22a11e9b1350d927649052c/snapshots/1653752759667/ + +This should load the snapshot. + +Repeat this for all snapshots you saved, and you should have a fully restored Cassandra database. + +Finally, restart Cassandra: + + sudo service cassandra restart + +And ensure that it is working properly. + +### Restoring MinIO from a backup + +Restoring MinIO from a backup is as simple as extracting the files (`minio-server1-backup.tar.gz` and `minio-server2-backup.tar.gz` which you have backup up in the backup procedure and should have access to) to the correct remote host (MinIO Virtual Machine), and restarting MinIO: + +First run: + + cat minio-server1-backup.tar.gz | ssh user@my-minio-server.your-domain.com "cd /var/lib/ && tar zxvf -" + cat minio-server2-backup.tar.gz | ssh user@my-minio-server.your-domain.com "cd /var/lib/ && tar zxvf -" + +Where: + +* `user` is the user you used to install Wire on this server, typically `wire` or `root` +* `my-minio-server.your-domain.com` is the domain name or IP address for the MinIO Virtual Machine +* `minio-server[number]-backup.tar.gz` is the name of the file in which each minio data folder was be stored and backup up + +Finally SSH into the server and restart MinIO: + + ssh user@minio-vm.your-domain.com + sudo service minio restart + +Where: + +* `user` is the user you used to install Wire on this server, typically `wire` or `root` +* `minio-vm.your-domain.com` is the domain name or IP address for the server with your MinIO node + diff --git a/docs/src/how-to/install/team-feature-settings.md b/docs/src/how-to/install/team-feature-settings.md index 01e1a8497d1..3697b9b7ef4 100644 --- a/docs/src/how-to/install/team-feature-settings.md +++ b/docs/src/how-to/install/team-feature-settings.md @@ -10,6 +10,8 @@ By default Wire enforces a 2nd factor authentication for certain user operations If the `sndFactorPasswordChallenge` feature is enabled, a 6 digit verification code will be send per email to authenticate for additional user operations like e.g. for login, adding a new client, generating SCIM tokens, or deleting a team. +After 3 attempts, the key is invalidated, and requests for generating new verification codes are rate limited. The default delay between two consecutive requests is 5 minutes. + Usually the default is what you want. If you explicitly want to enable additional password challenges, add the following to your Helm overrides in `values/wire-server/values.yaml`: ```yaml @@ -29,6 +31,20 @@ galley: Note that the lock status is required but has no effect, as it is currently not supported for team admins to enable or disable `sndFactorPasswordChallenge`. We recommend to set the lock status to `locked`. +### Rate limiting of code generation requests + +The default delay between code generation requests is 5 minutes. This setting can be overridden in the Helm charts: + +```yaml +brig: + # ... + config: + # ... + optSettings: + # ... + set2FACodeGenerationDelaySecs: 300 # 5 minutes +``` + ## Guest links The guest link feature is the ability for a Wire users to join a group conversation by tapping on a unique link generated by an admin of that group. diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index 8d5c08b34a9..5a491395858 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -81,6 +81,7 @@ brig: search_policy: full_search - domain: federation-test-helper.{{ .Release.Namespace }}.svc.cluster.local search_policy: full_search + set2FACodeGenerationDelaySecs: 5 aws: sesEndpoint: http://fake-aws-ses:4569 sqsEndpoint: http://fake-aws-sqs:4568 diff --git a/libs/brig-types/src/Brig/Types/Intra.hs b/libs/brig-types/src/Brig/Types/Intra.hs index dde249b3a56..5fcb18e631f 100644 --- a/libs/brig-types/src/Brig/Types/Intra.hs +++ b/libs/brig-types/src/Brig/Types/Intra.hs @@ -33,7 +33,7 @@ where import Data.Aeson import qualified Data.Aeson.KeyMap as KeyMap import Data.Code as Code -import Data.Id (TeamId, UserId) +import Data.Id (TeamId) import Data.Misc (PlainTextPassword (..)) import qualified Data.Text as Text import Imports @@ -144,26 +144,6 @@ instance ToJSON NewUserScimInvitation where "email" .= email ] -------------------------------------------------------------------------------- --- UserList - --- | Set of user ids, can be used for different purposes (e.g., used on the internal --- APIs for listing user's clients) -data UserSet = UserSet - { usUsrs :: !(Set UserId) - } - deriving (Eq, Show, Generic) - -instance FromJSON UserSet where - parseJSON = withObject "user-set" $ \o -> - UserSet <$> o .: "users" - -instance ToJSON UserSet where - toJSON ac = - object - [ "users" .= usUsrs ac - ] - ------------------------------------------------------------------------------- -- ReAuthUser diff --git a/libs/types-common/src/Data/RetryAfter.hs b/libs/types-common/src/Data/RetryAfter.hs new file mode 100644 index 00000000000..e06c6b8bd06 --- /dev/null +++ b/libs/types-common/src/Data/RetryAfter.hs @@ -0,0 +1,24 @@ +-- 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 Data.RetryAfter where + +import Imports + +newtype RetryAfter = RetryAfter + {retryAfterSeconds :: Int64} + deriving (Eq, Show) diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index 66f1952a66d..8444ed2572f 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -30,6 +30,7 @@ library Data.Misc Data.Qualified Data.Range + Data.RetryAfter Data.SizedHashMap Data.Text.Ascii Data.UUID.Tagged diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs index 9bd1f39d154..aff82534191 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs @@ -41,7 +41,7 @@ data Error = Error message :: !LText, errorData :: Maybe ErrorData } - deriving (Show, Typeable) + deriving (Eq, Show, Typeable) mkError :: Status -> LText -> LText -> Error mkError c l m = Error c l m Nothing @@ -52,7 +52,7 @@ data ErrorData = FederationErrorData { federrDomain :: !Domain, federrPath :: !Text } - deriving (Show, Typeable) + deriving (Eq, Show, Typeable) instance ToJSON ErrorData where toJSON (FederationErrorData d p) = 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 016c17cfaca..e93c1f8f65a 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 @@ -25,6 +25,7 @@ import Data.Qualified import Data.Range import Data.Time.Clock (UTCTime) import Imports +import qualified Network.Wai.Utilities.Error as Wai import Servant.API import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) import Wire.API.Conversation @@ -44,8 +45,14 @@ import Wire.API.Util.Aeson (CustomEncoded (..)) -- | For conventions see /docs/developer/federation-api-conventions.md type GalleyApi = - -- | Register a new conversation - FedEndpoint "on-conversation-created" (NewRemoteConversation ConvId) () + -- | Register a new conversation. This is only called on backends of users + -- that are part of a conversation at creation time. Since MLS conversations + -- are always created empty (i.e. they only contain the creator), this RPC is + -- never invoked for such conversations. + FedEndpoint "on-conversation-created" (ConversationCreated ConvId) () + -- This endpoint is called the first time a user from this backend is + -- added to a remote conversation. + :<|> FedEndpoint "on-new-remote-conversation" NewRemoteConversation EmptyResponse :<|> FedEndpoint "get-conversations" GetConversationsRequest GetConversationsResponse -- used by the backend that owns a conversation to inform this backend of -- changes to the conversation @@ -61,6 +68,7 @@ type GalleyApi = :<|> FedEndpoint "update-conversation" ConversationUpdateRequest ConversationUpdateResponse :<|> FedEndpoint "mls-welcome" MLSWelcomeRequest EmptyResponse :<|> FedEndpoint "on-mls-message-sent" RemoteMLSMessage EmptyResponse + :<|> FedEndpoint "send-mls-message" MessageSendRequest MLSMessageResponse data GetConversationsRequest = GetConversationsRequest { gcrUserId :: UserId, @@ -105,31 +113,41 @@ newtype GetConversationsResponse = GetConversationsResponse -- -- FUTUREWORK: Think about extracting common conversation metadata into a -- separarate data type that can be reused in several data types in this module. -data NewRemoteConversation conv = NewRemoteConversation +data ConversationCreated conv = ConversationCreated { -- | The time when the conversation was created - rcTime :: UTCTime, + ccTime :: UTCTime, -- | The user that created the conversation. This is implicitly qualified -- by the requesting domain, since it is impossible to create a regular/group -- conversation on a remote backend. - rcOrigUserId :: UserId, + ccOrigUserId :: UserId, -- | The conversation ID, local to the backend invoking the RPC - rcCnvId :: conv, + ccCnvId :: conv, -- | The conversation type - rcCnvType :: ConvType, - rcCnvAccess :: [Access], - rcCnvAccessRoles :: Set AccessRoleV2, + ccCnvType :: ConvType, + ccCnvAccess :: [Access], + ccCnvAccessRoles :: Set AccessRoleV2, -- | The conversation name, - rcCnvName :: Maybe Text, + ccCnvName :: Maybe Text, -- | Members of the conversation apart from the creator - rcNonCreatorMembers :: Set OtherMember, - rcMessageTimer :: Maybe Milliseconds, - rcReceiptMode :: Maybe ReceiptMode + ccNonCreatorMembers :: Set OtherMember, + ccMessageTimer :: Maybe Milliseconds, + ccReceiptMode :: Maybe ReceiptMode, + ccProtocol :: Protocol } deriving stock (Eq, Show, Generic, Functor) - deriving (ToJSON, FromJSON) via (CustomEncoded (NewRemoteConversation conv)) + deriving (ToJSON, FromJSON) via (CustomEncoded (ConversationCreated conv)) -rcRemoteOrigUserId :: NewRemoteConversation (Remote ConvId) -> Remote UserId -rcRemoteOrigUserId rc = qualifyAs (rcCnvId rc) (rcOrigUserId rc) +ccRemoteOrigUserId :: ConversationCreated (Remote ConvId) -> Remote UserId +ccRemoteOrigUserId cc = qualifyAs (ccCnvId cc) (ccOrigUserId cc) + +data NewRemoteConversation = NewRemoteConversation + { -- | The conversation ID, local to the backend invoking the RPC. + nrcConvId :: ConvId, + -- | The conversation protocol. + nrcProtocol :: Protocol + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON) via (CustomEncoded NewRemoteConversation) data ConversationUpdate = ConversationUpdate { cuTime :: UTCTime, @@ -275,3 +293,11 @@ newtype MLSWelcomeRequest = MLSWelcomeRequest deriving stock (Eq, Generic, Show) deriving (Arbitrary) via (GenericUniform MLSWelcomeRequest) deriving (FromJSON, ToJSON) via (CustomEncoded MLSWelcomeRequest) + +data MLSMessageResponse + = MLSMessageResponseError GalleyError + | MLSMessageResponseProtocolError Text + | MLSMessageResponseProposalFailure Wai.Error + | MLSMessageResponseUpdates [ConversationUpdate] + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON) via (CustomEncoded MLSMessageResponse) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewRemoteConversation.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationCreated.hs similarity index 61% rename from libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewRemoteConversation.hs rename to libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationCreated.hs index bb6484d795f..f66ede73639 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/NewRemoteConversation.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationCreated.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Wire.API.Federation.Golden.NewRemoteConversation where +module Test.Wire.API.Federation.Golden.ConversationCreated where import Data.Domain import Data.Id @@ -25,21 +25,22 @@ import qualified Data.Set as Set import qualified Data.UUID as UUID import Imports import Wire.API.Conversation +import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Federation.API.Galley import Wire.API.Provider.Service -testObject_NewRemoteConversation1 :: NewRemoteConversation ConvId -testObject_NewRemoteConversation1 = - NewRemoteConversation - { rcTime = read "1864-04-12 12:22:43.673 UTC", - rcOrigUserId = Id (fromJust (UUID.fromString "eed9dea3-5468-45f8-b562-7ad5de2587d0")), - rcCnvId = Id (fromJust (UUID.fromString "d13dbe58-d4e3-450f-9c0c-1e632f548740")), - rcCnvType = RegularConv, - rcCnvAccess = [InviteAccess, CodeAccess], - rcCnvAccessRoles = Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole], - rcCnvName = Just "gossip", - rcNonCreatorMembers = +testObject_ConversationCreated1 :: ConversationCreated ConvId +testObject_ConversationCreated1 = + ConversationCreated + { ccTime = read "1864-04-12 12:22:43.673 UTC", + ccOrigUserId = Id (fromJust (UUID.fromString "eed9dea3-5468-45f8-b562-7ad5de2587d0")), + ccCnvId = Id (fromJust (UUID.fromString "d13dbe58-d4e3-450f-9c0c-1e632f548740")), + ccCnvType = RegularConv, + ccCnvAccess = [InviteAccess, CodeAccess], + ccCnvAccessRoles = Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole], + ccCnvName = Just "gossip", + ccNonCreatorMembers = Set.fromList [ OtherMember { omQualifiedId = @@ -64,21 +65,23 @@ testObject_NewRemoteConversation1 = omConvRoleName = roleNameWireMember } ], - rcMessageTimer = Just (Ms 1000), - rcReceiptMode = Just (ReceiptMode 42) + ccMessageTimer = Just (Ms 1000), + ccReceiptMode = Just (ReceiptMode 42), + ccProtocol = ProtocolProteus } -testObject_NewRemoteConversation2 :: NewRemoteConversation ConvId -testObject_NewRemoteConversation2 = - NewRemoteConversation - { rcTime = read "1864-04-12 12:22:43.673 UTC", - rcOrigUserId = Id (fromJust (UUID.fromString "eed9dea3-5468-45f8-b562-7ad5de2587d0")), - rcCnvId = Id (fromJust (UUID.fromString "d13dbe58-d4e3-450f-9c0c-1e632f548740")), - rcCnvType = One2OneConv, - rcCnvAccess = [], - rcCnvAccessRoles = Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole], - rcCnvName = Nothing, - rcNonCreatorMembers = Set.fromList [], - rcMessageTimer = Nothing, - rcReceiptMode = Nothing +testObject_ConversationCreated2 :: ConversationCreated ConvId +testObject_ConversationCreated2 = + ConversationCreated + { ccTime = read "1864-04-12 12:22:43.673 UTC", + ccOrigUserId = Id (fromJust (UUID.fromString "eed9dea3-5468-45f8-b562-7ad5de2587d0")), + ccCnvId = Id (fromJust (UUID.fromString "d13dbe58-d4e3-450f-9c0c-1e632f548740")), + ccCnvType = One2OneConv, + ccCnvAccess = [], + ccCnvAccessRoles = Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole], + ccCnvName = Nothing, + ccNonCreatorMembers = Set.fromList [], + ccMessageTimer = Nothing, + ccReceiptMode = Nothing, + ccProtocol = ProtocolMLS (ConversationMLSData (GroupId "group") (Epoch 3)) } 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 87830a46238..871bfbb0357 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 @@ -19,13 +19,13 @@ module Test.Wire.API.Federation.Golden.GoldenSpec where import Imports import Test.Hspec +import qualified Test.Wire.API.Federation.Golden.ConversationCreated as ConversationCreated import qualified Test.Wire.API.Federation.Golden.ConversationUpdate as ConversationUpdate import qualified Test.Wire.API.Federation.Golden.LeaveConversationRequest as LeaveConversationRequest import qualified Test.Wire.API.Federation.Golden.LeaveConversationResponse as LeaveConversationResponse import qualified Test.Wire.API.Federation.Golden.MessageSendResponse as MessageSendResponse import qualified Test.Wire.API.Federation.Golden.NewConnectionRequest as NewConnectionRequest import qualified Test.Wire.API.Federation.Golden.NewConnectionResponse as NewConnectionResponse -import qualified Test.Wire.API.Federation.Golden.NewRemoteConversation as NewRemoteConversation import Test.Wire.API.Federation.Golden.Runner (testObjects) spec :: Spec @@ -60,6 +60,6 @@ spec = (NewConnectionResponse.testObject_NewConnectionResponse4, "testObject_NewConnectionResponse4.json") ] testObjects - [ (NewRemoteConversation.testObject_NewRemoteConversation1, "testObject_NewRemoteConversation1.json"), - (NewRemoteConversation.testObject_NewRemoteConversation2, "testObject_NewRemoteConversation2.json") + [ (ConversationCreated.testObject_ConversationCreated1, "testObject_ConversationCreated1.json"), + (ConversationCreated.testObject_ConversationCreated2, "testObject_ConversationCreated2.json") ] diff --git a/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation1.json b/libs/wire-api-federation/test/golden/testObject_ConversationCreated1.json similarity index 95% rename from libs/wire-api-federation/test/golden/testObject_NewRemoteConversation1.json rename to libs/wire-api-federation/test/golden/testObject_ConversationCreated1.json index 312092a69a5..54a9b53fb66 100644 --- a/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation1.json +++ b/libs/wire-api-federation/test/golden/testObject_ConversationCreated1.json @@ -36,6 +36,9 @@ } ], "orig_user_id": "eed9dea3-5468-45f8-b562-7ad5de2587d0", + "protocol": { + "protocol": "proteus" + }, "receipt_mode": 42, "time": "1864-04-12T12:22:43.673Z" } \ No newline at end of file diff --git a/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation2.json b/libs/wire-api-federation/test/golden/testObject_ConversationCreated2.json similarity index 78% rename from libs/wire-api-federation/test/golden/testObject_NewRemoteConversation2.json rename to libs/wire-api-federation/test/golden/testObject_ConversationCreated2.json index 24d28af0f71..29e8fb092a4 100644 --- a/libs/wire-api-federation/test/golden/testObject_NewRemoteConversation2.json +++ b/libs/wire-api-federation/test/golden/testObject_ConversationCreated2.json @@ -10,6 +10,11 @@ "message_timer": null, "non_creator_members": [], "orig_user_id": "eed9dea3-5468-45f8-b562-7ad5de2587d0", + "protocol": { + "epoch": 3, + "group_id": "Z3JvdXA=", + "protocol": "mls" + }, "receipt_mode": null, "time": "1864-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 6c15116e1ad..b5791dd2d4f 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -120,6 +120,7 @@ test-suite spec main-is: Spec.hs other-modules: Test.Wire.API.Federation.API.BrigSpec + Test.Wire.API.Federation.Golden.ConversationCreated Test.Wire.API.Federation.Golden.ConversationUpdate Test.Wire.API.Federation.Golden.GoldenSpec Test.Wire.API.Federation.Golden.LeaveConversationRequest @@ -127,7 +128,6 @@ test-suite spec Test.Wire.API.Federation.Golden.MessageSendResponse Test.Wire.API.Federation.Golden.NewConnectionRequest Test.Wire.API.Federation.Golden.NewConnectionResponse - Test.Wire.API.Federation.Golden.NewRemoteConversation Test.Wire.API.Federation.Golden.Runner Paths_wire_api_federation hs-source-dirs: diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index f424a110781..a8cabe01100 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -698,7 +698,6 @@ type ConnectionAPI = Named "update-connection" ( Summary "Update a connection to another user" - :> Until 'V2 :> CanThrow 'MissingLegalholdConsent :> CanThrow 'InvalidUser :> CanThrow 'ConnectionLimitReached diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 9530bd0cdb7..6d47129186b 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -1315,6 +1315,7 @@ type MLSMessagingAPI = :<|> Named "mls-message" ( Summary "Post an MLS message" + :> CanThrow 'ConvAccessDenied :> CanThrow 'ConvNotFound :> CanThrow 'MLSKeyPackageRefNotFound :> CanThrow 'MLSClientMismatch diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs b/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs index d5b53bbac17..90762213689 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs @@ -34,6 +34,7 @@ import Web.Scim.Class.User as Scim.User import Wire.API.Error import Wire.API.Error.Brig import Wire.API.Routes.Public +import Wire.API.User (ScimUserInfos, UserSet) import Wire.API.User.IdentityProvider import Wire.API.User.Saml import Wire.API.User.Scim @@ -124,14 +125,15 @@ type APIINTERNAL = "status" :> Get '[JSON] NoContent :<|> "teams" :> Capture "team" TeamId :> DeleteNoContent :<|> "sso" :> "settings" :> ReqBody '[JSON] SsoSettings :> Put '[JSON] NoContent + :<|> "scim" :> "userinfos" :> ReqBody '[JSON] UserSet :> Post '[JSON] ScimUserInfos -sparSPIssuer :: SAML.HasConfig m => Maybe TeamId -> m SAML.Issuer +sparSPIssuer :: (Functor m, SAML.HasConfig m) => Maybe TeamId -> m SAML.Issuer sparSPIssuer Nothing = SAML.Issuer <$> SAML.getSsoURI (Proxy @APISSO) (Proxy @APIAuthRespLegacy) sparSPIssuer (Just tid) = SAML.Issuer <$> SAML.getSsoURI' (Proxy @APISSO) (Proxy @APIAuthResp) tid -sparResponseURI :: SAML.HasConfig m => Maybe TeamId -> m URI.URI +sparResponseURI :: (Functor m, SAML.HasConfig m) => Maybe TeamId -> m URI.URI sparResponseURI Nothing = SAML.getSsoURI (Proxy @APISSO) (Proxy @APIAuthRespLegacy) sparResponseURI (Just tid) = diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 1760ca872f4..d760ccae654 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -23,6 +23,9 @@ module Wire.API.User ( UserIdList (..), QualifiedUserIdList (..), LimitedQualifiedUserIdList (..), + ScimUserInfo (..), + ScimUserInfos (..), + UserSet (..), -- Profiles UserProfile (..), SelfProfile (..), @@ -892,6 +895,53 @@ instance ToSchema BindingNewTeamUser where <$> bnuTeam .= bindingNewTeamObjectSchema <*> bnuCurrency .= maybe_ (optField "currency" genericToSchema) +-------------------------------------------------------------------------------- +-- SCIM User Info + +data ScimUserInfo = ScimUserInfo + { suiUserId :: UserId, + suiCreatedOn :: Maybe UTCTimeMillis + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform ScimUserInfo) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ScimUserInfo) + +instance ToSchema ScimUserInfo where + schema = + object "ScimUserInfo" $ + ScimUserInfo + <$> suiUserId .= field "id" schema + <*> suiCreatedOn .= maybe_ (optField "created_on" schema) + +newtype ScimUserInfos = ScimUserInfos {scimUserInfos :: [ScimUserInfo]} + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform ScimUserInfos) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ScimUserInfos) + +instance ToSchema ScimUserInfos where + schema = + object "ScimUserInfos" $ + ScimUserInfos + <$> scimUserInfos .= field "scim_user_infos" (array schema) + +------------------------------------------------------------------------------- +-- UserSet + +-- | Set of user ids, can be used for different purposes (e.g., used on the internal +-- APIs for listing user's clients) +newtype UserSet = UserSet + { usUsrs :: Set UserId + } + deriving stock (Eq, Show, Generic) + deriving newtype (Arbitrary) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema UserSet) + +instance ToSchema UserSet where + schema = + object "UserSet" $ + UserSet + <$> usUsrs .= field "users" (set schema) + -------------------------------------------------------------------------------- -- Profile Updates 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 5541f6017e8..0ae4315a5a7 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 @@ -225,6 +225,7 @@ tests = testRoundTrip @(User.LimitedQualifiedUserIdList 20), testRoundTrip @User.UserProfile, testRoundTrip @User.User, + testRoundTrip @User.UserSet, testRoundTrip @User.SelfProfile, testRoundTrip @User.InvitationCode, testRoundTrip @User.BindingNewTeamUser, diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index dd3a691b032..4f7d6ce5b83 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -621,6 +621,7 @@ executable brig-schema V68_AddMLSPublicKeys V69_MLSKeyPackageRefMapping V70_UserEmailUnvalidated + V71_AddTableVCodesThrottle V9 Paths_brig hs-source-dirs: diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index b8f3c35e1a2..16f6ad2c355 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -187,6 +187,7 @@ optSettings: setFederationDomainConfigs: - domain: example.com search_policy: full_search + set2FACodeGenerationDelaySecs: 5 logLevel: Warn # ^ NOTE: We log too much in brig, if we set this to Info like other services, running tests diff --git a/services/brig/schema/src/Main.hs b/services/brig/schema/src/Main.hs index 5d60ec2920d..eb565236d6d 100644 --- a/services/brig/schema/src/Main.hs +++ b/services/brig/schema/src/Main.hs @@ -80,6 +80,7 @@ import qualified V67_MLSKeyPackages import qualified V68_AddMLSPublicKeys import qualified V69_MLSKeyPackageRefMapping import qualified V70_UserEmailUnvalidated +import qualified V71_AddTableVCodesThrottle import qualified V9 main :: IO () @@ -149,7 +150,8 @@ main = do V67_MLSKeyPackages.migration, V68_AddMLSPublicKeys.migration, V69_MLSKeyPackageRefMapping.migration, - V70_UserEmailUnvalidated.migration + V70_UserEmailUnvalidated.migration, + V71_AddTableVCodesThrottle.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Brig.App diff --git a/services/brig/schema/src/V71_AddTableVCodesThrottle.hs b/services/brig/schema/src/V71_AddTableVCodesThrottle.hs new file mode 100644 index 00000000000..7684653ec02 --- /dev/null +++ b/services/brig/schema/src/V71_AddTableVCodesThrottle.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- 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 V71_AddTableVCodesThrottle + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +-- | We need the initial_delay column because we can only retrieve the TTL value from a column that is not part of the PK. +migration :: Migration +migration = + Migration 71 "Add table vcodes_throttle" $ do + schema' + [r| + CREATE TABLE IF NOT EXISTS vcodes_throttle + ( key ascii + , scope int + , initial_delay int, + , PRIMARY KEY (key, scope) + ) + |] diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index f245b220bb6..1f1637199b0 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -191,6 +191,11 @@ deleteUserError DeleteUserInvalidPassword = StdError (errorToWai @'E.BadCredenti deleteUserError DeleteUserMissingPassword = StdError (errorToWai @'E.MissingAuth) deleteUserError (DeleteUserPendingCode t) = RichError deletionCodePending (DeletionCodeTimeout t) [] deleteUserError DeleteUserOwnerDeletingSelf = StdError (errorToWai @'E.OwnerDeletingSelf) +deleteUserError (DeleteUserVerificationCodeThrottled t) = + RichError + verificationCodeThrottled + () + [("Retry-After", toByteString' (retryAfterSeconds t))] accountStatusError :: AccountStatusError -> Error accountStatusError InvalidAccountStatus = StdError invalidAccountStatus @@ -205,6 +210,13 @@ updateProfileError :: UpdateProfileError -> Error updateProfileError DisplayNameManagedByScim = StdError (propertyManagedByScim "name") updateProfileError ProfileNotFound = StdError (errorToWai @'E.UserNotFound) +verificationCodeThrottledError :: VerificationCodeThrottledError -> Error +verificationCodeThrottledError (VerificationCodeThrottled t) = + RichError + verificationCodeThrottled + () + [("Retry-After", toByteString' (retryAfterSeconds t))] + -- WAI Errors ----------------------------------------------------------------- tooManyProperties :: Wai.Error @@ -370,6 +382,9 @@ loginsTooFrequent = Wai.mkError status429 "client-error" "Logins too frequent" tooManyFailedLogins :: Wai.Error tooManyFailedLogins = Wai.mkError status403 "client-error" "Too many failed logins" +verificationCodeThrottled :: Wai.Error +verificationCodeThrottled = Wai.mkError status429 "too-many-requests" "Too many request to generate a verification code." + tooLargeRichInfo :: Wai.Error tooLargeRichInfo = Wai.mkError status413 "too-large-rich-info" "Rich info has exceeded the limit" diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index fa5b63fd018..f30a84351d6 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -1042,7 +1042,7 @@ sendVerificationCode req = do (Code.Retries 3) timeout (Just $ toUUID $ Public.userId $ accountUser account) - wrapClientE $ Code.insert code + tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled sendMail email (Code.codeValue code) (Just $ Public.userLocale $ accountUser account) action _ -> pure () where diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index a2b884d4868..145e1cc327a 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -37,10 +37,10 @@ import Brig.Data.Properties (PropertiesDataError (..)) import Brig.Data.User (AuthError (..), ReAuthError (..)) import Brig.Data.UserKey (UserKey, foldKey) import Brig.Types.Intra -import Brig.User.Auth.Cookie (RetryAfter (..)) import Data.Code import Data.Id import Data.Qualified +import Data.RetryAfter import Imports import qualified Network.Wai.Utilities.Error as Wai import Wire.API.Federation.Error @@ -193,11 +193,15 @@ data DeleteUserError | DeleteUserMissingPassword | DeleteUserPendingCode Timeout | DeleteUserOwnerDeletingSelf + | DeleteUserVerificationCodeThrottled RetryAfter data AccountStatusError = InvalidAccountStatus | AccountNotFound +data VerificationCodeThrottledError + = VerificationCodeThrottled RetryAfter + ------------------------------------------------------------------------------- -- Exceptions diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 13410a5445b..cc956cc9d99 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1110,7 +1110,7 @@ deleteSelfUser uid pwd = do (Code.Retries 3) (Code.Timeout 600) (Just (toUUID uid)) - wrapClientE $ Code.insert c + tryInsertVerificationCode c DeleteUserVerificationCodeThrottled let k = Code.codeKey c let v = Code.codeValue c let l = userLocale (accountUser a) diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 40060ef52be..01607c93bd4 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -26,6 +26,7 @@ module Brig.API.Util exceptTToMaybe, lookupSearchPolicy, ensureLocal, + tryInsertVerificationCode, ) where @@ -33,8 +34,9 @@ import Brig.API.Error import Brig.API.Handler import Brig.API.Types import Brig.App +import qualified Brig.Code as Code import qualified Brig.Data.User as Data -import Brig.Options (FederationDomainConfig, federationDomainConfigs) +import Brig.Options (FederationDomainConfig, federationDomainConfigs, set2FACodeGenerationDelaySecs) import qualified Brig.Options as Opts import Brig.Types.Intra (accountUser) import Control.Lens (view) @@ -118,3 +120,9 @@ ensureLocal :: Qualified a -> AppT r (Local a) ensureLocal x = do loc <- qualifyLocal () foldQualified loc pure (\_ -> throwM federationNotImplemented) x + +tryInsertVerificationCode :: Code.Code -> (RetryAfter -> e) -> ExceptT e (AppT r) () +tryInsertVerificationCode code e = do + ttl <- set2FACodeGenerationDelaySecs <$> view settings + mRetryAfter <- wrapClientE $ Code.insert code ttl + mapM_ (throwE . e) mRetryAfter diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index d32f1c99ef8..7119cb057e2 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -155,7 +155,7 @@ import Wire.Sem.Now (Now) import Wire.Sem.Now.IO schemaVersion :: Int32 -schemaVersion = 70 +schemaVersion = 71 ------------------------------------------------------------------------------- -- Environment diff --git a/services/brig/src/Brig/Code.hs b/services/brig/src/Brig/Code.hs index dac87e3fdfb..5d4c11a0b40 100644 --- a/services/brig/src/Brig/Code.hs +++ b/services/brig/src/Brig/Code.hs @@ -66,6 +66,7 @@ import Cassandra hiding (Value) import qualified Data.ByteString as BS import Data.Code import Data.Range +import Data.RetryAfter (RetryAfter (RetryAfter)) import qualified Data.Text as Text import qualified Data.Text.Ascii as Ascii import qualified Data.Text.Encoding as Text @@ -268,8 +269,29 @@ generate gen scope retries ttl account = do -------------------------------------------------------------------------------- -- Storage -insert :: MonadClient m => Code -> m () -insert c = do +insert :: MonadClient m => Code -> Int -> m (Maybe RetryAfter) +insert code ttl = do + mRetryAfter <- lookupThrottle (codeKey code) (codeScope code) + case mRetryAfter of + Just ra -> pure (Just ra) + Nothing -> do + insertThrottle code ttl + insertInternal code + pure Nothing + where + insertThrottle :: MonadClient m => Code -> Int -> m () + insertThrottle c t = do + let k = codeKey c + let s = codeScope c + retry x5 (write cql (params LocalQuorum (k, s, fromIntegral t, fromIntegral t))) + where + cql :: PrepQuery W (Key, Scope, Int32, Int32) () + cql = + "INSERT INTO vcodes_throttle (key, scope, initial_delay) \ + \VALUES (?, ?, ?) USING TTL ?" + +insertInternal :: MonadClient m => Code -> m () +insertInternal c = do let k = codeKey c let s = codeScope c let v = codeValue c @@ -285,6 +307,16 @@ insert c = do "INSERT INTO vcodes (key, scope, value, retries, email, phone, account) \ \VALUES (?, ?, ?, ?, ?, ?, ?) USING TTL ?" +-- | Check if code generation should be throttled. +lookupThrottle :: MonadClient m => Key -> Scope -> m (Maybe RetryAfter) +lookupThrottle k s = do + fmap (RetryAfter . fromIntegral . runIdentity) <$> retry x1 (query1 cql (params LocalQuorum (k, s))) + where + cql :: PrepQuery R (Key, Scope) (Identity Int32) + cql = + "SELECT ttl(initial_delay) \ + \FROM vcodes_throttle WHERE key = ? AND scope = ?" + -- | Lookup a pending code. lookup :: MonadClient m => Key -> Scope -> m (Maybe Code) lookup k s = fmap (toCode k s) <$> retry x1 (query1 cql (params LocalQuorum (k, s))) @@ -302,7 +334,7 @@ verify k s v = lookup k s >>= maybe (pure Nothing) continue continue c | codeValue c == v = pure (Just c) | codeRetries c > 0 = do - insert (c {codeRetries = codeRetries c - 1}) + insertInternal (c {codeRetries = codeRetries c - 1}) pure Nothing | otherwise = pure Nothing diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 44892270f7d..335cfc91a6b 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -586,7 +586,10 @@ data Settings = Settings setSftListAllServers :: Maybe ListAllSFTServers, setKeyPackageMaximumLifetime :: Maybe NominalDiffTime, -- | When set, development API versions are advertised to clients. - setEnableDevelopmentVersions :: Maybe Bool + setEnableDevelopmentVersions :: Maybe Bool, + -- | Minimum delay in seconds between consecutive attempts to generate a new verification code. + -- use `set2FACodeGenerationDelaySecs` as the getter function which always provides a default value + set2FACodeGenerationDelaySecsInternal :: !(Maybe Int) } deriving (Show, Generic) @@ -608,6 +611,12 @@ setVerificationTimeout = fromMaybe defVerificationTimeout . setVerificationCodeT setDefaultTemplateLocale :: Settings -> Locale setDefaultTemplateLocale = fromMaybe defaultTemplateLocale . setDefaultTemplateLocaleInternal +def2FACodeGenerationDelaySecs :: Int +def2FACodeGenerationDelaySecs = 5 * 60 -- 5 minutes + +set2FACodeGenerationDelaySecs :: Settings -> Int +set2FACodeGenerationDelaySecs = fromMaybe def2FACodeGenerationDelaySecs . set2FACodeGenerationDelaySecsInternal + -- | The analog to `GT.FeatureFlags`. This type tracks only the things that we need to -- express our current cloud business logic. -- @@ -790,6 +799,7 @@ instance FromJSON Settings where "setDefaultUserLocaleInternal" -> "setDefaultUserLocale" "setDefaultTemplateLocaleInternal" -> "setDefaultTemplateLocale" "setVerificationCodeTimeoutInternal" -> "setVerificationTimeout" + "set2FACodeGenerationDelaySecsInternal" -> "set2FACodeGenerationDelaySecs" other -> other } diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 72d5adc6cdd..937cc677955 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -30,7 +30,8 @@ import Bilge.RPC (HasRequestId) import qualified Brig.API.Client as Client import Brig.API.Error import Brig.API.Handler -import Brig.API.Types (PasswordResetError (..)) +import Brig.API.Types (PasswordResetError (..), VerificationCodeThrottledError (VerificationCodeThrottled)) +import Brig.API.Util import Brig.App import qualified Brig.Code as Code import qualified Brig.Data.Client as User @@ -359,7 +360,7 @@ newAccount new = do (Code.Retries 3) (Code.Timeout (3600 * 24)) -- 24h (Just (toUUID pid)) - wrapClientE $ Code.insert code + tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled let key = Code.codeKey code let val = Code.codeValue code lift $ sendActivationMail name email key val False @@ -461,7 +462,7 @@ beginPasswordReset (Public.PasswordReset target) = do (Code.Retries 3) (Code.Timeout 3600) -- 1h (Just (toUUID pid)) - wrapClientE $ Code.insert code + tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled lift $ sendPasswordResetMail target (Code.codeKey code) (Code.codeValue code) completePasswordResetH :: JsonRequest Public.CompletePasswordReset -> (Handler r) Response @@ -530,7 +531,7 @@ updateAccountEmail pid (Public.EmailUpdate new) = do (Code.Retries 3) (Code.Timeout (3600 * 24)) -- 24h (Just (toUUID pid)) - wrapClientE $ Code.insert code + tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled lift $ sendActivationMail (Name "name") email (Code.codeKey code) (Code.codeValue code) True updateAccountPasswordH :: ProviderId ::: JsonRequest Public.PasswordChange -> (Handler r) Response diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 9e7ede54b42..df92a69b717 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -54,6 +54,7 @@ import Data.Id import qualified Data.List as List import qualified Data.Metrics as Metrics import Data.Proxy +import Data.RetryAfter import Data.Time.Clock import Imports import Network.Wai (Response) diff --git a/services/brig/src/Brig/User/Auth/Cookie/Limit.hs b/services/brig/src/Brig/User/Auth/Cookie/Limit.hs index 43a46605dad..fec43c726ed 100644 --- a/services/brig/src/Brig/User/Auth/Cookie/Limit.hs +++ b/services/brig/src/Brig/User/Auth/Cookie/Limit.hs @@ -18,6 +18,7 @@ module Brig.User.Auth.Cookie.Limit where import Data.Aeson +import Data.RetryAfter import Data.Time.Clock import Data.Time.Clock.POSIX import qualified Data.Vector as Vector @@ -71,10 +72,6 @@ data CookieThrottle newtype StdDev = StdDev Double deriving (Eq, Ord, Show, Generic) -newtype RetryAfter = RetryAfter - {retryAfterSeconds :: Int64} - deriving (Eq, Show) - instance FromJSON StdDev instance FromJSON CookieThrottle where diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 932c5521ed0..3ee5369de02 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -234,8 +234,8 @@ testDeleteProvider db brig = do getProvider brig pid !!! const 404 === statusCode -- The email address must be available again let new = defNewProvider (providerEmail prv) - registerProvider brig new - !!! const 201 === statusCode + response <- retryWhileN 10 ((==) 429 . statusCode) $ registerProvider brig new + liftIO $ statusCode response @?= 201 testPasswordResetProvider :: DB.ClientState -> Brig -> Http () testPasswordResetProvider db brig = do diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index bcb1f6565e2..896ab54098d 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -129,7 +129,7 @@ tests conf m z db b g n = test m "test-login-verify6-digit-wrong-code-fails" $ testLoginVerify6DigitWrongCodeFails b g, test m "test-login-verify6-digit-missing-code-fails" $ testLoginVerify6DigitMissingCodeFails b g, test m "test-login-verify6-digit-expired-code-fails" $ testLoginVerify6DigitExpiredCodeFails b g db, - test m "test-login-verify6-digit-resend-code-success" $ testLoginVerify6DigitResendCodeSuccess b g db + test m "test-login-verify6-digit-resend-code-success-and-rate-limiting" $ testLoginVerify6DigitResendCodeSuccessAndRateLimiting b g conf db ] ], testGroup @@ -388,8 +388,8 @@ testLoginVerify6DigitEmailCodeSuccess brig galley db = do Just vcode <- Util.lookupCode db key Code.AccountLogin checkLoginSucceeds $ PasswordLogin (LoginByEmail email) defPassword (Just defCookieLabel) (Just $ Code.codeValue vcode) -testLoginVerify6DigitResendCodeSuccess :: Brig -> Galley -> DB.ClientState -> Http () -testLoginVerify6DigitResendCodeSuccess brig galley db = do +testLoginVerify6DigitResendCodeSuccessAndRateLimiting :: Brig -> Galley -> Opts.Opts -> DB.ClientState -> Http () +testLoginVerify6DigitResendCodeSuccessAndRateLimiting brig galley _opts db = do (u, tid) <- createUserWithTeam' brig let Just email = userEmail u let checkLoginSucceeds body = login brig body PersistentCookie !!! const 200 === statusCode @@ -408,8 +408,10 @@ testLoginVerify6DigitResendCodeSuccess brig galley db = do Util.generateVerificationCode brig (Public.SendVerificationCode Public.Login email) fstCode <- getCodeFromDb - Util.generateVerificationCode brig (Public.SendVerificationCode Public.Login email) - Util.generateVerificationCode brig (Public.SendVerificationCode Public.Login email) + let tooManyRequests = 429 + Util.generateVerificationCodeExpect tooManyRequests brig (Public.SendVerificationCode Public.Login email) + + void $ retryWhileN 10 ((==) 429 . statusCode) $ Util.generateVerificationCode' brig (Public.SendVerificationCode Public.Login email) mostRecentCode <- getCodeFromDb checkLoginFails $ PasswordLogin (LoginByEmail email) defPassword (Just defCookieLabel) (Just $ Code.codeValue fstCode) diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index e93190fce03..09217e441e9 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -517,9 +517,16 @@ matchConvLeaveNotification conv remover removeds n = do sorted x = x generateVerificationCode :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> Public.SendVerificationCode -> m () -generateVerificationCode brig req = do +generateVerificationCode = generateVerificationCodeExpect 200 + +generateVerificationCodeExpect :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Int -> Brig -> Public.SendVerificationCode -> m () +generateVerificationCodeExpect expectedStatus brig req = do + generateVerificationCode' brig req !!! const expectedStatus === statusCode + +generateVerificationCode' :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> Public.SendVerificationCode -> m ResponseLBS +generateVerificationCode' brig req = do let js = RequestBodyLBS $ encode req - post (brig . paths ["verification-code", "send"] . contentJson . body js) !!! const 200 === statusCode + post (brig . paths ["verification-code", "send"] . contentJson . body js) setTeamSndFactorPasswordChallenge :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Galley -> TeamId -> Public.FeatureStatus -> m () setTeamSndFactorPasswordChallenge galley tid status = do diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index bfa77192791..dfa71470cd3 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -93,8 +93,9 @@ spec :: Brig -> Galley -> CargoHold -> + Cannon -> IO TestTree -spec _brigOpts mg brig galley cargohold cannon _federator brigTwo galleyTwo cargoholdTwo = +spec _brigOpts mg brig galley cargohold cannon _federator brigTwo galleyTwo cargoholdTwo cannonTwo = pure $ testGroup "federation-end2end-user" @@ -116,7 +117,7 @@ spec _brigOpts mg brig galley cargohold cannon _federator brigTwo galleyTwo carg test mg "download remote asset" $ testRemoteAsset brig brigTwo cargohold cargoholdTwo, test mg "claim remote key packages" $ claimRemoteKeyPackages brig brigTwo, test mg "send an MLS message to a remote user" $ - testSendMLSMessage brig brigTwo galleyTwo cannon + testSendMLSMessage brig brigTwo galley galleyTwo cannon cannonTwo ] -- | Path covered by this test: @@ -691,8 +692,8 @@ claimRemoteKeyPackages brig1 brig2 = do -- bob creates an MLS conversation on domain 2 with alice on domain 1, then sends a -- message to alice -testSendMLSMessage :: Brig -> Brig -> Galley -> Cannon -> Http () -testSendMLSMessage brig1 brig2 galley2 cannon1 = do +testSendMLSMessage :: Brig -> Brig -> Galley -> Galley -> Cannon -> Cannon -> Http () +testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do let cli :: String -> FilePath -> [String] -> CreateProcess cli store tmp args = proc "mls-test-cli" $ @@ -832,6 +833,32 @@ testSendMLSMessage brig1 brig2 galley2 cannon1 = do spawn (cli bobClientId tmp ["message", "--group", tmp "group.json", "dove"]) Nothing + + -- alice creates the group and replies + void . liftIO $ + spawn + ( cli + aliceClientId + tmp + [ "group", + "from-welcome", + "--group-out", + tmp "groupA.json", + tmp "welcome" + ] + ) + Nothing + reply <- + liftIO $ + spawn + ( cli + aliceClientId + tmp + ["message", "--group", tmp "groupA.json", "raven"] + ) + Nothing + + -- send welcome, commit and dove WS.bracketR cannon1 (userId alice) $ \wsAlice -> do post ( galley2 @@ -894,3 +921,26 @@ testSendMLSMessage brig1 brig2 galley2 cannon1 = do evtType e @?= MLSMessageAdd evtFrom e @?= userQualifiedId bob evtData e @?= EdMLSMessage dove + + -- send the reply and assert reception + WS.bracketR cannon2 (userId bob) $ \wsBob -> do + post + ( galley1 + . paths + ["mls", "messages"] + . zUser (userId alice) + . zConn "conn" + . header "Z-Type" "access" + . content "message/mls" + . bytes reply + ) + !!! const 201 === statusCode + + -- verify that bob receives the reply + WS.assertMatch_ (5 # Second) wsBob $ \n -> do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + evtConv e @?= qconvId + evtType e @?= MLSMessageAdd + evtFrom e @?= userQualifiedId alice + evtData e @?= EdMLSMessage reply diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index 586273d439c..ebeed42cd4c 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -66,6 +66,7 @@ data BackendConf = BackendConf { remoteBrig :: Endpoint, remoteGalley :: Endpoint, remoteCargohold :: Endpoint, + remoteCannon :: Endpoint, remoteFederatorInternal :: Endpoint, remoteFederatorExternal :: Endpoint } @@ -77,6 +78,7 @@ instance FromJSON BackendConf where <$> o .: "brig" <*> o .: "galley" <*> o .: "cargohold" + <*> o .: "cannon" <*> o .: "federatorInternal" <*> o .: "federatorExternal" @@ -110,6 +112,7 @@ runTests iConf brigOpts otherArgs = do s = mkRequest $ spar iConf f = federatorInternal iConf brigTwo = mkRequest $ remoteBrig (backendTwo iConf) + cannonTwo = mkRequest $ remoteCannon (backendTwo iConf) galleyTwo = mkRequest $ remoteGalley (backendTwo iConf) ch2 = mkRequest $ remoteCargohold (backendTwo iConf) @@ -138,7 +141,7 @@ runTests iConf brigOpts otherArgs = do createIndex <- Index.Create.spec brigOpts browseTeam <- TeamUserSearch.tests brigOpts mg g b userPendingActivation <- UserPendingActivation.tests brigOpts mg db b g s - federationEnd2End <- Federation.End2end.spec brigOpts mg b g ch c f brigTwo galleyTwo ch2 + 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 diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index bfa1038b0d6..9fe26c3e598 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -228,7 +228,7 @@ library , retry >=0.5 , safe >=0.3 , safe-exceptions >=0.1 - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , schema-profunctor , semigroups , servant @@ -325,7 +325,7 @@ executable galley , imports , raw-strings-qq >=1.0 , safe >=0.3 - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , servant-client , ssl-util , tagged @@ -456,7 +456,7 @@ executable galley-integration , raw-strings-qq >=1.0 , retry , safe >=0.3 - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , schema-profunctor , servant , servant-client @@ -559,7 +559,7 @@ executable galley-migrate-data , optparse-applicative , raw-strings-qq >=1.0 , safe >=0.3 - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , servant-client , ssl-util , tagged @@ -680,7 +680,7 @@ executable galley-schema , optparse-applicative , raw-strings-qq >=1.0 , safe >=0.3 - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , servant-client , ssl-util , tagged @@ -759,7 +759,7 @@ test-suite galley-tests , lens , raw-strings-qq >=1.0 , safe >=0.3 - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , servant-client , servant-swagger , ssl-util diff --git a/services/galley/package.yaml b/services/galley/package.yaml index b5e192a42b5..7008ec1de4c 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -21,7 +21,7 @@ dependencies: - wire-api-federation - tagged - servant-client -- saml2-web-sso >=0.18 +- saml2-web-sso >=0.19 - transformers library: diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 58b6fd311fd..49f19d5efba 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -24,10 +24,10 @@ module Galley.API.Action HasConversationActionGalleyErrors, -- * Performing actions - updateLocalConversationWithLocalUser, - updateLocalConversationWithLocalUserUnchecked, - updateLocalConversationWithRemoteUser, + updateLocalConversation, + updateLocalConversationUnchecked, NoChanges (..), + LocalConversationUpdate (..), -- * Utilities ensureConversationActionAllowed, @@ -47,7 +47,6 @@ import Data.List.NonEmpty (nonEmpty) import qualified Data.Map as Map import Data.Misc import Data.Qualified -import qualified Data.Set as S import qualified Data.Set as Set import Data.Singletons import Data.Time.Clock @@ -255,32 +254,33 @@ performAction :: (HasConversationActionEffects tag r) => Sing tag -> Qualified UserId -> - Local ConvId -> - Conversation -> + Local Conversation -> ConversationAction tag -> Sem r (BotsAndMembers, ConversationAction tag) -performAction tag origUser lcnv cnv action = +performAction tag origUser lconv action = do + let lcnv = fmap convId lconv + conv = tUnqualified lconv case tag of SConversationJoinTag -> do - performConversationJoin origUser lcnv cnv action + performConversationJoin origUser lconv action SConversationLeaveTag -> do - let presentVictims = filter (isConvMember lcnv cnv) (toList action) + let presentVictims = filter (isConvMemberL lconv) (toList action) when (null presentVictims) noChanges - E.deleteMembers (convId cnv) (toUserList lcnv presentVictims) + E.deleteMembers (tUnqualified lcnv) (toUserList lconv presentVictims) pure (mempty, action) -- FUTUREWORK: should we return the filtered action here? SConversationRemoveMembersTag -> do - let presentVictims = filter (isConvMember lcnv cnv) (toList action) + let presentVictims = filter (isConvMemberL lconv) (toList action) when (null presentVictims) noChanges - E.deleteMembers (convId cnv) (toUserList lcnv presentVictims) + E.deleteMembers (tUnqualified lcnv) (toUserList lconv presentVictims) pure (mempty, action) -- FUTUREWORK: should we return the filtered action here? SConversationMemberUpdateTag -> do - void $ ensureOtherMember lcnv (cmuTarget action) cnv + void $ ensureOtherMember lconv (cmuTarget action) conv E.setOtherMember lcnv (cmuTarget action) (cmuUpdate action) pure (mempty, action) SConversationDeleteTag -> do key <- E.makeKey (tUnqualified lcnv) E.deleteCode key ReusableCode - case convTeam cnv of + case convTeam conv of Nothing -> E.deleteConversation (tUnqualified lcnv) Just tid -> E.deleteTeamConversation tid (tUnqualified lcnv) pure (mempty, action) @@ -289,28 +289,27 @@ performAction tag origUser lcnv cnv action = E.setConversationName (tUnqualified lcnv) cn pure (mempty, action) SConversationMessageTimerUpdateTag -> do - when (Data.convMessageTimer cnv == cupMessageTimer action) noChanges + when (Data.convMessageTimer conv == cupMessageTimer action) noChanges E.setConversationMessageTimer (tUnqualified lcnv) (cupMessageTimer action) pure (mempty, action) SConversationReceiptModeUpdateTag -> do - when (Data.convReceiptMode cnv == Just (cruReceiptMode action)) noChanges + when (Data.convReceiptMode conv == Just (cruReceiptMode action)) noChanges E.setConversationReceiptMode (tUnqualified lcnv) (cruReceiptMode action) pure (mempty, action) SConversationAccessDataTag -> do - (bm, act) <- performConversationAccessData origUser lcnv cnv action + (bm, act) <- performConversationAccessData origUser lconv action pure (bm, act) performConversationJoin :: (HasConversationActionEffects 'ConversationJoinTag r) => Qualified UserId -> - Local ConvId -> - Conversation -> + Local Conversation -> ConversationJoin -> Sem r (BotsAndMembers, ConversationJoin) -performConversationJoin qusr lcnv conv (ConversationJoin invited role) = do - let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited +performConversationJoin qusr lconv (ConversationJoin invited role) = do + let newMembers = ulNewMembers lconv conv . toUserList lconv $ invited - lusr <- ensureLocal lcnv qusr + lusr <- ensureLocal lconv qusr ensureMemberLimit (toList (convLocalMembers conv)) newMembers ensureAccess conv InviteAccess checkLocals lusr (convTeam conv) (ulLocals newMembers) @@ -318,8 +317,11 @@ performConversationJoin qusr lcnv conv (ConversationJoin invited role) = do checkLHPolicyConflictsLocal (ulLocals newMembers) checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) - addMembersToLocalConversation lcnv newMembers role + addMembersToLocalConversation (fmap convId lconv) newMembers role where + conv :: Data.Conversation + conv = tUnqualified lconv + checkLocals :: Members '[ BrigAccess, @@ -408,10 +410,14 @@ performConversationJoin qusr lcnv conv (ConversationJoin invited role) = do then do for_ convUsersLHStatus $ \(mem, status) -> when (consentGiven status == ConsentNotGiven) $ do - let lvictim = qualifyAs lcnv (lmId mem) + let lvictim = qualifyAs lconv (lmId mem) void . runError @NoChanges $ - updateLocalConversationWithLocalUser @'ConversationLeaveTag lcnv lvictim Nothing $ - pure (qUntagged lvictim) + updateLocalConversation + @'ConversationLeaveTag + (fmap convId lconv) + (qUntagged lvictim) + Nothing + $ pure (qUntagged lvictim) else throwS @'MissingLegalholdConsent checkLHPolicyConflictsRemote :: @@ -422,11 +428,10 @@ performConversationJoin qusr lcnv conv (ConversationJoin invited role) = do performConversationAccessData :: (HasConversationActionEffects 'ConversationAccessDataTag r) => Qualified UserId -> - Local ConvId -> - Conversation -> + Local Conversation -> ConversationAccessData -> Sem r (BotsAndMembers, ConversationAccessData) -performConversationAccessData qusr lcnv conv action = do +performConversationAccessData qusr lconv action = do when (convAccessData conv == action) noChanges -- Remove conversation codes if CodeAccess is revoked when @@ -456,10 +461,13 @@ performConversationAccessData qusr lcnv conv action = do -- Remove users and notify everyone void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do - void . runError @NoChanges $ performAction SConversationLeaveTag qusr lcnv conv usersToRemove - notifyConversationAction (sing @'ConversationLeaveTag) qusr Nothing lcnv bmToNotify usersToRemove + void . runError @NoChanges $ performAction SConversationLeaveTag qusr lconv usersToRemove + notifyConversationAction (sing @'ConversationLeaveTag) qusr Nothing lconv bmToNotify usersToRemove pure (mempty, action) where + lcnv = fmap convId lconv + conv = tUnqualified lconv + maybeRemoveBots :: Member BrigAccess r => BotsAndMembers -> Sem r BotsAndMembers maybeRemoveBots bm = if Set.member ServiceAccessRole (cupAccessRoles action) @@ -495,7 +503,12 @@ performConversationAccessData qusr lcnv conv action = do pure $ bm {bmLocals = Set.fromList noTeamMembers} Nothing -> pure bm -updateLocalConversationWithLocalUser :: +data LocalConversationUpdate = LocalConversationUpdate + { lcuEvent :: Event, + lcuUpdate :: ConversationUpdate + } + +updateLocalConversation :: forall tag r. ( Members '[ ConversationStore, @@ -513,11 +526,11 @@ updateLocalConversationWithLocalUser :: SingI tag ) => Local ConvId -> - Local UserId -> + Qualified UserId -> Maybe ConnId -> ConversationAction tag -> - Sem r Event -updateLocalConversationWithLocalUser lcnv lusr con action = do + Sem r LocalConversationUpdate +updateLocalConversation lcnv qusr con action = do let tag = sing @tag -- retrieve conversation @@ -528,7 +541,7 @@ updateLocalConversationWithLocalUser lcnv lusr con action = do throwS @'InvalidOperation -- perform all authorisation checks and, if successful, the update itself - updateLocalConversationWithLocalUserUnchecked @tag conv lusr con action + updateLocalConversationUnchecked @tag (qualifyAs lcnv conv) qusr con action -- | Similar to 'updateLocalConversationWithLocalUser', but takes a -- 'Conversation' value directly, instead of a 'ConvId', and skips protocol @@ -537,7 +550,7 @@ updateLocalConversationWithLocalUser lcnv lusr con action = do -- This is intended to be used by protocol-aware code, once all the -- protocol-specific checks and updates have been performed, to finally apply -- the changes to the conversation as seen by the backend. -updateLocalConversationWithLocalUserUnchecked :: +updateLocalConversationUnchecked :: forall tag r. ( SingI tag, Member (ErrorS ('ActionDenied (ConversationActionPermission tag))) r, @@ -549,91 +562,33 @@ updateLocalConversationWithLocalUserUnchecked :: Member (Input UTCTime) r, HasConversationActionEffects tag r ) => - Conversation -> - Local UserId -> + Local Conversation -> + Qualified UserId -> Maybe ConnId -> ConversationAction tag -> - Sem r Event -updateLocalConversationWithLocalUserUnchecked conv lusr con action = do + Sem r LocalConversationUpdate +updateLocalConversationUnchecked lconv qusr con action = do let tag = sing @tag - lcnv = qualifyAs lusr (convId conv) + lcnv = fmap convId lconv + conv = tUnqualified lconv -- retrieve member - self <- noteS @'ConvNotFound $ getConvMember lusr conv lusr + self <- noteS @'ConvNotFound $ getConvMember lconv conv qusr -- perform checks ensureConversationActionAllowed (sing @tag) lcnv action conv self -- perform action - (extraTargets, action') <- performAction tag (qUntagged lusr) lcnv conv action + (extraTargets, action') <- performAction tag qusr lconv action notifyConversationAction (sing @tag) - (qUntagged lusr) + qusr con - lcnv + lconv (convBotsAndMembers conv <> extraTargets) action' -updateLocalConversationWithRemoteUser :: - forall tag r. - ( Members - '[ ConversationStore, - Error NoChanges, - ErrorS ('ActionDenied (ConversationActionPermission tag)), - ErrorS 'InvalidOperation, - ErrorS 'ConvNotFound, - ExternalAccess, - FederatorAccess, - GundeckAccess, - Input UTCTime - ] - r, - HasConversationActionEffects tag r - ) => - Sing tag -> - Local ConvId -> - Remote UserId -> - ConversationAction tag -> - Sem r ConversationUpdate -updateLocalConversationWithRemoteUser tag lcnv rusr action = do - -- retrieve conversation - (conv, self) <- getConversationAndMemberWithError @'ConvNotFound (qUntagged rusr) lcnv - - -- perform checks - ensureConversationActionAllowed tag lcnv action conv self - - -- perform action - (extraTargets, action') <- performAction tag (qUntagged rusr) lcnv conv action - - -- filter out user from rusr's domain, because rusr's backend will update - -- local state and notify its users itself using the ConversationUpdate - -- returned by this function - let targets = convBotsAndMembers conv <> extraTargets - remotes = bmRemotes targets - remotesUserDomain = S.filter ((== tDomain rusr) . tDomain) remotes - remotesOtherDomain = remotes Set.\\ remotesUserDomain - - void $ - notifyConversationAction - tag - (qUntagged rusr) - Nothing - lcnv - (targets {bmRemotes = remotesOtherDomain}) - action' - - now <- input - - pure $ - ConversationUpdate - { cuTime = now, - cuOrigUserId = qUntagged rusr, - cuConvId = tUnqualified lcnv, - cuAlreadyPresentUsers = tUnqualified <$> S.toList remotesUserDomain, - cuAction = SomeConversationAction tag action' - } - -- -------------------------------------------------------------------------------- -- -- Utilities @@ -684,20 +639,55 @@ notifyConversationAction :: Sing tag -> Qualified UserId -> Maybe ConnId -> - Local ConvId -> + Local Conversation -> BotsAndMembers -> ConversationAction (tag :: ConversationActionTag) -> - Sem r Event -notifyConversationAction tag quid con lcnv targets action = do + Sem r LocalConversationUpdate +notifyConversationAction tag quid con lconv targets action = do now <- input - let e = conversationActionToEvent tag now quid (qUntagged lcnv) action - - E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> - fedClient @'Galley @"on-conversation-updated" $ - ConversationUpdate now quid (tUnqualified lcnv) (tUnqualified ruids) (SomeConversationAction tag action) + let lcnv = fmap convId lconv + conv = tUnqualified lconv + e = conversationActionToEvent tag now quid (qUntagged lcnv) action + + let mkUpdate uids = + ConversationUpdate + now + quid + (tUnqualified lcnv) + uids + (SomeConversationAction tag action) + + -- call `on-new-remote-conversation` on backends that are seeing this + -- conversation for the first time + let newDomains = + Set.difference + (Set.map void (bmRemotes targets)) + (Set.fromList (map (void . rmId) (convRemoteMembers conv))) + let nrc = + NewRemoteConversation + { nrcConvId = convId conv, + nrcProtocol = convProtocol conv + } + E.runFederatedConcurrently_ (toList newDomains) $ \_ -> do + void $ fedClient @'Galley @"on-new-remote-conversation" nrc + + update <- fmap (fromMaybe (mkUpdate []) . asum . map tUnqualified) + . E.runFederatedConcurrently (toList (bmRemotes targets)) + $ \ruids -> do + let update = mkUpdate (tUnqualified ruids) + -- 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 (tDomain ruids == qDomain quid) + then pure (Just update) + else fedClient @'Galley @"on-conversation-updated" update $> Nothing -- notify local participants and bots - pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) $> e + 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 -- | Notify all local members about a remote conversation update that originated -- from a local user @@ -707,14 +697,14 @@ notifyRemoteConversationAction :: ExternalAccess, GundeckAccess, MemberStore, - Input (Local ()), P.TinyLog ] r => + Local x -> Remote ConversationUpdate -> - ConnId -> + Maybe ConnId -> Sem r Event -notifyRemoteConversationAction rconvUpdate con = do +notifyRemoteConversationAction loc rconvUpdate con = do let convUpdate = tUnqualified rconvUpdate rconvId = qualifyAs rconvUpdate . cuConvId $ convUpdate @@ -728,7 +718,6 @@ notifyRemoteConversationAction rconvUpdate con = do -- backend. (presentUsers, allUsersArePresent) <- E.selectRemoteMembers (cuAlreadyPresentUsers convUpdate) rconvId - loc <- qualifyLocal () let localPresentUsers = qualifyAs loc presentUsers unless allUsersArePresent $ @@ -745,4 +734,4 @@ notifyRemoteConversationAction rconvUpdate con = do -- implemented. let bots = [] - pushConversationEvent (Just con) event localPresentUsers bots $> event + pushConversationEvent con event localPresentUsers bots $> event diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index d70fc8a2e99..2826309abaa 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -19,7 +19,7 @@ module Galley.API.Federation where import Control.Error -import Control.Lens (itraversed, (<.>)) +import Control.Lens (itraversed, preview, to, (<.>)) import Data.Bifunctor import Data.ByteString.Conversion (toByteString') import Data.Containers.ListUtils (nubOrd) @@ -39,6 +39,7 @@ import Data.Time.Clock import Galley.API.Action import Galley.API.Error import Galley.API.MLS.KeyPackage +import Galley.API.MLS.Message import Galley.API.MLS.Welcome import qualified Galley.API.Mapping as Mapping import Galley.API.Message @@ -59,6 +60,7 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.Internal.Kind (Append) +import Polysemy.Resource import qualified Polysemy.TinyLog as P import Servant (ServerT) import Servant.API @@ -67,6 +69,7 @@ import Wire.API.Connection import Wire.API.Conversation hiding (Member) import qualified Wire.API.Conversation as Public import Wire.API.Conversation.Action +import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Error import Wire.API.Error.Galley @@ -90,6 +93,7 @@ type FederationAPI = "federation" :> FedApi 'Galley federationSitemap :: ServerT FederationAPI (Sem GalleyEffects) federationSitemap = Named @"on-conversation-created" onConversationCreated + :<|> Named @"on-new-remote-conversation" onNewRemoteConversation :<|> Named @"get-conversations" getConversations :<|> Named @"on-conversation-updated" onConversationUpdated :<|> Named @"leave-conversation" leaveConversation @@ -99,10 +103,12 @@ federationSitemap = :<|> Named @"update-conversation" updateConversation :<|> Named @"mls-welcome" mlsSendWelcome :<|> Named @"on-mls-message-sent" onMLSMessageSent + :<|> Named @"send-mls-message" sendMLSMessage onConversationCreated :: Members '[ BrigAccess, + ConversationStore, GundeckAccess, ExternalAccess, Input (Local ()), @@ -111,17 +117,17 @@ onConversationCreated :: ] r => Domain -> - F.NewRemoteConversation ConvId -> + F.ConversationCreated ConvId -> Sem r () onConversationCreated domain rc = do let qrc = fmap (toRemoteUnsafe domain) rc loc <- qualifyLocal () - let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (F.rcNonCreatorMembers rc))) + let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (F.ccNonCreatorMembers rc))) addedUserIds <- addLocalUsersToRemoteConv - (F.rcCnvId qrc) - (qUntagged (F.rcRemoteOrigUserId qrc)) + (F.ccCnvId qrc) + (qUntagged (F.ccRemoteOrigUserId qrc)) localUserIds let connectedMembers = @@ -132,19 +138,31 @@ onConversationCreated domain rc = do (const True) . omQualifiedId ) - (F.rcNonCreatorMembers rc) + (F.ccNonCreatorMembers rc) -- Make sure to notify only about local users connected to the adder - let qrcConnected = qrc {F.rcNonCreatorMembers = connectedMembers} + let qrcConnected = qrc {F.ccNonCreatorMembers = connectedMembers} - forM_ (fromNewRemoteConversation loc qrcConnected) $ \(mem, c) -> do + for_ (fromConversationCreated loc qrcConnected) $ \(mem, c) -> do let event = Event - (qUntagged (F.rcCnvId qrcConnected)) - (qUntagged (F.rcRemoteOrigUserId qrcConnected)) - (F.rcTime qrcConnected) + (qUntagged (F.ccCnvId qrcConnected)) + (qUntagged (F.ccRemoteOrigUserId qrcConnected)) + (F.ccTime qrcConnected) (EdConversation c) pushConversationEvent Nothing event (qualifyAs loc [qUnqualified . Public.memId $ mem]) [] +onNewRemoteConversation :: + Member ConversationStore r => + Domain -> + F.NewRemoteConversation -> + Sem r EmptyResponse +onNewRemoteConversation domain nrc = do + -- update group_id -> conv_id mapping + for_ (preview (to F.nrcProtocol . _ProtocolMLS) nrc) $ \mls -> + E.setGroupId (cnvmlsGroupId mls) (Qualified (F.nrcConvId nrc) domain) + + pure EmptyResponse + getConversations :: Members '[ConversationStore, Input (Local ())] r => Domain -> @@ -189,8 +207,8 @@ onConversationUpdated requestingDomain cu = do -- Perform action, and determine extra notification targets. -- -- When new users are being added to the conversation, we consider them as - -- notification targets. Once we start checking connections before letting - -- people being added, this will be safe against spam. However, if users that + -- 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. @@ -294,7 +312,14 @@ leaveConversation requestingDomain lc = do . mapError @NoChanges (const F.RemoveFromConversationErrorUnchanged) $ do (conv, _self) <- getConversationAndMemberWithError @'ConvNotFound (qUntagged leaver) lcnv - update <- updateLocalConversationWithRemoteUser SConversationLeaveTag lcnv leaver (pure (qUntagged leaver)) + update <- + lcuUpdate + <$> updateLocalConversation + @'ConversationLeaveTag + lcnv + (qUntagged leaver) + Nothing + (pure (qUntagged leaver)) pure (update, conv) case res of @@ -304,7 +329,14 @@ leaveConversation requestingDomain lc = do let remotes = filter ((== tDomain leaver) . tDomain) (rmId <$> Data.convRemoteMembers conv) let botsAndMembers = BotsAndMembers mempty (Set.fromList remotes) mempty - _event <- notifyConversationAction SConversationLeaveTag (qUntagged leaver) Nothing lcnv botsAndMembers action + _ <- + notifyConversationAction + SConversationLeaveTag + (qUntagged leaver) + Nothing + (qualifyAs lcnv conv) + botsAndMembers + action pure $ F.LeaveConversationResponse (Right ()) @@ -420,7 +452,14 @@ onUserDeleted origDomain udcn = do Public.RegularConv -> do let action = pure untaggedDeletedUser botsAndMembers = convBotsAndMembers conv - void $ notifyConversationAction (sing @'ConversationLeaveTag) untaggedDeletedUser Nothing lc botsAndMembers action + void $ + notifyConversationAction + (sing @'ConversationLeaveTag) + untaggedDeletedUser + Nothing + (qualifyAs lc conv) + botsAndMembers + action pure EmptyResponse updateConversation :: @@ -446,9 +485,7 @@ updateConversation :: ] r ) => - -- Domain -> - -- F.ConversationUpdateRequest -> Sem r ConversationUpdateResponse updateConversation origDomain updateRequest = do @@ -457,42 +494,50 @@ updateConversation origDomain updateRequest = do lcnv = qualifyAs loc (F.curConvId updateRequest) mkResponse $ case F.curAction updateRequest of - SomeConversationAction tag action -> - case tag of - SConversationJoinTag -> - mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationJoinTag) $ - updateLocalConversationWithRemoteUser tag lcnv rusr action - SConversationLeaveTag -> - mapToGalleyError - @(HasConversationActionGalleyErrors 'ConversationLeaveTag) - $ updateLocalConversationWithRemoteUser tag lcnv rusr action - SConversationRemoveMembersTag -> - mapToGalleyError - @(HasConversationActionGalleyErrors 'ConversationRemoveMembersTag) - $ updateLocalConversationWithRemoteUser tag lcnv rusr action - SConversationMemberUpdateTag -> - mapToGalleyError - @(HasConversationActionGalleyErrors 'ConversationMemberUpdateTag) - $ updateLocalConversationWithRemoteUser tag lcnv rusr action - SConversationDeleteTag -> - mapToGalleyError - @(HasConversationActionGalleyErrors 'ConversationDeleteTag) - $ updateLocalConversationWithRemoteUser tag lcnv rusr action - SConversationRenameTag -> - mapToGalleyError - @(HasConversationActionGalleyErrors 'ConversationRenameTag) - $ updateLocalConversationWithRemoteUser tag lcnv rusr action - SConversationMessageTimerUpdateTag -> - mapToGalleyError - @(HasConversationActionGalleyErrors 'ConversationMessageTimerUpdateTag) - $ updateLocalConversationWithRemoteUser tag lcnv rusr action - SConversationReceiptModeUpdateTag -> - mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationReceiptModeUpdateTag) $ - updateLocalConversationWithRemoteUser tag lcnv rusr action - SConversationAccessDataTag -> - mapToGalleyError - @(HasConversationActionGalleyErrors 'ConversationAccessDataTag) - $ updateLocalConversationWithRemoteUser tag lcnv rusr action + SomeConversationAction tag action -> case tag of + SConversationJoinTag -> + mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationJoinTag) + . fmap lcuUpdate + $ updateLocalConversation @'ConversationJoinTag lcnv (qUntagged rusr) Nothing action + SConversationLeaveTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationLeaveTag) + . fmap lcuUpdate + $ updateLocalConversation @'ConversationLeaveTag lcnv (qUntagged rusr) Nothing action + SConversationRemoveMembersTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationRemoveMembersTag) + . fmap lcuUpdate + $ updateLocalConversation @'ConversationRemoveMembersTag lcnv (qUntagged rusr) Nothing action + SConversationMemberUpdateTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationMemberUpdateTag) + . fmap lcuUpdate + $ updateLocalConversation @'ConversationMemberUpdateTag lcnv (qUntagged rusr) Nothing action + SConversationDeleteTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationDeleteTag) + . fmap lcuUpdate + $ updateLocalConversation @'ConversationDeleteTag lcnv (qUntagged rusr) Nothing action + SConversationRenameTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationRenameTag) + . fmap lcuUpdate + $ updateLocalConversation @'ConversationRenameTag lcnv (qUntagged rusr) Nothing action + SConversationMessageTimerUpdateTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationMessageTimerUpdateTag) + . fmap lcuUpdate + $ updateLocalConversation @'ConversationMessageTimerUpdateTag lcnv (qUntagged rusr) Nothing action + SConversationReceiptModeUpdateTag -> + mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationReceiptModeUpdateTag) + . fmap lcuUpdate + $ updateLocalConversation @'ConversationReceiptModeUpdateTag lcnv (qUntagged rusr) Nothing action + SConversationAccessDataTag -> + mapToGalleyError + @(HasConversationActionGalleyErrors 'ConversationAccessDataTag) + . fmap lcuUpdate + $ updateLocalConversation @'ConversationAccessDataTag lcnv (qUntagged rusr) Nothing action where mkResponse = fmap toResponse . runError @GalleyError . runError @NoChanges @@ -500,6 +545,44 @@ updateConversation origDomain updateRequest = do toResponse (Right (Left NoChanges)) = F.ConversationUpdateResponseNoChanges toResponse (Right (Right update)) = F.ConversationUpdateResponseUpdate update +sendMLSMessage :: + ( Members + [ BrigAccess, + ConversationStore, + ExternalAccess, + Error FederationError, + Error InternalError, + FederatorAccess, + GundeckAccess, + Input (Local ()), + Input Opts, + Input UTCTime, + LegalHoldStore, + MemberStore, + Resource, + TeamStore, + P.TinyLog + ] + r + ) => + Domain -> + F.MessageSendRequest -> + Sem r F.MLSMessageResponse +sendMLSMessage remoteDomain msr = + fmap (either (F.MLSMessageResponseProtocolError . unTagged) id) + . runError @MLSProtocolError + . fmap (either F.MLSMessageResponseError id) + . runError + . fmap (either (F.MLSMessageResponseProposalFailure . pfInner) id) + . runError + $ do + loc <- qualifyLocal () + let sender = toRemoteUnsafe remoteDomain (F.msrSender msr) + raw <- either (throw . mlsProtocolError) pure $ decodeMLS' (fromBase64ByteString (F.msrRawMessage msr)) + mapToGalleyError @MLSMessageStaticErrors $ + F.MLSMessageResponseUpdates . map lcuUpdate + <$> postMLSMessage loc (qUntagged sender) Nothing raw + class ToGalleyRuntimeError (effs :: EffectRow) r where mapToGalleyError :: Member (Error GalleyError) r => diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index a8de858a051..ff87ebd5867 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -694,7 +694,7 @@ deleteLoop = do safeForever "deleteLoop" $ do i@(TeamItem tid usr con) <- Q.pop q env <- ask - liftIO (evalGalley env (doDelete usr con tid)) + liftIO (evalGalleyToIO env (doDelete usr con tid)) `catchAny` someError q i where someError q i x = do diff --git a/services/galley/src/Galley/API/MLS.hs b/services/galley/src/Galley/API/MLS.hs index 217398a130c..c2886cdc9bb 100644 --- a/services/galley/src/Galley/API/MLS.hs +++ b/services/galley/src/Galley/API/MLS.hs @@ -15,7 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.MLS (postMLSWelcome, postMLSMessage) where +module Galley.API.MLS + ( postMLSWelcome, + postMLSMessage, + postMLSMessageFromLocalUser, + ) +where import Galley.API.MLS.Message import Galley.API.MLS.Welcome diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index da8cd90a58a..fab451cf17e 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -16,10 +16,16 @@ -- with this program. If not, see . {-# LANGUAGE RecordWildCards #-} -module Galley.API.MLS.Message (postMLSMessage) where +module Galley.API.MLS.Message + ( postMLSMessageFromLocalUser, + postMLSMessage, + MLSMessageStaticErrors, + ) +where import Control.Comonad import Control.Lens (preview, to) +import Data.Bifunctor import Data.Domain import Data.Id import Data.Json.Util @@ -72,11 +78,24 @@ import Wire.API.MLS.Proposal import Wire.API.MLS.Serialisation import Wire.API.Message -postMLSMessage :: +type MLSMessageStaticErrors = + '[ ErrorS 'ConvAccessDenied, + ErrorS 'ConvNotFound, + ErrorS 'MLSUnsupportedMessage, + ErrorS 'MLSStaleMessage, + ErrorS 'MLSProposalNotFound, + ErrorS 'MissingLegalholdConsent, + ErrorS 'MLSKeyPackageRefNotFound, + ErrorS 'MLSClientMismatch, + ErrorS 'MLSUnsupportedProposal + ] + +postMLSMessageFromLocalUser :: ( HasProposalEffects r, Members '[ Resource, Error FederationError, + ErrorS 'ConvAccessDenied, ErrorS 'ConvNotFound, Error InternalError, ErrorS 'MLSUnsupportedMessage, @@ -91,18 +110,70 @@ postMLSMessage :: ConnId -> RawMLS SomeMessage -> Sem r [Event] -postMLSMessage lusr con smsg = case rmValue smsg of - SomeMessage tag msg -> do - -- fetch conversation +postMLSMessageFromLocalUser lusr conn msg = + map lcuEvent + <$> postMLSMessage lusr (qUntagged lusr) (Just conn) msg + +postMLSMessage :: + ( HasProposalEffects r, + Members + '[ Error FederationError, + Error InternalError, + ErrorS 'ConvAccessDenied, + ErrorS 'ConvNotFound, + ErrorS 'MLSUnsupportedMessage, + ErrorS 'MLSStaleMessage, + ErrorS 'MLSProposalNotFound, + ErrorS 'MissingLegalholdConsent, + Resource, + TinyLog + ] + r + ) => + Local x -> + Qualified UserId -> + Maybe ConnId -> + RawMLS SomeMessage -> + Sem r [LocalConversationUpdate] +postMLSMessage loc qusr con smsg = case rmValue smsg of + SomeMessage _ msg -> do + -- fetch conversation ID qcnv <- getConversationIdByGroupId (msgGroupId msg) >>= noteS @'ConvNotFound - lcnv <- ensureLocal lusr qcnv -- FUTUREWORK: allow remote conversations + foldQualified + loc + (postMLSMessageToLocalConv qusr con smsg) + (postMLSMessageToRemoteConv loc qusr con smsg) + qcnv + +postMLSMessageToLocalConv :: + ( HasProposalEffects r, + Members + '[ Error FederationError, + Error InternalError, + ErrorS 'ConvNotFound, + ErrorS 'MLSUnsupportedMessage, + ErrorS 'MLSStaleMessage, + ErrorS 'MLSProposalNotFound, + ErrorS 'MissingLegalholdConsent, + Resource, + TinyLog + ] + r + ) => + Qualified UserId -> + Maybe ConnId -> + RawMLS SomeMessage -> + Local ConvId -> + Sem r [LocalConversationUpdate] +postMLSMessageToLocalConv qusr con smsg lcnv = case rmValue smsg of + SomeMessage tag msg -> do conv <- getConversation (tUnqualified lcnv) >>= noteS @'ConvNotFound -- validate message events <- case tag of SMLSPlainText -> case msgTBS (msgPayload msg) of CommitMessage c -> - processCommit lusr con conv (msgEpoch msg) (msgSender msg) c + processCommit qusr con (qualifyAs lcnv conv) (msgEpoch msg) (msgSender msg) c ApplicationMessage _ -> throwS @'MLSUnsupportedMessage ProposalMessage _ -> pure mempty -- FUTUREWORK: handle proposals SMLSCipherText -> case toMLSEnum' (msgContentType (msgPayload msg)) of @@ -112,15 +183,47 @@ postMLSMessage lusr con smsg = case rmValue smsg of Left _ -> throwS @'MLSUnsupportedMessage -- forward message - propagateMessage lusr conv con (rmRaw smsg) + propagateMessage lcnv qusr conv con (rmRaw smsg) pure events +postMLSMessageToRemoteConv :: + ( Members MLSMessageStaticErrors r, + Members '[Error FederationError, TinyLog] r, + HasProposalEffects r + ) => + Local x -> + Qualified UserId -> + Maybe ConnId -> + RawMLS SomeMessage -> + Remote ConvId -> + Sem r [LocalConversationUpdate] +postMLSMessageToRemoteConv loc qusr con smsg rcnv = do + -- only local users can send messages to remote conversations + lusr <- foldQualified loc pure (\_ -> throwS @'ConvAccessDenied) qusr + resp <- + runFederated rcnv $ + fedClient @'Galley @"send-mls-message" $ + MessageSendRequest + { msrConvId = tUnqualified rcnv, + msrSender = tUnqualified lusr, + msrRawMessage = Base64ByteString (rmRaw smsg) + } + updates <- case resp of + MLSMessageResponseError e -> rethrowErrors @MLSMessageStaticErrors e + MLSMessageResponseProtocolError e -> throw (mlsProtocolError e) + MLSMessageResponseProposalFailure e -> throw (MLSProposalFailure e) + MLSMessageResponseUpdates updates -> pure updates + + for updates $ \update -> do + e <- notifyRemoteConversationAction loc (qualifyAs rcnv update) con + pure (LocalConversationUpdate e update) + type HasProposalEffects r = ( Member BrigAccess r, Member ConversationStore r, - Member (Error MLSProtocolError) r, Member (Error MLSProposalFailure) r, + Member (Error MLSProtocolError) r, Member (ErrorS 'MLSKeyPackageRefNotFound) r, Member (ErrorS 'MLSClientMismatch) r, Member (ErrorS 'MLSUnsupportedProposal) r, @@ -161,19 +264,19 @@ processCommit :: Member (ErrorS 'MissingLegalholdConsent) r, Member Resource r ) => - Local UserId -> - ConnId -> - Data.Conversation -> + Qualified UserId -> + Maybe ConnId -> + Local Data.Conversation -> Epoch -> Sender 'MLSPlainText -> Commit -> - Sem r [Event] -processCommit lusr con conv epoch sender commit = do - self <- noteS @'ConvNotFound $ getConvMember lusr conv lusr + Sem r [LocalConversationUpdate] +processCommit qusr con lconv epoch sender commit = do + self <- noteS @'ConvNotFound $ getConvMember lconv (tUnqualified lconv) qusr -- check epoch number convMeta <- - preview (to convProtocol . _ProtocolMLS) conv + preview (to convProtocol . _ProtocolMLS) (tUnqualified lconv) & noteS @'ConvNotFound let curEpoch = cnvmlsEpoch convMeta @@ -186,26 +289,30 @@ processCommit lusr con conv epoch sender commit = do when (epoch == Epoch 0) $ do -- this is a newly created conversation, and it should contain exactly one -- client (the creator) - case (sender, toList (lmMLSClients self)) of - (MemberSender ref, [creatorClient]) -> do + case (sender, first (toList . lmMLSClients) self) of + (MemberSender ref, Left [creatorClient]) -> do -- register the creator client addKeyPackageRef ref - (qUntagged lusr) + qusr creatorClient - (qUntagged (qualifyAs lusr (Data.convId conv))) + (qUntagged (fmap Data.convId lconv)) + -- remote clients cannot send the first commit + (_, Right _) -> throwS @'MLSStaleMessage + -- uninitialised conversations should contain exactly one client (MemberSender _, _) -> throw (InternalErrorWithDescription "Unexpected creator client set") + -- the sender of the first commit must be a member _ -> throw (mlsProtocolError "Unexpected sender") -- process and execute proposals action <- foldMap applyProposalRef (cProposals commit) - events <- executeProposalAction lusr con conv action + updates <- executeProposalAction qusr con lconv action -- increment epoch number - setConversationEpoch (Data.convId conv) (succ epoch) + setConversationEpoch (Data.convId (tUnqualified lconv)) (succ epoch) - pure events + pure updates applyProposalRef :: ( HasProposalEffects r, @@ -234,6 +341,7 @@ executeProposalAction :: Member (ErrorS 'MLSClientMismatch) r, Member (Error MLSProposalFailure) r, Member (ErrorS 'MissingLegalholdConsent) r, + Member (ErrorS 'MLSUnsupportedProposal) r, Member ExternalAccess r, Member FederatorAccess r, Member GundeckAccess r, @@ -243,26 +351,28 @@ executeProposalAction :: Member MemberStore r, Member TeamStore r ) => - Local UserId -> - ConnId -> - Data.Conversation -> + Qualified UserId -> + Maybe ConnId -> + Local Data.Conversation -> ProposalAction -> - Sem r [Event] -executeProposalAction lusr con conv action = do + Sem r [LocalConversationUpdate] +executeProposalAction qusr con lconv action = do -- For the moment, assume a fixed ciphersuite. -- FUTUREWORK: store ciphersuite with the conversation let cs = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 ss = csSignatureScheme cs - cm = convClientMap lusr conv + cm = convClientMap lconv newUserClients = Map.assocs (paAdd action) -- check that all clients of each user are added to the conversation, and -- update the database accordingly traverse_ (uncurry (addUserClients ss cm)) newUserClients + -- FUTUREWORK: remove this check after remote admins are implemented in federation https://wearezeta.atlassian.net/browse/FS-216 + foldQualified lconv (\_ -> pure ()) (\_ -> throwS @'MLSUnsupportedProposal) qusr -- add users to the conversation and send events result <- foldMap addMembers . nonEmpty . map fst $ newUserClients -- add clients to the database for_ newUserClients $ \(qtarget, newClients) -> do - addMLSClients (qualifyAs lusr (convId conv)) qtarget newClients + addMLSClients (fmap convId lconv) qtarget newClients pure result where addUserClients :: SignatureSchemeTag -> ClientMap -> Qualified UserId -> Set ClientId -> Sem r () @@ -270,36 +380,37 @@ executeProposalAction lusr con conv action = do -- compute final set of clients in the conversation let cs = newClients <> Map.findWithDefault mempty qtarget cm -- get list of mls clients from brig - allClients <- getMLSClients lusr qtarget ss + allClients <- getMLSClients lconv qtarget ss -- if not all clients have been added to the conversation, return an error when (cs /= allClients) $ do -- FUTUREWORK: turn this error into a proper response throwS @'MLSClientMismatch - addMembers :: NonEmpty (Qualified UserId) -> Sem r [Event] + addMembers :: NonEmpty (Qualified UserId) -> Sem r [LocalConversationUpdate] addMembers users = -- FUTUREWORK: update key package ref mapping to reflect conversation membership handleNoChanges . handleMLSProposalFailures @ProposalErrors - . fmap pure - . updateLocalConversationWithLocalUserUnchecked + . fmap (pure) + . updateLocalConversationUnchecked @'ConversationJoinTag - conv - lusr - (Just con) + lconv + qusr + con $ ConversationJoin users roleNameWireMember handleNoChanges :: Monoid a => Sem (Error NoChanges ': r) a -> Sem r a handleNoChanges = fmap fold . runError -convClientMap :: Local x -> Data.Conversation -> ClientMap -convClientMap loc = +convClientMap :: Local Data.Conversation -> ClientMap +convClientMap lconv = mconcat [ foldMap localMember . convLocalMembers, foldMap remoteMember . convRemoteMembers ] + (tUnqualified lconv) where - localMember lm = Map.singleton (qUntagged (qualifyAs loc (lmId lm))) (lmMLSClients lm) + localMember lm = Map.singleton (qUntagged (qualifyAs lconv (lmId lm))) (lmMLSClients lm) remoteMember rm = Map.singleton (qUntagged (rmId rm)) (rmMLSClients rm) -- | Propagate a message. @@ -310,12 +421,13 @@ propagateMessage :: Member (Input UTCTime) r, Member TinyLog r ) => - Local UserId -> + Local x -> + Qualified UserId -> Data.Conversation -> - ConnId -> + Maybe ConnId -> ByteString -> Sem r () -propagateMessage lusr conv con raw = do +propagateMessage loc qusr conv con raw = do -- FUTUREWORK: check the epoch let lmems = Data.convLocalMembers conv botMap = Map.fromList $ do @@ -324,15 +436,13 @@ propagateMessage lusr conv con raw = do pure (lmId m, b) mm = defMessageMetadata now <- input @UTCTime - let lcnv = qualifyAs lusr (Data.convId conv) + let lcnv = qualifyAs loc (Data.convId conv) qcnv = qUntagged lcnv - e = Event qcnv (qUntagged lusr) now $ EdMLSMessage raw - lclients = tUnqualified . clients lusr <$> lmems + e = Event qcnv qusr now $ EdMLSMessage raw + lclients = tUnqualified . clients <$> lmems mkPush :: UserId -> ClientId -> MessagePush 'NormalMessage - mkPush u c = newMessagePush lcnv botMap (Just con) mm (u, c) e - - -- send to locals - runMessagePush lusr (Just qcnv) $ + mkPush u c = newMessagePush lcnv botMap con mm (u, c) e + runMessagePush loc (Just qcnv) $ foldMap (uncurry mkPush) (cToList =<< lclients) -- send to remotes @@ -342,7 +452,7 @@ propagateMessage lusr conv con raw = do fedClient @'Galley @"on-mls-message-sent" $ RemoteMLSMessage { rmmTime = now, - rmmSender = qUntagged lusr, + rmmSender = qusr, rmmMetadata = mm, rmmConversation = tUnqualified lcnv, rmmRecipients = rs >>= remoteMemberMLSClients, @@ -351,8 +461,9 @@ propagateMessage lusr conv con raw = do where cToList :: (UserId, Set ClientId) -> [(UserId, ClientId)] cToList (u, s) = (u,) <$> Set.toList s - clients :: Local x -> LocalMember -> Local (UserId, Set ClientId) - clients loc LocalMember {..} = qualifyAs loc (lmId, lmMLSClients) + + clients :: LocalMember -> Local (UserId, Set ClientId) + clients LocalMember {..} = qualifyAs loc (lmId, lmMLSClients) remoteMemberMLSClients :: RemoteMember -> [(UserId, ClientId)] remoteMemberMLSClients rm = diff --git a/services/galley/src/Galley/API/Public/Servant.hs b/services/galley/src/Galley/API/Public/Servant.hs index b35276edf9f..0d78ea19bdb 100644 --- a/services/galley/src/Galley/API/Public/Servant.hs +++ b/services/galley/src/Galley/API/Public/Servant.hs @@ -159,7 +159,7 @@ servantSitemap = mls :: API MLSAPI GalleyEffects mls = mkNamedAPI @"mls-welcome-message" postMLSWelcome - <@> mkNamedAPI @"mls-message" postMLSMessage + <@> mkNamedAPI @"mls-message" postMLSMessageFromLocalUser customBackend :: API CustomBackendAPI GalleyEffects customBackend = mkNamedAPI @"get-custom-backend-by-domain" getCustomBackendByDomain diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index b9ab3f07a48..d8ad841f396 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -146,7 +146,7 @@ import Wire.API.Team.Permission (Perm (..), Permissions (..), SPerm (..), copy, import Wire.API.Team.Role import Wire.API.Team.SearchVisibility import qualified Wire.API.Team.SearchVisibility as Public -import Wire.API.User (User, UserIdList, UserSSOId (UserScimExternalId), userSCIMExternalId, userSSOId) +import Wire.API.User (ScimUserInfo (..), User, UserIdList, UserSSOId (UserScimExternalId), userSCIMExternalId, userSSOId) import qualified Wire.API.User as U import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) @@ -505,7 +505,7 @@ outputToStreamingBody action = withWeavingToFinal @IO $ \state weave _inspect -> void . weave . (<$ state) $ runOutputSem writeChunk action getTeamMembersCSV :: - (Members '[BrigAccess, ErrorS 'AccessDenied, TeamMemberStore InternalPaging, TeamStore, Final IO] r) => + (Members '[BrigAccess, ErrorS 'AccessDenied, TeamMemberStore InternalPaging, TeamStore, Final IO, SparAccess] r) => Local UserId -> TeamId -> Sem r StreamingBody @@ -522,16 +522,18 @@ getTeamMembersCSV lusr tid = do output headerLine E.withChunks (\mps -> E.listTeamMembers @InternalPaging tid mps maxBound) $ \members -> do - inviters <- lookupInviterHandle members - users <- - lookupUser <$> E.lookupActivatedUsers (fmap (view userId) members) - richInfos <- - lookupRichInfo <$> E.getRichInfoMultiUser (fmap (view userId) members) - numUserClients <- lookupClients <$> E.lookupClients (fmap (view userId) members) + let uids = fmap (view userId) members + teamExportUser <- + mkTeamExportUser + <$> (lookupUser <$> E.lookupActivatedUsers uids) + <*> lookupInviterHandle members + <*> (lookupRichInfo <$> E.getRichInfoMultiUser uids) + <*> (lookupClients <$> E.lookupClients uids) + <*> (lookupScimUserInfo <$> Spar.lookupScimUserInfos uids) output @LByteString ( encodeDefaultOrderedByNameWith defaultEncodeOptions - (mapMaybe (teamExportUser users inviters richInfos numUserClients) members) + (mapMaybe teamExportUser members) ) where headerLine :: LByteString @@ -546,14 +548,15 @@ getTeamMembersCSV lusr tid = do encQuoting = QuoteAll } - teamExportUser :: + mkTeamExportUser :: (UserId -> Maybe User) -> (UserId -> Maybe Handle.Handle) -> (UserId -> Maybe RichInfo) -> (UserId -> Int) -> + (UserId -> Maybe ScimUserInfo) -> TeamMember -> Maybe TeamExportUser - teamExportUser users inviters richInfos numClients member = do + mkTeamExportUser users inviters richInfos numClients scimUserInfo member = do let uid = member ^. userId user <- users uid pure $ @@ -562,7 +565,7 @@ getTeamMembersCSV lusr tid = do tExportHandle = U.userHandle user, tExportEmail = U.userIdentity user >>= U.emailIdentity, tExportRole = permissionsRole . view permissions $ member, - tExportCreatedOn = fmap snd . view invitation $ member, + tExportCreatedOn = maybe (scimUserInfo uid >>= suiCreatedOn) (Just . snd) (view invitation member), tExportInvitedBy = inviters . fst =<< member ^. invitation, tExportIdpIssuer = userToIdPIssuer user, tExportManagedBy = U.userManagedBy user, @@ -593,6 +596,9 @@ getTeamMembersCSV lusr tid = do Just _ -> Nothing Nothing -> Nothing + lookupScimUserInfo :: [ScimUserInfo] -> (UserId -> Maybe ScimUserInfo) + lookupScimUserInfo infos = (`M.lookup` M.fromList (infos <&> (\sui -> (suiUserId sui, sui)))) + lookupUser :: [U.User] -> (UserId -> Maybe U.User) lookupUser users = (`M.lookup` M.fromList (users <&> \user -> (U.userId user, user))) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 9f1ed8e8a93..dc18e0eaef5 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -77,7 +77,6 @@ import qualified Data.Map.Strict as Map import Data.Qualified import qualified Data.Set as Set import Data.Singletons -import qualified Data.Text as T import Data.Time import Galley.API.Action import Galley.API.Error @@ -291,8 +290,8 @@ updateConversationAccess :: Sem r (UpdateResult Event) updateConversationAccess lusr con qcnv update = do lcnv <- ensureLocal lusr qcnv - getUpdateResult $ - updateLocalConversationWithLocalUser @'ConversationAccessDataTag lcnv lusr (Just con) update + getUpdateResult . fmap lcuEvent $ + updateLocalConversation @'ConversationAccessDataTag lcnv (qUntagged lusr) (Just con) update updateConversationAccessUnqualified :: Members UpdateConversationAccessEffects r => @@ -302,10 +301,10 @@ updateConversationAccessUnqualified :: ConversationAccessData -> Sem r (UpdateResult Event) updateConversationAccessUnqualified lusr con cnv update = - getUpdateResult $ - updateLocalConversationWithLocalUser @'ConversationAccessDataTag + getUpdateResult . fmap lcuEvent $ + updateLocalConversation @'ConversationAccessDataTag (qualifyAs lusr cnv) - lusr + (qUntagged lusr) (Just con) update @@ -334,7 +333,15 @@ updateConversationReceiptMode :: updateConversationReceiptMode lusr zcon qcnv update = foldQualified lusr - (\lcnv -> getUpdateResult $ updateLocalConversationWithLocalUser @'ConversationReceiptModeUpdateTag lcnv lusr (Just zcon) update) + ( \lcnv -> + getUpdateResult . fmap lcuEvent $ + updateLocalConversation + @'ConversationReceiptModeUpdateTag + lcnv + (qUntagged lusr) + (Just zcon) + update + ) (\rcnv -> updateRemoteConversation @'ConversationReceiptModeUpdateTag rcnv lusr zcon update) qcnv @@ -374,27 +381,7 @@ updateRemoteConversation rcnv lusr conn action = getUpdateResult $ do ConversationUpdateResponseUpdate convUpdate -> pure convUpdate onConversationUpdated (tDomain rcnv) convUpdate - notifyRemoteConversationAction (qualifyAs rcnv convUpdate) conn - -class RethrowErrors (effs :: EffectRow) r where - rethrowErrors :: GalleyError -> Sem r a - -instance (Member (Error FederationError) r) => RethrowErrors '[] r where - rethrowErrors :: GalleyError -> Sem r a - rethrowErrors err' = throw (FederationUnexpectedError (T.pack . show $ err')) - -instance - ( SingI (e :: GalleyError), - Member (ErrorS e) r, - RethrowErrors effs r - ) => - RethrowErrors (ErrorS e ': effs) r - where - rethrowErrors :: GalleyError -> Sem r a - rethrowErrors err' = - if err' == demote @e - then throwS @e - else rethrowErrors @effs @r err' + notifyRemoteConversationAction lusr (qualifyAs rcnv convUpdate) (Just conn) updateConversationReceiptModeUnqualified :: Members @@ -442,7 +429,15 @@ updateConversationMessageTimer lusr zcon qcnv update = getUpdateResult $ foldQualified lusr - (\lcnv -> updateLocalConversationWithLocalUser @'ConversationMessageTimerUpdateTag lcnv lusr (Just zcon) update) + ( \lcnv -> + lcuEvent + <$> updateLocalConversation + @'ConversationMessageTimerUpdateTag + lcnv + (qUntagged lusr) + (Just zcon) + update + ) (\_ -> throw FederationNotImplemented) qcnv @@ -487,8 +482,8 @@ deleteLocalConversation :: Local ConvId -> Sem r (UpdateResult Event) deleteLocalConversation lusr con lcnv = - getUpdateResult $ - updateLocalConversationWithLocalUser @'ConversationDeleteTag lcnv lusr (Just con) () + getUpdateResult . fmap lcuEvent $ + updateLocalConversation @'ConversationDeleteTag lcnv (qUntagged lusr) (Just con) () getUpdateResult :: Sem (Error NoChanges ': r) a -> Sem r (UpdateResult a) getUpdateResult = fmap (either (const Unchanged) Updated) . runError @@ -766,13 +761,14 @@ joinConversation lusr zcon conv access = do let users = filter (notIsConvMember lusr conv) [tUnqualified lusr] (extraTargets, action) <- addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember - notifyConversationAction - (sing @'ConversationJoinTag) - (qUntagged lusr) - (Just zcon) - lcnv - (convBotsAndMembers conv <> extraTargets) - action + lcuEvent + <$> notifyConversationAction + (sing @'ConversationJoinTag) + (qUntagged lusr) + (Just zcon) + (qualifyAs lusr conv) + (convBotsAndMembers conv <> extraTargets) + action addMembers :: Members @@ -805,8 +801,8 @@ addMembers :: Sem r (UpdateResult Event) addMembers lusr zcon qcnv (InviteQualified users role) = do lcnv <- ensureLocal lusr qcnv - getUpdateResult $ - updateLocalConversationWithLocalUser @'ConversationJoinTag lcnv lusr (Just zcon) $ + getUpdateResult . fmap lcuEvent $ + updateLocalConversation @'ConversationJoinTag lcnv (qUntagged lusr) (Just zcon) $ ConversationJoin users role addMembersUnqualifiedV2 :: @@ -840,8 +836,8 @@ addMembersUnqualifiedV2 :: Sem r (UpdateResult Event) addMembersUnqualifiedV2 lusr zcon cnv (InviteQualified users role) = do let lcnv = qualifyAs lusr cnv - getUpdateResult $ - updateLocalConversationWithLocalUser @'ConversationJoinTag lcnv lusr (Just zcon) $ + getUpdateResult . fmap lcuEvent $ + updateLocalConversation @'ConversationJoinTag lcnv (qUntagged lusr) (Just zcon) $ ConversationJoin users role addMembersUnqualified :: @@ -966,10 +962,10 @@ updateOtherMemberLocalConv :: Qualified UserId -> OtherMemberUpdate -> Sem r () -updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do +updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult . fmap lcuEvent $ do when (qUntagged lusr == qvictim) $ throwS @'InvalidTarget - updateLocalConversationWithLocalUser @'ConversationMemberUpdateTag lcnv lusr (Just con) $ + updateLocalConversation @'ConversationMemberUpdateTag lcnv (qUntagged lusr) (Just con) $ ConversationMemberUpdate qvictim update updateOtherMemberUnqualified :: @@ -1142,17 +1138,15 @@ removeMemberFromLocalConv :: Sem r (Maybe Event) removeMemberFromLocalConv lcnv lusr con victim | qUntagged lusr == victim = - do - fmap hush + fmap (fmap lcuEvent . hush) . runError @NoChanges - . updateLocalConversationWithLocalUser @'ConversationLeaveTag lcnv lusr con + . updateLocalConversation @'ConversationLeaveTag lcnv (qUntagged lusr) con . pure $ victim | otherwise = - do - fmap hush + fmap (fmap lcuEvent . hush) . runError @NoChanges - . updateLocalConversationWithLocalUser @'ConversationRemoveMembersTag lcnv lusr con + . updateLocalConversation @'ConversationRemoveMembersTag lcnv (qUntagged lusr) con . pure $ victim @@ -1398,8 +1392,8 @@ updateLocalConversationName :: ConversationRename -> Sem r (UpdateResult Event) updateLocalConversationName lusr zcon lcnv rename = - getUpdateResult $ - updateLocalConversationWithLocalUser @'ConversationRenameTag lcnv lusr (Just zcon) rename + getUpdateResult . fmap lcuEvent $ + updateLocalConversation @'ConversationRenameTag lcnv (qUntagged lusr) (Just zcon) rename isTypingUnqualified :: Members diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index ff5d02f877d..62908700dd1 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -34,6 +34,7 @@ import Data.Misc (PlainTextPassword (..)) import Data.Qualified import qualified Data.Set as Set import Data.Singletons +import qualified Data.Text as T import Data.Time import Galley.API.Error import qualified Galley.Data.Conversation as Data @@ -336,6 +337,9 @@ class IsConvMember mem => IsConvMemberId uid mem | uid -> mem where notIsConvMember :: Local x -> Data.Conversation -> uid -> Bool notIsConvMember loc conv = not . isConvMember loc conv +isConvMemberL :: IsConvMemberId uid mem => Local Data.Conversation -> uid -> Bool +isConvMemberL lconv = isConvMember lconv (tUnqualified lconv) + instance IsConvMemberId UserId LocalMember where getConvMember _ conv u = find ((u ==) . lmId) (Data.convLocalMembers conv) @@ -606,13 +610,13 @@ runLocalInput :: Local x -> Sem (Input (Local ()) ': r) a -> Sem r a runLocalInput = runInputConst . void -- | Convert an internal conversation representation 'Data.Conversation' to --- 'NewRemoteConversation' to be sent over the wire to a remote backend that will +-- 'ConversationCreated' to be sent over the wire to a remote backend that will -- reconstruct this into multiple public-facing -- 'Wire.API.Conversation.Conversation' values, one per user from that remote -- backend. -- -- FUTUREWORK: Include the team ID as well once it becomes qualified. -toNewRemoteConversation :: +toConversationCreated :: -- | The time stamp the conversation was created at UTCTime -> -- | The domain of the user that created the conversation @@ -620,19 +624,20 @@ toNewRemoteConversation :: -- | The conversation to convert for sending to a remote Galley Data.Conversation -> -- | The resulting information to be sent to a remote Galley - NewRemoteConversation ConvId -toNewRemoteConversation now localDomain Data.Conversation {convMetadata = ConversationMetadata {..}, ..} = - NewRemoteConversation - { rcTime = now, - rcOrigUserId = cnvmCreator, - rcCnvId = convId, - rcCnvType = cnvmType, - rcCnvAccess = cnvmAccess, - rcCnvAccessRoles = cnvmAccessRoles, - rcCnvName = cnvmName, - rcNonCreatorMembers = toMembers (filter (\lm -> lmId lm /= cnvmCreator) convLocalMembers) convRemoteMembers, - rcMessageTimer = cnvmMessageTimer, - rcReceiptMode = cnvmReceiptMode + ConversationCreated ConvId +toConversationCreated now localDomain Data.Conversation {convMetadata = ConversationMetadata {..}, ..} = + ConversationCreated + { ccTime = now, + ccOrigUserId = cnvmCreator, + ccCnvId = convId, + ccCnvType = cnvmType, + ccCnvAccess = cnvmAccess, + ccCnvAccessRoles = cnvmAccessRoles, + ccCnvName = cnvmName, + ccNonCreatorMembers = toMembers (filter (\lm -> lmId lm /= cnvmCreator) convLocalMembers) convRemoteMembers, + ccMessageTimer = cnvmMessageTimer, + ccReceiptMode = cnvmReceiptMode, + ccProtocol = convProtocol } where toMembers :: @@ -644,20 +649,20 @@ toNewRemoteConversation now localDomain Data.Conversation {convMetadata = Conver map (localMemberToOther localDomain) ls <> map remoteMemberToOther rs --- | The function converts a 'NewRemoteConversation' value to a +-- | The function converts a 'ConversationCreated' value to a -- 'Wire.API.Conversation.Conversation' value for each user that is on the given -- domain/backend. The obtained value can be used in e.g. creating an 'Event' to -- be sent out to users informing them that they were added to a new -- conversation. -fromNewRemoteConversation :: +fromConversationCreated :: Local x -> - NewRemoteConversation (Remote ConvId) -> + ConversationCreated (Remote ConvId) -> [(Public.Member, Public.Conversation)] -fromNewRemoteConversation loc rc@NewRemoteConversation {..} = - let membersView = fmap (second Set.toList) . setHoles $ rcNonCreatorMembers +fromConversationCreated loc rc@ConversationCreated {..} = + let membersView = fmap (second Set.toList) . setHoles $ ccNonCreatorMembers creatorOther = OtherMember - (qUntagged (rcRemoteOrigUserId rc)) + (qUntagged (ccRemoteOrigUserId rc)) Nothing roleNameWireAdmin in foldMap @@ -688,20 +693,20 @@ fromNewRemoteConversation loc rc@NewRemoteConversation {..} = conv :: Public.Member -> [OtherMember] -> Public.Conversation conv this others = Public.Conversation - (qUntagged rcCnvId) + (qUntagged ccCnvId) ConversationMetadata - { cnvmType = rcCnvType, + { cnvmType = ccCnvType, -- FUTUREWORK: Document this is the same domain as the conversation -- domain - cnvmCreator = rcOrigUserId, - cnvmAccess = rcCnvAccess, - cnvmAccessRoles = rcCnvAccessRoles, - cnvmName = rcCnvName, + cnvmCreator = ccOrigUserId, + cnvmAccess = ccCnvAccess, + cnvmAccessRoles = ccCnvAccessRoles, + cnvmName = ccCnvName, -- FUTUREWORK: Document this is the same domain as the conversation -- domain. cnvmTeam = Nothing, - cnvmMessageTimer = rcMessageTimer, - cnvmReceiptMode = rcReceiptMode + cnvmMessageTimer = ccMessageTimer, + cnvmReceiptMode = ccReceiptMode } (ConvMembers this others) ProtocolProteus @@ -717,7 +722,7 @@ registerRemoteConversationMemberships :: Sem r () registerRemoteConversationMemberships now localDomain c = do let allRemoteMembers = nubOrd (map rmId (Data.convRemoteMembers c)) - rc = toNewRemoteConversation now localDomain c + rc = toConversationCreated now localDomain c runFederatedConcurrently_ allRemoteMembers $ \_ -> fedClient @'Galley @"on-conversation-created" rc @@ -829,3 +834,26 @@ ensureMemberLimit old new = do let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) when (length old + length new > maxSize) $ throwS @'TooManyMembers + +-------------------------------------------------------------------------------- +-- Handling remote errors + +class RethrowErrors (effs :: EffectRow) r where + rethrowErrors :: GalleyError -> Sem r a + +instance (Member (Error FederationError) r) => RethrowErrors '[] r where + rethrowErrors :: GalleyError -> Sem r a + rethrowErrors err' = throw (FederationUnexpectedError (T.pack . show $ err')) + +instance + ( SingI (e :: GalleyError), + Member (ErrorS e) r, + RethrowErrors effs r + ) => + RethrowErrors (ErrorS e ': effs) r + where + rethrowErrors :: GalleyError -> Sem r a + rethrowErrors err' = + if err' == demote @e + then throwS @e + else rethrowErrors @effs @r err' diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index f5ec7026439..43452af1ae3 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -37,11 +37,10 @@ module Galley.App -- * Running Galley effects GalleyEffects, - evalGalley, + evalGalleyToIO, ask, DeleteItem (..), toServantHandler, - interpretWaiErrorToException, ) where @@ -87,13 +86,14 @@ import qualified Galley.Types.Teams as Teams import Imports hiding (forkIO) import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.OpenSSL +import qualified Network.Wai.Utilities.Error as Wai import OpenSSL.Session as Ssl import qualified OpenSSL.X509.SystemStore as Ssl import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.Internal (Append) -import Polysemy.Resource (Resource, runResource) +import Polysemy.Resource import qualified Polysemy.TinyLog as P import qualified Servant import Ssl.Util @@ -115,8 +115,9 @@ type GalleyEffects0 = -- federation errors can be thrown by almost every endpoint, so we avoid -- having to declare it every single time, and simply handle it here Error FederationError, - Resource, Embed IO, + Error Wai.Error, + Resource, Final IO ] @@ -201,41 +202,37 @@ interpretTinyLog :: interpretTinyLog e = interpret $ \case P.Log l m -> Logger.log (e ^. applog) (Wire.Sem.Logger.toLevel l) (reqIdMsg (e ^. reqId) . m) -toServantHandler :: Env -> Sem GalleyEffects a -> Servant.Handler a -toServantHandler env action = - liftIO $ - evalGalley env action `UnliftIO.catch` \(e :: SomeException) -> do +evalGalleyToIO :: Env -> Sem GalleyEffects a -> IO a +evalGalleyToIO env action = do + r <- + -- log IO exceptions + runExceptT (evalGalley env action) `UnliftIO.catch` \(e :: SomeException) -> do Log.err (env ^. applog) $ Log.msg ("IO Exception occurred" :: ByteString) . Log.field "message" (displayException e) . Log.field "request" (unRequestId (env ^. reqId)) UnliftIO.throwIO e + case r of + -- throw any errors as IO exceptions without logging them + Left e -> UnliftIO.throwIO e + Right a -> pure a -interpretErrorToException :: - (Exception exc, Member (Embed IO) r) => - (err -> exc) -> - Sem (Error err ': r) a -> - Sem r a -interpretErrorToException f = either (embed @IO . UnliftIO.throwIO . f) pure <=< runError - -interpretWaiErrorToException :: - (APIError e, Member (Embed IO) r) => - Sem (Error e ': r) a -> - Sem r a -interpretWaiErrorToException = interpretErrorToException toWai +toServantHandler :: Env -> Sem GalleyEffects a -> Servant.Handler a +toServantHandler env = liftIO . evalGalleyToIO env -evalGalley :: Env -> Sem GalleyEffects a -> IO a +evalGalley :: Env -> Sem GalleyEffects a -> ExceptT Wai.Error IO a evalGalley e = - runFinal @IO - . embedToFinal @IO + ExceptT + . runFinal @IO . runResource - . interpretWaiErrorToException - . interpretWaiErrorToException - . interpretWaiErrorToException + . runError + . embedToFinal @IO + . mapError toWai + . mapError toWai + . mapError toWai . runInputConst e . runInputConst (e ^. cstate) - . interpretWaiErrorToException -- Wai.Error - . interpretWaiErrorToException -- DynError + . mapError toWai -- DynError . interpretTinyLog e . interpretQueue (e ^. deleteQueue) . runInputSem (embed getCurrentTime) -- FUTUREWORK: could we take the time only once instead? diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index a865ae7088f..be8a4dd882b 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -88,7 +88,6 @@ import Galley.Effects.TeamStore import Galley.Effects.WaiRoutes import Galley.Env import Galley.Options -import qualified Network.Wai.Utilities.Error as Wai import Polysemy import Polysemy.Error import Polysemy.Input @@ -127,6 +126,5 @@ type GalleyEffects1 = Input UTCTime, Queue DeleteItem, TinyLog, - Error Wai.Error, Error DynError ] diff --git a/services/galley/src/Galley/Effects/SparAccess.hs b/services/galley/src/Galley/Effects/SparAccess.hs index b0ad427be86..4b9b0df882d 100644 --- a/services/galley/src/Galley/Effects/SparAccess.hs +++ b/services/galley/src/Galley/Effects/SparAccess.hs @@ -21,8 +21,10 @@ module Galley.Effects.SparAccess where import Data.Id import Polysemy +import Wire.API.User (ScimUserInfo) data SparAccess m a where DeleteTeam :: TeamId -> SparAccess m () + LookupScimUserInfos :: [UserId] -> SparAccess m [ScimUserInfo] makeSem ''SparAccess diff --git a/services/galley/src/Galley/Intra/Effects.hs b/services/galley/src/Galley/Intra/Effects.hs index bbb837b5ed9..f516c171d90 100644 --- a/services/galley/src/Galley/Intra/Effects.hs +++ b/services/galley/src/Galley/Intra/Effects.hs @@ -91,6 +91,7 @@ interpretSparAccess :: Sem r a interpretSparAccess = interpret $ \case DeleteTeam tid -> embedApp $ deleteTeam tid + LookupScimUserInfos uids -> embedApp $ lookupScimUserInfos uids interpretBotAccess :: Members '[Embed IO, Input Env] r => diff --git a/services/galley/src/Galley/Intra/Spar.hs b/services/galley/src/Galley/Intra/Spar.hs index 510aa3720f7..e9429ca2448 100644 --- a/services/galley/src/Galley/Intra/Spar.hs +++ b/services/galley/src/Galley/Intra/Spar.hs @@ -17,16 +17,19 @@ module Galley.Intra.Spar ( deleteTeam, + lookupScimUserInfos, ) where import Bilge import Data.ByteString.Conversion import Data.Id +import qualified Data.Set as Set import Galley.Intra.Util import Galley.Monad import Imports import Network.HTTP.Types.Method +import Wire.API.User (ScimUserInfo, UserSet (..), scimUserInfos) -- | Notify Spar that a team is being deleted. deleteTeam :: TeamId -> App () @@ -35,3 +38,13 @@ deleteTeam tid = do method DELETE . paths ["i", "teams", toByteString' tid] . expect2xx + +-- | Get the SCIM user info for a user. +lookupScimUserInfos :: [UserId] -> App [ScimUserInfo] +lookupScimUserInfos uids = do + response <- + call Spar $ + method POST + . paths ["i", "scim", "userinfos"] + . json (UserSet $ Set.fromList uids) + pure $ maybe mempty scimUserInfos $ responseJsonMaybe response diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 7f4b2455632..a82a7f3a721 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -105,7 +105,7 @@ mkApp opts = pure (middlewares $ servantApp env, env) where rtree = compile API.sitemap - runGalley e r k = evalGalley e (route rtree r k) + runGalley e r k = evalGalleyToIO e (route rtree r k) -- the servant API wraps the one defined using wai-routing servantApp e0 r = let e = reqId .~ lookupReqId r $ e0 diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 5d3777cd10c..644df340f6f 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -90,6 +90,7 @@ import Wire.API.Conversation.Typing import Wire.API.Event.Conversation import Wire.API.Federation.API import qualified Wire.API.Federation.API.Brig as F +import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import qualified Wire.API.Federation.API.Galley as F import Wire.API.Internal.Notification @@ -322,15 +323,15 @@ postConvWithRemoteUsersOk = do liftIO $ do length federatedRequests @?= 2 - F.rcOrigUserId cFedReqBody @?= alice - F.rcCnvId cFedReqBody @?= cid - F.rcCnvType cFedReqBody @?= RegularConv - F.rcCnvAccess cFedReqBody @?= [InviteAccess] - F.rcCnvAccessRoles cFedReqBody @?= Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole, ServiceAccessRole] - F.rcCnvName cFedReqBody @?= Just nameMaxSize - F.rcNonCreatorMembers cFedReqBody @?= Set.fromList (toOtherMember <$> [qAlex, qAmy, qChad, qCharlie, qDee]) - F.rcMessageTimer cFedReqBody @?= Nothing - F.rcReceiptMode cFedReqBody @?= Nothing + F.ccOrigUserId cFedReqBody @?= alice + F.ccCnvId cFedReqBody @?= cid + F.ccCnvType cFedReqBody @?= RegularConv + F.ccCnvAccess cFedReqBody @?= [InviteAccess] + F.ccCnvAccessRoles cFedReqBody @?= Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole, ServiceAccessRole] + F.ccCnvName cFedReqBody @?= Just nameMaxSize + F.ccNonCreatorMembers cFedReqBody @?= Set.fromList (toOtherMember <$> [qAlex, qAmy, qChad, qCharlie, qDee]) + F.ccMessageTimer cFedReqBody @?= Nothing + F.ccReceiptMode cFedReqBody @?= Nothing dFedReqBody @?= cFedReqBody where @@ -2304,8 +2305,8 @@ testAddRemoteMember = do postQualifiedMembers alice (remoteBob :| []) convId pure () + galleyApi _ = + mkHandler @(FedApi 'Galley) $ + (Named @"on-new-remote-conversation" $ \_ _ -> pure EmptyResponse) + :<|> (Named @"on-conversation-updated" $ \_ _ -> pure ()) (_, received) <- withTempServantMockFederator brigApi galleyApi localDomain $ do postQualifiedMembers alice (remoteBob :| []) convId @@ -3667,17 +3673,18 @@ removeUser = do now <- liftIO getCurrentTime fedGalleyClient <- view tsFedGalleyClient let nc cid creator quids = - F.NewRemoteConversation - { F.rcTime = now, - F.rcOrigUserId = qUnqualified creator, - F.rcCnvId = cid, - F.rcCnvType = RegularConv, - F.rcCnvAccess = [], - F.rcCnvAccessRoles = Set.fromList [], - F.rcCnvName = Just "gossip4", - F.rcNonCreatorMembers = Set.fromList $ createOtherMember <$> quids, - F.rcMessageTimer = Nothing, - F.rcReceiptMode = Nothing + F.ConversationCreated + { F.ccTime = now, + F.ccOrigUserId = qUnqualified creator, + F.ccCnvId = cid, + F.ccCnvType = RegularConv, + F.ccCnvAccess = [], + F.ccCnvAccessRoles = Set.fromList [], + F.ccCnvName = Just "gossip4", + F.ccNonCreatorMembers = Set.fromList $ createOtherMember <$> quids, + F.ccMessageTimer = Nothing, + F.ccReceiptMode = Nothing, + F.ccProtocol = ProtocolProteus } runFedClient @"on-conversation-created" fedGalleyClient bDomain $ nc convB1 bart [alice, alexDel] runFedClient @"on-conversation-created" fedGalleyClient bDomain $ nc convB2 bart [alexDel] diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 6cac0503bfc..9d9eda39be0 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -92,8 +92,7 @@ tests s = 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/mls-welcome : Post an MLS welcome message received from another backend" sendMLSWelcome, - test s "POST /federation/mls-welcome : Post an MLS welcome message (key package ref not found)" sendMLSWelcomeKeyPackageNotFound, - test s "POST /federation/on-mls-message-sent" onMLSMessageSent + test s "POST /federation/mls-welcome : Post an MLS welcome message (key package ref not found)" sendMLSWelcomeKeyPackageNotFound ] getConversationsAllFound :: TestM () @@ -685,9 +684,8 @@ leaveConversationSuccess = do void . WS.assertMatch (3 # Second) wsBob $ wsAssertMembersLeave qconvId qChad [qChad] - let [remote1GalleyFederatedRequest] = fedRequestsForDomain remoteDomain1 Galley federatedRequests - [remote2GalleyFederatedRequest] = fedRequestsForDomain remoteDomain2 Galley federatedRequests - assertLeaveUpdate remote1GalleyFederatedRequest qconvId qChad [qUnqualified qChad, qUnqualified qDee] qChad + liftIO $ fedRequestsForDomain remoteDomain1 Galley federatedRequests @?= [] + let [remote2GalleyFederatedRequest] = fedRequestsForDomain remoteDomain2 Galley federatedRequests assertLeaveUpdate remote2GalleyFederatedRequest qconvId qChad [qUnqualified qEve] qChad leaveConversationNonExistent :: TestM () @@ -1026,17 +1024,10 @@ onUserDeleted = do -- not part of any other conversations with bob. WS.assertNoEvent (1 # Second) [wsAlice, wsAlex] - -- There should be only 2 RPC calls made only for groupConvId: 1 for bob's - -- domain and 1 for eve's domain - assertEqual ("Expected 2 RPC calls, got: " <> show rpcCalls) 2 (length rpcCalls) - - -- Assertions about RPC to bDomain - bobDomainRPC <- assertOne $ filter (\c -> frTargetDomain c == bDomain) rpcCalls - bobDomainRPCReq <- assertRight $ parseFedRequest bobDomainRPC - FedGalley.cuOrigUserId bobDomainRPCReq @?= qUntagged bob - FedGalley.cuConvId bobDomainRPCReq @?= qUnqualified groupConvId - sort (FedGalley.cuAlreadyPresentUsers bobDomainRPCReq) @?= sort [tUnqualified bob, qUnqualified bart] - FedGalley.cuAction bobDomainRPCReq @?= SomeConversationAction (sing @'ConversationLeaveTag) (pure $ qUntagged bob) + -- There should be only 1 RPC call made to eve's domain for groupConvId. + -- Bob's domain does not get a notification, because it's the one making + -- the request. + assertEqual ("Expected 1 RPC calls, got: " <> show rpcCalls) 1 (length rpcCalls) -- Assertions about RPC to 'cDomain' cDomainRPC <- assertOne $ filter (\c -> frTargetDomain c == cDomain) rpcCalls @@ -1192,60 +1183,6 @@ sendMLSWelcomeKeyPackageNotFound = do -- check that no event is received WS.assertNoEvent (1 # Second) [wsB] -onMLSMessageSent :: TestM () -onMLSMessageSent = do - localDomain <- viewFederationDomain - c <- view tsCannon - alice <- randomUser - eve <- randomUser - bob <- randomId - conv <- randomId - let aliceC1 = newClientId 0 - aliceC2 = newClientId 1 - eveC = newClientId 0 - bdom = Domain "bob.example.com" - qconv = Qualified conv bdom - qbob = Qualified bob bdom - qalice = Qualified alice localDomain - now <- liftIO getCurrentTime - fedGalleyClient <- view tsFedGalleyClient - - -- only add alice to the remote conversation - connectWithRemoteUser alice qbob - let cu = - FedGalley.ConversationUpdate - { FedGalley.cuTime = now, - FedGalley.cuOrigUserId = qbob, - FedGalley.cuConvId = conv, - FedGalley.cuAlreadyPresentUsers = [], - FedGalley.cuAction = - SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) - } - runFedClient @"on-conversation-updated" fedGalleyClient bdom cu - - let txt = "Hello from another backend" - rcpts = [(alice, aliceC1), (alice, aliceC2), (eve, eveC)] - rm = - FedGalley.RemoteMLSMessage - { FedGalley.rmmTime = now, - FedGalley.rmmMetadata = defMessageMetadata, - FedGalley.rmmSender = qbob, - FedGalley.rmmConversation = conv, - FedGalley.rmmRecipients = rcpts, - FedGalley.rmmMessage = Base64ByteString txt - } - - -- send message to alice and check reception - WS.bracketAsClientRN c [(alice, aliceC1), (alice, aliceC2), (eve, eveC)] $ \[wsA1, wsA2, wsE] -> do - void $ runFedClient @"on-mls-message-sent" fedGalleyClient bdom rm - liftIO $ do - -- alice should receive the message on her first client - WS.assertMatch_ (5 # Second) wsA1 $ \n -> wsAssertMLSMessage qconv qbob txt n - WS.assertMatch_ (5 # Second) wsA2 $ \n -> wsAssertMLSMessage qconv qbob txt n - - -- eve should not receive the message - WS.assertNoEvent (1 # Second) [wsE] - getConvAction :: Sing tag -> SomeConversationAction -> Maybe (ConversationAction tag) getConvAction tquery (SomeConversationAction tag action) = case (tag, tquery) of diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index bc902c42c1f..3d8f25675e0 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -35,27 +35,29 @@ import Data.List1 hiding (head) import Data.Qualified import Data.Range import qualified Data.Set as Set +import Data.Singletons import Data.String.Conversions import qualified Data.Text as T -import Federator.MockServer +import Data.Time +import Federator.MockServer hiding (withTempMockFederator) import Imports import qualified Network.Wai.Utilities.Error as Wai import System.FilePath import System.IO.Temp import Test.Tasty -import Test.Tasty.Cannon ((#)) +import Test.Tasty.Cannon (TimeoutUnit (Second), (#)) import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import TestHelpers import TestSetup import Wire.API.Conversation import Wire.API.Conversation.Action +import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role import Wire.API.Event.Conversation import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import Wire.API.MLS.Group (convToGroupId) -import Wire.API.MLS.Message import Wire.API.Message tests :: IO TestSetup -> TestTree @@ -86,9 +88,24 @@ tests s = ], testGroup "Application Message" - [ test s "send application message" testAppMessage, - test s "send remote application message" testRemoteAppMessage, - test s "another participant sends an application message" testAppMessage2 + [ testGroup + "Local Sender/Local Conversation" + [ test s "send application message" testAppMessage, + test s "send remote application message" testRemoteAppMessage, + test s "another participant sends an application message" testAppMessage2 + ], + testGroup + "Local Sender/Remote Conversation" + [ test s "send application message" testLocalToRemote + ], + testGroup + "Remote Sender/Local Conversation" + [ test s "POST /federation/send-mls-message" testRemoteToLocal + ], + testGroup + "Remote Sender/Remote Conversation" + [ test s "POST /federation/on-mls-message-sent" testRemoteToRemote + ] -- all is mocked ], testGroup "Protocol mismatch" @@ -290,7 +307,7 @@ testAddUserWithProteusClients = do pure participants -- alice creates a conversation and adds Bob's MLS clients - conversation <- setupGroup tmp CreateConv alice "group" + (groupId, conversation) <- setupGroup tmp CreateConv alice "group" (commit, welcome) <- liftIO $ setupCommit tmp alice "group" "group" (pClients bob) pure MessagingSetup {creator = alice, ..} @@ -328,7 +345,7 @@ testAddNewClient = do withSystemTempDirectory "mls" $ \tmp -> withLastPrekeys $ do -- bob starts with a single client (creator, users@[bob]) <- setupParticipants tmp def [(1, LocalUser)] - conversation <- lift $ setupGroup tmp CreateConv creator "group" + (groupId, conversation) <- lift $ setupGroup tmp CreateConv creator "group" -- creator sends first commit message do @@ -337,8 +354,8 @@ testAddNewClient = do do -- then bob adds a new client - (qcid, c) <- setupUserClient tmp CreateWithKey True (pUserId bob) - let bobC = (qcid, c) + c <- setupUserClient tmp CreateWithKey True (pUserId bob) + let bobC = (userClientQid (pUserId bob) c, c) -- which gets added to the group (commit, welcome) <- liftIO $ setupCommit tmp creator "group" "group" [bobC] -- and the corresponding commit is sent @@ -396,7 +413,7 @@ testProteusMessage = do testStaleCommit :: TestM () testStaleCommit = withSystemTempDirectory "mls" $ \tmp -> do (creator, users) <- withLastPrekeys $ setupParticipants tmp def ((,LocalUser) <$> [2, 3]) - conversation <- setupGroup tmp CreateConv creator "group.0" + (groupId, conversation) <- setupGroup tmp CreateConv creator "group.0" let (users1, users2) = splitAt 1 users -- add the first batch of users to the conversation, but do not overwrite group @@ -428,6 +445,7 @@ testAddRemoteUser = do bob <- assertOne (users setup) let mock req = case frRPC req of "on-conversation-updated" -> pure (Aeson.encode ()) + "on-new-remote-conversation" -> pure (Aeson.encode EmptyResponse) "get-mls-clients" -> pure . Aeson.encode @@ -470,7 +488,7 @@ testCommitLock :: TestM () testCommitLock = withSystemTempDirectory "mls" $ \tmp -> do -- create MLS conversation (creator, users) <- withLastPrekeys $ setupParticipants tmp def ((,LocalUser) <$> [2, 2, 2]) - conversation <- setupGroup tmp CreateConv creator "group" + (groupId, conversation) <- setupGroup tmp CreateConv creator "group" let (users1, usersX) = splitAt 1 users let (users2, users3) = splitAt 1 usersX void $ assertOne users1 @@ -541,7 +559,7 @@ testRemoteAppMessage = withSystemTempDirectory "mls" $ \tmp -> do (alice, [bob]) <- withLastPrekeys $ setupParticipants tmp opts [(1, RemoteUser (Domain "faraway.example.com"))] - conversation <- setupGroup tmp CreateConv alice "group" + (groupId, conversation) <- setupGroup tmp CreateConv alice "group" (commit, welcome) <- liftIO $ setupCommit tmp alice "group" "group" (pClients bob) message <- liftIO $ @@ -549,6 +567,7 @@ testRemoteAppMessage = withSystemTempDirectory "mls" $ \tmp -> do let mock req = case frRPC req of "on-conversation-updated" -> pure (Aeson.encode ()) + "on-new-remote-conversation" -> pure (Aeson.encode EmptyResponse) "on-mls-message-sent" -> pure (Aeson.encode EmptyResponse) "get-mls-clients" -> pure @@ -587,10 +606,120 @@ testRemoteAppMessage = withSystemTempDirectory "mls" $ \tmp -> do liftIO $ assertBool "Unexpected events returned" (null events) +-- The following test happens within backend B +-- Alice@A is remote and Bob@B is local +-- Alice creates a remote conversation and invites Bob +-- Bob sends a message to the conversion +-- +-- In reality, the following steps would happen: +-- +-- 1) alice creates a new conversation @A -> convId, groupID +-- 2) alice creates an MLS group (locally) with bob in it -> commit, welcome +-- 3) alice sends commit +-- 4) A notifies B about the new conversation +-- 5) A notifies B about bob being in the conversation (Join event) +-- 6) B notifies bob about join event +-- 7) alice sends welcome @A +-- 8) A forwards welcome to B +-- 9) B forwards welcome to bob +-- 10) bob creates his view on the group (locally) using the welcome message +-- +-- 11) bob crafts a message (locally) +-- 12) bob sends the message @B +-- 13) B forwards the message to A +-- 14) A forwards the message to alice +-- +-- In the test: +-- +-- setup: 2 10 11 +-- skipped: 1 3 5 6 7 8 9 13 +-- faked: 4 +-- actual test step: 12 14 +testLocalToRemote :: TestM () +testLocalToRemote = withSystemTempDirectory "mls" $ \tmp -> do + let domain = Domain "faraway.example.com" + -- step 2 + MessagingSetup {creator = alice, users = [bob], ..} <- + aliceInvitesBobWithTmp + tmp + (1, LocalUser) + def + { creatorOrigin = RemoteUser domain + } + + -- step 10 + void . liftIO $ + spawn + ( cli + (pClientQid bob) + tmp + [ "group", + "from-welcome", + "--group-out", + tmp "groupB.json", + tmp "welcome" + ] + ) + Nothing + -- step 11 + message <- + liftIO $ + spawn + ( cli + (pClientQid bob) + tmp + ["message", "--group", tmp "groupB.json", "hi"] + ) + Nothing + + fedGalleyClient <- view tsFedGalleyClient + + -- register remote conversation: step 4 + qcnv <- randomQualifiedId (qDomain (pUserId alice)) + let nrc = + NewRemoteConversation (qUnqualified qcnv) $ + ProtocolMLS (ConversationMLSData groupId (Epoch 1)) + void $ + runFedClient + @"on-new-remote-conversation" + fedGalleyClient + (qDomain (pUserId alice)) + nrc + + let mock req = case frRPC req of + "send-mls-message" -> pure (Aeson.encode (MLSMessageResponseUpdates [])) + rpc -> assertFailure $ "unmocked RPC called: " <> T.unpack rpc + + (_, reqs) <- withTempMockFederator' mock $ do + galley <- viewGalley + + -- bob sends a message: step 12 + post + ( galley . paths ["mls", "messages"] + . zUser (qUnqualified (pUserId bob)) + . zConn "conn" + . content "message/mls" + . bytes message + ) + !!! const 201 + === statusCode + + -- check requests to mock federator: step 14 + liftIO $ do + req <- assertOne reqs + frRPC req @?= "send-mls-message" + frTargetDomain req @?= qDomain qcnv + bdy <- case Aeson.eitherDecode (frBody req) of + Right b -> pure b + Left e -> assertFailure $ "Could not parse send-mls-message request body: " <> e + msrConvId bdy @?= qUnqualified qcnv + msrSender bdy @?= qUnqualified (pUserId bob) + msrRawMessage bdy @?= Base64ByteString message + testAppMessage :: TestM () testAppMessage = withSystemTempDirectory "mls" $ \tmp -> do (creator, users) <- withLastPrekeys $ setupParticipants tmp def ((,LocalUser) <$> [1, 2, 3]) - conversation <- setupGroup tmp CreateConv creator "group" + (groupId, conversation) <- setupGroup tmp CreateConv creator "group" (commit, welcome) <- liftIO $ @@ -627,7 +756,7 @@ testAppMessage2 :: TestM () testAppMessage2 = do (MessagingSetup {..}, message) <- withSystemTempDirectory "mls" $ \tmp -> do (creator, users) <- withLastPrekeys $ setupParticipants tmp def ((,LocalUser) <$> [2, 1]) - conversation <- setupGroup tmp CreateConv creator "group" + (groupId, conversation) <- setupGroup tmp CreateConv creator "group" (commit, welcome) <- liftIO $ @@ -686,3 +815,124 @@ testAppMessage2 = do liftIO $ WS.assertMatchN_ (5 # WS.Second) wss $ wsAssertMLSMessage conversation (pUserId bob) message + +testRemoteToRemote :: TestM () +testRemoteToRemote = do + localDomain <- viewFederationDomain + c <- view tsCannon + alice <- randomUser + eve <- randomUser + bob <- randomId + conv <- randomId + let aliceC1 = newClientId 0 + aliceC2 = newClientId 1 + eveC = newClientId 0 + bdom = Domain "bob.example.com" + qconv = Qualified conv bdom + qbob = Qualified bob bdom + qalice = Qualified alice localDomain + now <- liftIO getCurrentTime + fedGalleyClient <- view tsFedGalleyClient + + -- only add alice to the remote conversation + connectWithRemoteUser alice qbob + let cu = + ConversationUpdate + { cuTime = now, + cuOrigUserId = qbob, + cuConvId = conv, + cuAlreadyPresentUsers = [], + cuAction = + SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) + } + runFedClient @"on-conversation-updated" fedGalleyClient bdom cu + + let txt = "Hello from another backend" + rcpts = [(alice, aliceC1), (alice, aliceC2), (eve, eveC)] + rm = + RemoteMLSMessage + { rmmTime = now, + rmmMetadata = defMessageMetadata, + rmmSender = qbob, + rmmConversation = conv, + rmmRecipients = rcpts, + rmmMessage = Base64ByteString txt + } + + -- send message to alice and check reception + WS.bracketAsClientRN c [(alice, aliceC1), (alice, aliceC2), (eve, eveC)] $ \[wsA1, wsA2, wsE] -> do + void $ runFedClient @"on-mls-message-sent" fedGalleyClient bdom rm + liftIO $ do + -- alice should receive the message on her first client + WS.assertMatch_ (5 # Second) wsA1 $ \n -> wsAssertMLSMessage qconv qbob txt n + WS.assertMatch_ (5 # Second) wsA2 $ \n -> wsAssertMLSMessage qconv qbob txt n + + -- eve should not receive the message + WS.assertNoEvent (1 # Second) [wsE] + +testRemoteToLocal :: TestM () +testRemoteToLocal = do + -- alice is local, bob is remote + -- alice creates a local conversation and invites bob + -- bob then sends a message to the conversation + + let bobDomain = Domain "faraway.example.com" + + -- Simulate the whole MLS setup for both clients first. In reality, + -- backend calls would need to happen in order for bob to get ahold of a + -- welcome message, but that should not affect the correctness of the test. + + (MessagingSetup {..}, message) <- withSystemTempDirectory "mls" $ \tmp -> do + setup <- + aliceInvitesBobWithTmp + tmp + (1, RemoteUser bobDomain) + def + { createConv = CreateConv + } + let bob = head (users setup) + void . liftIO $ + spawn + ( cli + (pClientQid bob) + tmp + [ "group", + "from-welcome", + "--group-out", + tmp "groupB.json", + tmp "welcome" + ] + ) + Nothing + message <- + liftIO $ + spawn + ( cli + (pClientQid bob) + tmp + ["message", "--group", tmp "groupB.json", "hello from another backend"] + ) + Nothing + pure (setup, message) + + let bob = head users + let alice = creator + + fedGalleyClient <- view tsFedGalleyClient + cannon <- view tsCannon + + -- actual test + + let msr = + MessageSendRequest + { msrConvId = qUnqualified conversation, + msrSender = qUnqualified (pUserId bob), + msrRawMessage = Base64ByteString message + } + + WS.bracketR cannon (qUnqualified (pUserId alice)) $ \ws -> do + resp <- runFedClient @"send-mls-message" fedGalleyClient bobDomain msr + liftIO $ do + resp @?= MLSMessageResponseUpdates [] + WS.assertMatch_ (5 # Second) ws $ + wsAssertMLSMessage conversation (pUserId bob) message diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 3b06fc34029..4f6618661b1 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -89,27 +89,41 @@ data MessagingSetup = MessagingSetup { creator :: Participant, users :: [Participant], conversation :: Qualified ConvId, + groupId :: GroupId, welcome :: ByteString, commit :: ByteString } deriving (Show) +cli :: String -> FilePath -> [String] -> CreateProcess +cli store tmp args = + proc "mls-test-cli" $ + ["--store", tmp (store <> ".db")] <> args + data Participant = Participant { pUserId :: Qualified UserId, - pClients :: NonEmpty (String, ClientId) + pClientIds :: NonEmpty ClientId } deriving (Show) -cli :: String -> FilePath -> [String] -> CreateProcess -cli store tmp args = - proc "mls-test-cli" $ - ["--store", tmp (store <> ".db")] <> args +userClientQid :: Qualified UserId -> ClientId -> String +userClientQid usr c = + show (qUnqualified usr) + <> ":" + <> T.unpack (client c) + <> "@" + <> T.unpack (domainText (qDomain usr)) + +pClients :: Participant -> NonEmpty (String, ClientId) +pClients p = + pClientIds p <&> \c -> + (userClientQid (pUserId p) c, c) pClientQid :: Participant -> String -pClientQid = fst . NonEmpty.head . pClients +pClientQid p = userClientQid (pUserId p) (NonEmpty.head (pClientIds p)) pClientId :: Participant -> ClientId -pClientId = snd . NonEmpty.head . pClients +pClientId = NonEmpty.head . pClientIds setupUserClient :: HasCallStack => @@ -118,7 +132,7 @@ setupUserClient :: -- | Whether to claim/map the key package Bool -> Qualified UserId -> - State.StateT [LastPrekey] TestM (String, ClientId) + State.StateT [LastPrekey] TestM ClientId setupUserClient tmp doCreateClients mapKeyPackage usr = do localDomain <- lift viewFederationDomain lpk <- takeLastPrekey @@ -128,12 +142,7 @@ setupUserClient tmp doCreateClients mapKeyPackage usr = do DontCreateClients -> liftIO $ generate arbitrary _ -> randomClient (qUnqualified usr) lpk - let qcid = - show (qUnqualified usr) - <> ":" - <> T.unpack (client c) - <> "@" - <> T.unpack (domainText (qDomain usr)) + let qcid = userClientQid usr c -- generate key package void . liftIO $ spawn (cli qcid tmp ["init", qcid]) Nothing @@ -162,7 +171,7 @@ setupUserClient tmp doCreateClients mapKeyPackage usr = do when mapKeyPackage $ mapRemoteKeyPackageRef brig bundle _ -> pure () - pure (qcid, c) + pure c setupParticipant :: HasCallStack => @@ -187,14 +196,14 @@ setupParticipants :: setupParticipants tmp SetupOptions {..} ns = do creator <- do u <- lift $ createUserOrId creatorOrigin - let createCreatorClients = case creatorOrigin of - LocalUser -> createClients - RemoteUser _ -> DontCreateClients + let createCreatorClients = createClientsForUR creatorOrigin createClients c0 <- setupUserClient tmp createCreatorClients False u cs <- replicateM (numCreatorClients - 1) (setupUserClient tmp createCreatorClients True u) pure (Participant u (c0 :| cs)) - others <- for ns $ \(n, ur) -> - lift (createUserOrId ur) >>= fmap (,ur) . setupParticipant tmp createClients n + others <- for ns $ \(n, ur) -> do + qusr <- lift (createUserOrId ur) + participant <- setupParticipant tmp (createClientsForUR ur createClients) n qusr + pure (participant, ur) lift . when makeConnections $ do for_ others $ \(o, ur) -> case (creatorOrigin, ur) of (LocalUser, LocalUser) -> @@ -217,10 +226,19 @@ setupParticipants tmp SetupOptions {..} ns = do LocalUser -> randomQualifiedUser RemoteUser d -> randomQualifiedId d + createClientsForUR LocalUser cc = cc + createClientsForUR (RemoteUser _) _ = DontCreateClients + withLastPrekeys :: Monad m => State.StateT [LastPrekey] m a -> m a withLastPrekeys m = State.evalStateT m someLastPrekeys -setupGroup :: HasCallStack => FilePath -> CreateConv -> Participant -> String -> TestM (Qualified ConvId) +setupGroup :: + HasCallStack => + FilePath -> + CreateConv -> + Participant -> + String -> + TestM (GroupId, Qualified ConvId) setupGroup tmp createConv creator name = do (mGroupId, conversation) <- case createNewConv (pClientId creator) createConv of Nothing -> pure (Nothing, error "No conversation created") @@ -231,13 +249,23 @@ setupGroup tmp createConv creator name = do pure (preview (to cnvProtocol . _ProtocolMLS . to cnvmlsGroupId) conv, cnvQualifiedId conv) - let groupId = toBase64Text (maybe "test_group" unGroupId mGroupId) + groupId <- case mGroupId of + Just gid -> pure gid + -- generate a random group id + Nothing -> liftIO $ fmap (GroupId . BS.pack) (replicateM 32 (generate arbitrary)) + groupJSON <- liftIO $ - spawn (cli (pClientQid creator) tmp ["group", "create", T.unpack groupId]) Nothing + spawn + ( cli + (pClientQid creator) + tmp + ["group", "create", T.unpack (toBase64Text (unGroupId groupId))] + ) + Nothing liftIO $ BS.writeFile (tmp name) groupJSON - pure conversation + pure (groupId, conversation) setupCommit :: (HasCallStack, Foldable f) => @@ -286,10 +314,19 @@ takeLastPrekey = do -- Alice depending on the passed in creator origin. Return welcome and commit -- message. aliceInvitesBob :: HasCallStack => (Int, UserOrigin) -> SetupOptions -> TestM MessagingSetup -aliceInvitesBob bobConf opts@SetupOptions {..} = withSystemTempDirectory "mls" $ \tmp -> do +aliceInvitesBob bobConf opts = withSystemTempDirectory "mls" $ \tmp -> + aliceInvitesBobWithTmp tmp bobConf opts + +aliceInvitesBobWithTmp :: + HasCallStack => + FilePath -> + (Int, UserOrigin) -> + SetupOptions -> + TestM MessagingSetup +aliceInvitesBobWithTmp tmp bobConf opts@SetupOptions {..} = do (alice, [bob]) <- withLastPrekeys $ setupParticipants tmp opts [bobConf] -- create a group - conversation <- setupGroup tmp createConv alice "group" + (groupId, conversation) <- setupGroup tmp createConv alice "group" -- add clients to it and get welcome message (commit, welcome) <- diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index ea7ee57259c..809fc3bab30 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -292,6 +292,7 @@ testListTeamMembersDefaultLimit = do -- | for ad-hoc load-testing, set @numMembers@ to, say, 10k and see what -- happens. but please don't give that number to our ci! :) +-- for additional tests of the CSV download particularly with SCIM users, please refer to 'Test.Spar.Scim.UserSpec' testListTeamMembersCsv :: HasCallStack => Int -> TestM () testListTeamMembersCsv numMembers = do let teamSize = numMembers + 1 diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index eb1262b3e87..709a3cc7205 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -82,15 +82,14 @@ tests s = testGroup "Conference calling" [ test s "ConferenceCalling unlimited TTL" $ testSimpleFlagTTL @Public.ConferenceCallingConfig Public.FeatureStatusEnabled FeatureTTLUnlimited, - test s "ConferenceCalling 1s TTL" $ testSimpleFlagTTL @Public.ConferenceCallingConfig Public.FeatureStatusEnabled (FeatureTTLSeconds 1), test s "ConferenceCalling 2s TTL" $ testSimpleFlagTTL @Public.ConferenceCallingConfig Public.FeatureStatusEnabled (FeatureTTLSeconds 2) ], testGroup "Overrides" - [ test s "increase to unlimited" $ testSimpleFlagTTLOverride @Public.ConferenceCallingConfig Public.FeatureStatusEnabled (FeatureTTLSeconds 1) FeatureTTLUnlimited, - test s "increase" $ testSimpleFlagTTLOverride @Public.ConferenceCallingConfig Public.FeatureStatusEnabled (FeatureTTLSeconds 1) (FeatureTTLSeconds 2), - test s "reduce from unlimited" $ testSimpleFlagTTLOverride @Public.ConferenceCallingConfig Public.FeatureStatusEnabled FeatureTTLUnlimited (FeatureTTLSeconds 1), - test s "reduce" $ testSimpleFlagTTLOverride @Public.ConferenceCallingConfig Public.FeatureStatusEnabled (FeatureTTLSeconds 5) (FeatureTTLSeconds 1), + [ test s "increase to unlimited" $ testSimpleFlagTTLOverride @Public.ConferenceCallingConfig Public.FeatureStatusEnabled (FeatureTTLSeconds 2) FeatureTTLUnlimited, + test s "increase" $ testSimpleFlagTTLOverride @Public.ConferenceCallingConfig Public.FeatureStatusEnabled (FeatureTTLSeconds 2) (FeatureTTLSeconds 4), + test s "reduce from unlimited" $ testSimpleFlagTTLOverride @Public.ConferenceCallingConfig Public.FeatureStatusEnabled FeatureTTLUnlimited (FeatureTTLSeconds 2), + test s "reduce" $ testSimpleFlagTTLOverride @Public.ConferenceCallingConfig Public.FeatureStatusEnabled (FeatureTTLSeconds 5) (FeatureTTLSeconds 2), test s "Unlimited to unlimited" $ testSimpleFlagTTLOverride @Public.ConferenceCallingConfig Public.FeatureStatusEnabled FeatureTTLUnlimited FeatureTTLUnlimited ], test s "MLS feature config" testMLS, @@ -391,8 +390,7 @@ testSimpleFlagTTLOverride defaultValue ttl ttlAfter = do storedTTL <- maybe Nothing runIdentity <$> Cql.runClient cassState (Cql.query1 select $ params LocalQuorum (Identity tid)) storedTTL @?= Nothing - half = 500000 - seconds = 1000000 + toMicros secs = fromIntegral secs * 1000000 assertFlagForbidden $ Util.getTeamFeatureFlag @cfg nonMember tid @@ -414,17 +412,17 @@ testSimpleFlagTTLOverride defaultValue ttl ttlAfter = do case (ttl, ttlAfter) of (FeatureTTLSeconds d, FeatureTTLSeconds d') -> do -- wait less than expiration, override and recheck. - liftIO $ threadDelay (fromIntegral d * half) -- waiting half of TTL + liftIO $ threadDelay (toMicros d `div` 2) -- waiting half of TTL setFlagInternal otherValue ttlAfter -- value is still correct getFlag otherValue - liftIO $ threadDelay (fromIntegral d' * seconds) -- waiting for new TTL + liftIO $ threadDelay (toMicros d') -- waiting for new TTL getFlag defaultValue assertUnlimited -- TTL should be NULL after expiration. (FeatureTTLSeconds d, FeatureTTLUnlimited) -> do -- wait less than expiration, override and recheck. - liftIO $ threadDelay (fromIntegral d * half) -- waiting half of TTL + liftIO $ threadDelay (fromIntegral d `div` 2) -- waiting half of TTL setFlagInternal otherValue ttlAfter -- value is still correct getFlag otherValue @@ -445,7 +443,7 @@ testSimpleFlagTTLOverride defaultValue ttl ttlAfter = do getFeatureConfig otherValue getFlagInternal otherValue - liftIO $ threadDelay (fromIntegral d * seconds) -- waiting it out + liftIO $ threadDelay (toMicros d) -- waiting it out -- value reverts back getFlag defaultValue -- TTL should be NULL inside cassandra diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 8600eac0f58..de13c45a14a 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -22,14 +22,8 @@ import qualified API.SQS as SQS import Bilge hiding (timeout) import Bilge.Assert import Bilge.TestSession --- import Galley.Types --- import Galley.Types.Conversations.Intra --- import Galley.Types.Conversations.One2One (one2OneConvId) --- import Galley.Types.Conversations.Roles hiding (DeleteConversation) --- import Galley.Types.Teams hiding (Event, EventType (..), self) - import Brig.Types.Connection -import Brig.Types.Intra (UserAccount (..), UserSet (..)) +import Brig.Types.Intra (UserAccount (..)) import Control.Concurrent.Async import Control.Exception (throw) import Control.Lens hiding (from, to, (#), (.=)) @@ -116,17 +110,7 @@ import qualified Wire.API.Event.Team as TE import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Domain (originDomainHeaderName) -import Wire.API.Internal.Notification - ( Notification (..), - NotificationId, - QueuedNotification, - QueuedNotificationList, - queuedHasMore, - queuedNotificationId, - queuedNotificationPayload, - queuedNotifications, - queuedTime, - ) +import Wire.API.Internal.Notification hiding (target) import Wire.API.MLS.Serialisation import Wire.API.Message import qualified Wire.API.Message.Proto as Proto @@ -1409,17 +1393,18 @@ registerRemoteConv convId originUser name othMembers = do fedGalleyClient <- view tsFedGalleyClient now <- liftIO getCurrentTime runFedClient @"on-conversation-created" fedGalleyClient (qDomain convId) $ - NewRemoteConversation - { rcTime = now, - rcOrigUserId = originUser, - rcCnvId = qUnqualified convId, - rcCnvType = RegularConv, - rcCnvAccess = [], - rcCnvAccessRoles = Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole], - rcCnvName = name, - rcNonCreatorMembers = othMembers, - rcMessageTimer = Nothing, - rcReceiptMode = Nothing + ConversationCreated + { ccTime = now, + ccOrigUserId = originUser, + ccCnvId = qUnqualified convId, + ccCnvType = RegularConv, + ccCnvAccess = [], + ccCnvAccessRoles = Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole], + ccCnvName = name, + ccNonCreatorMembers = othMembers, + ccMessageTimer = Nothing, + ccReceiptMode = Nothing, + ccProtocol = ProtocolProteus } getFeatureStatusMulti :: forall cfg. (IsFeatureConfig cfg, KnownSymbol (FeatureSymbol cfg)) => Multi.TeamFeatureNoConfigMultiRequest -> TestM ResponseLBS @@ -2511,7 +2496,7 @@ withTempMockFederator' resp action = do $ \mockPort -> do withSettingsOverrides (\opts -> opts & Opts.optFederator ?~ Endpoint "127.0.0.1" (fromIntegral mockPort)) action --- Start a mock federator. Use proveded Servant handler for the mocking mocking function. +-- Start a mock federator. Use provided Servant handler for the mocking function. withTempServantMockFederator :: (Domain -> ServerT (FedApi 'Brig) Handler) -> (Domain -> ServerT (FedApi 'Galley) Handler) -> diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index 46f15eb1de9..e73b36ed049 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -46,6 +46,7 @@ library Gundeck.Push.Websocket Gundeck.React Gundeck.Redis + Gundeck.Redis.HedisExtensions Gundeck.Run Gundeck.ThreadBudget Gundeck.ThreadBudget.Internal diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index b9e4b68ea14..96cb36f211f 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -37,6 +37,7 @@ import qualified Database.Redis as Redis import qualified Gundeck.Aws as Aws import Gundeck.Options as Opt import qualified Gundeck.Redis as Redis +import qualified Gundeck.Redis.HedisExtensions as Redis import Gundeck.ThreadBudget import Imports import Network.HTTP.Client (responseTimeoutMicro) @@ -131,7 +132,7 @@ createRedisPool l endpoint identifier = do . Log.field "connInfo" (show redisConnInfo) let connectWithRetry = Redis.connectRobust l (capDelay 1000000 (exponentialBackoff 50000)) r <- case endpoint ^. rConnectionMode of - Master -> connectWithRetry $ Redis.connect redisConnInfo - Cluster -> connectWithRetry $ Redis.connectCluster redisConnInfo + Master -> connectWithRetry $ Redis.checkedConnect redisConnInfo + Cluster -> connectWithRetry $ Redis.checkedConnectCluster redisConnInfo Log.info l $ Log.msg (Log.val $ "Established connection to " <> identifier <> ".") pure r diff --git a/services/gundeck/src/Gundeck/Redis.hs b/services/gundeck/src/Gundeck/Redis.hs index 74b116cf374..d8dfa59d369 100644 --- a/services/gundeck/src/Gundeck/Redis.hs +++ b/services/gundeck/src/Gundeck/Redis.hs @@ -35,6 +35,7 @@ import Control.Lens import qualified Control.Monad.Catch as Catch import Control.Retry import Database.Redis +import Gundeck.Redis.HedisExtensions import Imports import qualified System.Logger as Log import System.Logger.Class (MonadLogger) @@ -66,40 +67,31 @@ connectRobust :: Logger -> -- | e. g., @exponentialBackoff 50000@ RetryPolicy -> - -- | action returning a fresh initial 'Connection', e. g., @(connect connInfo)@ or @(connectCluster connInfo)@ + -- | action returning a fresh initial 'Connection', e. g., @(checkedConnect connInfo)@ or @(checkedConnectCluster connInfo)@ IO Connection -> IO RobustConnection connectRobust l retryStrategy connectLowLevel = do robustConnection <- newEmptyMVar @IO @ReConnection - reconnectRedis robustConnection + retry $ reconnectRedis robustConnection pure robustConnection where + retry = + recovering -- retry connecting, e. g., with exponential back-off + retryStrategy + [ const $ Catch.Handler (\(e :: ClusterDownError) -> logEx (Log.err l) e "Redis cluster down" >> pure True), + const $ Catch.Handler (\(e :: ConnectError) -> logEx (Log.err l) e "Redis not in cluster mode" >> pure True), + const $ Catch.Handler (\(e :: ConnectTimeout) -> logEx (Log.err l) e "timeout when connecting to Redis" >> pure True), + const $ Catch.Handler (\(e :: ConnectionLostException) -> logEx (Log.err l) e "Redis connection lost during request" >> pure True), + const $ Catch.Handler (\(e :: PingException) -> logEx (Log.err l) e "pinging Redis failed" >> pure True), + const $ Catch.Handler (\(e :: IOException) -> logEx (Log.err l) e "network error when connecting to Redis" >> pure True) + ] + . const -- ignore RetryStatus reconnectRedis robustConnection = do + Log.info l $ Log.msg (Log.val "connecting to Redis") conn <- connectLowLevel + Log.info l $ Log.msg (Log.val "successfully connected to Redis") - Log.info l $ Log.msg (Log.val "lazy connection established, running ping...") - -- FUTUREWORK: With ping, we only verify that a single node is running as - -- opposed to verifying that all nodes of the cluster are up and running. - -- It remains unclear how cluster health can be verified in hedis. - void . runRedis conn $ do - res <- ping - case res of - Left r -> throwIO $ PingException r - Right _ -> pure () - Log.info l $ Log.msg (Log.val "ping went through") - - reconnectOnce <- - once $ -- avoid concurrent attempts to reconnect - recovering -- retry connecting, e. g., with exponential back-off - retryStrategy - [ const $ Catch.Handler (\(e :: ConnectError) -> logEx (Log.err l) e "Redis not in cluster mode" >> pure True), - const $ Catch.Handler (\(e :: ConnectTimeout) -> logEx (Log.err l) e "timeout when connecting to Redis" >> pure True), - const $ Catch.Handler (\(e :: ConnectionLostException) -> logEx (Log.err l) e "Redis connection lost during request" >> pure True), - const $ Catch.Handler (\(e :: PingException) -> logEx (Log.err l) e "pinging Redis failed" >> pure True), - const $ Catch.Handler (\(e :: IOException) -> logEx (Log.err l) e "network error when connecting to Redis" >> pure True) - ] - $ const $ - reconnectRedis robustConnection + reconnectOnce <- once . retry $ reconnectRedis robustConnection -- avoid concurrent attempts to reconnect let newReConnection = ReConnection {_rrConnection = conn, _rrReconnect = reconnectOnce} unlessM (tryPutMVar robustConnection newReConnection) $ void $ swapMVar robustConnection newReConnection diff --git a/services/gundeck/src/Gundeck/Redis/HedisExtensions.hs b/services/gundeck/src/Gundeck/Redis/HedisExtensions.hs new file mode 100644 index 00000000000..c102ba9b7d3 --- /dev/null +++ b/services/gundeck/src/Gundeck/Redis/HedisExtensions.hs @@ -0,0 +1,182 @@ +-- 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 Gundeck.Redis.HedisExtensions + ( ClusterInfoResponse (..), + ClusterInfoResponseState (..), + clusterInfo, + checkedConnectCluster, + ClusterDownError, + ) +where + +import qualified Data.ByteString.Char8 as Char8 +import Database.Redis +import Imports hiding (Down) +import UnliftIO + +-- https://redis.io/commands/cluster-info/ +data ClusterInfoResponse = ClusterInfoResponse + { clusterInfoResponseState :: ClusterInfoResponseState, + clusterInfoResponseSlotsAssigned :: Integer, + clusterInfoResponseSlotsOK :: Integer, + clusterInfoResponseSlotsPfail :: Integer, + clusterInfoResponseSlotsFail :: Integer, + clusterInfoResponseKnownNodes :: Integer, + clusterInfoResponseSize :: Integer, + clusterInfoResponseCurrentEpoch :: Integer, + clusterInfoResponseMyEpoch :: Integer, + clusterInfoResponseStatsMessagesSent :: Integer, + clusterInfoResponseStatsMessagesReceived :: Integer, + clusterInfoResponseTotalLinksBufferLimitExceeded :: Integer, + clusterInfoResponseStatsMessagesPingSent :: Maybe Integer, + clusterInfoResponseStatsMessagesPingReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesPongSent :: Maybe Integer, + clusterInfoResponseStatsMessagesPongReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesMeetSent :: Maybe Integer, + clusterInfoResponseStatsMessagesMeetReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesFailSent :: Maybe Integer, + clusterInfoResponseStatsMessagesFailReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesPublishSent :: Maybe Integer, + clusterInfoResponseStatsMessagesPublishReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesAuthReqSent :: Maybe Integer, + clusterInfoResponseStatsMessagesAuthReqReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesAuthAckSent :: Maybe Integer, + clusterInfoResponseStatsMessagesAuthAckReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesUpdateSent :: Maybe Integer, + clusterInfoResponseStatsMessagesUpdateReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesMfstartSent :: Maybe Integer, + clusterInfoResponseStatsMessagesMfstartReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesModuleSent :: Maybe Integer, + clusterInfoResponseStatsMessagesModuleReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesPublishshardSent :: Maybe Integer, + clusterInfoResponseStatsMessagesPublishshardReceived :: Maybe Integer + } + deriving (Show, Eq) + +data ClusterInfoResponseState + = OK + | Down + deriving (Show, Eq) + +defClusterInfoResponse :: ClusterInfoResponse +defClusterInfoResponse = + ClusterInfoResponse + { clusterInfoResponseState = Down, + clusterInfoResponseSlotsAssigned = 0, + clusterInfoResponseSlotsOK = 0, + clusterInfoResponseSlotsPfail = 0, + clusterInfoResponseSlotsFail = 0, + clusterInfoResponseKnownNodes = 0, + clusterInfoResponseSize = 0, + clusterInfoResponseCurrentEpoch = 0, + clusterInfoResponseMyEpoch = 0, + clusterInfoResponseStatsMessagesSent = 0, + clusterInfoResponseStatsMessagesReceived = 0, + clusterInfoResponseTotalLinksBufferLimitExceeded = 0, + clusterInfoResponseStatsMessagesPingSent = Nothing, + clusterInfoResponseStatsMessagesPingReceived = Nothing, + clusterInfoResponseStatsMessagesPongSent = Nothing, + clusterInfoResponseStatsMessagesPongReceived = Nothing, + clusterInfoResponseStatsMessagesMeetSent = Nothing, + clusterInfoResponseStatsMessagesMeetReceived = Nothing, + clusterInfoResponseStatsMessagesFailSent = Nothing, + clusterInfoResponseStatsMessagesFailReceived = Nothing, + clusterInfoResponseStatsMessagesPublishSent = Nothing, + clusterInfoResponseStatsMessagesPublishReceived = Nothing, + clusterInfoResponseStatsMessagesAuthReqSent = Nothing, + clusterInfoResponseStatsMessagesAuthReqReceived = Nothing, + clusterInfoResponseStatsMessagesAuthAckSent = Nothing, + clusterInfoResponseStatsMessagesAuthAckReceived = Nothing, + clusterInfoResponseStatsMessagesUpdateSent = Nothing, + clusterInfoResponseStatsMessagesUpdateReceived = Nothing, + clusterInfoResponseStatsMessagesMfstartSent = Nothing, + clusterInfoResponseStatsMessagesMfstartReceived = Nothing, + clusterInfoResponseStatsMessagesModuleSent = Nothing, + clusterInfoResponseStatsMessagesModuleReceived = Nothing, + clusterInfoResponseStatsMessagesPublishshardSent = Nothing, + clusterInfoResponseStatsMessagesPublishshardReceived = Nothing + } + +parseClusterInfoResponse :: [[ByteString]] -> ClusterInfoResponse -> Maybe ClusterInfoResponse +parseClusterInfoResponse fields resp = case fields of + [] -> pure resp + (["cluster_state", state] : fs) -> parseState state >>= \s -> parseClusterInfoResponse fs $ resp {clusterInfoResponseState = s} + (["cluster_slots_assigned", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsAssigned = v} + (["cluster_slots_ok", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsOK = v} + (["cluster_slots_pfail", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsPfail = v} + (["cluster_slots_fail", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsFail = v} + (["cluster_known_nodes", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseKnownNodes = v} + (["cluster_size", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSize = v} + (["cluster_current_epoch", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseCurrentEpoch = v} + (["cluster_my_epoch", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseMyEpoch = v} + (["cluster_stats_messages_sent", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesSent = v} + (["cluster_stats_messages_received", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesReceived = v} + (["total_cluster_links_buffer_limit_exceeded", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseTotalLinksBufferLimitExceeded = fromMaybe 0 $ parseInteger value} -- this value should be mandatory according to the spec, but isn't necessarily set in Redis 6 + (["cluster_stats_messages_ping_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPingSent = parseInteger value} + (["cluster_stats_messages_ping_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPingReceived = parseInteger value} + (["cluster_stats_messages_pong_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPongSent = parseInteger value} + (["cluster_stats_messages_pong_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPongReceived = parseInteger value} + (["cluster_stats_messages_meet_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMeetSent = parseInteger value} + (["cluster_stats_messages_meet_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMeetReceived = parseInteger value} + (["cluster_stats_messages_fail_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesFailSent = parseInteger value} + (["cluster_stats_messages_fail_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesFailReceived = parseInteger value} + (["cluster_stats_messages_publish_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishSent = parseInteger value} + (["cluster_stats_messages_publish_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishReceived = parseInteger value} + (["cluster_stats_messages_auth_req_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthReqSent = parseInteger value} + (["cluster_stats_messages_auth_req_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthReqReceived = parseInteger value} + (["cluster_stats_messages_auth_ack_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthAckSent = parseInteger value} + (["cluster_stats_messages_auth_ack_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthAckReceived = parseInteger value} + (["cluster_stats_messages_update_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesUpdateSent = parseInteger value} + (["cluster_stats_messages_update_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesUpdateReceived = parseInteger value} + (["cluster_stats_messages_mfstart_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMfstartSent = parseInteger value} + (["cluster_stats_messages_mfstart_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMfstartReceived = parseInteger value} + (["cluster_stats_messages_module_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesModuleSent = parseInteger value} + (["cluster_stats_messages_module_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesModuleReceived = parseInteger value} + (["cluster_stats_messages_publishshard_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishshardSent = parseInteger value} + (["cluster_stats_messages_publishshard_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishshardReceived = parseInteger value} + (_ : fs) -> parseClusterInfoResponse fs resp + where + parseState bs = case bs of + "ok" -> Just OK + "fail" -> Just Down + _ -> Nothing + parseInteger = fmap fst . Char8.readInteger + +instance RedisResult ClusterInfoResponse where + decode r@(Bulk (Just bulkData)) = + maybe (Left r) Right + . flip parseClusterInfoResponse defClusterInfoResponse + . map (Char8.split ':' . Char8.takeWhile (/= '\r')) + $ Char8.lines bulkData + decode r = Left r + +clusterInfo :: RedisCtx m f => m (f ClusterInfoResponse) +clusterInfo = sendRequest ["CLUSTER", "INFO"] + +checkedConnectCluster :: ConnectInfo -> IO Connection +checkedConnectCluster connInfo = do + conn <- connectCluster connInfo + res <- runRedis conn clusterInfo + case res of + Right r -> case clusterInfoResponseState r of + OK -> pure conn + _ -> throwIO $ ClusterDownError r + Left e -> throwIO $ ConnectSelectError e + +newtype ClusterDownError = ClusterDownError ClusterInfoResponse deriving (Eq, Show, Typeable) + +instance Exception ClusterDownError diff --git a/services/integration.yaml b/services/integration.yaml index f560af205ba..d8d0cba6913 100644 --- a/services/integration.yaml +++ b/services/integration.yaml @@ -87,6 +87,9 @@ backendTwo: cargohold: host: 127.0.0.1 port: 9084 + cannon: + host: 127.0.0.1 + port: 9086 redis2: host: 127.0.0.1 diff --git a/services/spar/package.yaml b/services/spar/package.yaml index 751fd00333f..9fd9e4c5a75 100644 --- a/services/spar/package.yaml +++ b/services/spar/package.yaml @@ -60,7 +60,7 @@ dependencies: - QuickCheck - raw-strings-qq - retry - - saml2-web-sso >= 0.18 + - saml2-web-sso >= 0.19 - servant - servant-multipart - servant-server diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 32badbaa384..900af12a7d8 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -166,7 +166,7 @@ library , polysemy-wire-zoo , raw-strings-qq , retry - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , servant , servant-multipart , servant-server @@ -281,7 +281,7 @@ executable spar , polysemy-wire-zoo , raw-strings-qq , retry - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , servant , servant-multipart , servant-server @@ -418,7 +418,7 @@ executable spar-integration , random , raw-strings-qq , retry - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , servant , servant-multipart , servant-server @@ -546,7 +546,7 @@ executable spar-migrate-data , polysemy-wire-zoo , raw-strings-qq , retry - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , servant , servant-multipart , servant-server @@ -678,7 +678,7 @@ executable spar-schema , polysemy-wire-zoo , raw-strings-qq , retry - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , servant , servant-multipart , servant-server @@ -809,7 +809,7 @@ test-suite spec , polysemy-wire-zoo , raw-strings-qq , retry - , saml2-web-sso >=0.18 + , saml2-web-sso >=0.19 , servant , servant-multipart , servant-server diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index b8f5a34b238..b8c255bf3d1 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -53,6 +53,7 @@ import qualified Data.ByteString as SBS import Data.ByteString.Builder (toLazyByteString) import Data.Id import Data.Proxy +import qualified Data.Set as Set import Data.String.Conversions import Data.Time import Galley.Types.Teams (HiddenPerm (CreateUpdateDeleteIdp, ReadIdp)) @@ -92,6 +93,7 @@ import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) +import qualified Spar.Sem.ScimUserTimesStore as ScimUserTimesStore import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore import System.Logger (Msg) @@ -205,7 +207,8 @@ apiINTERNAL :: DefaultSsoCode, IdPConfigStore, Error SparError, - SAMLUserStore + SAMLUserStore, + ScimUserTimesStore ] r => ServerT APIINTERNAL (Sem r) @@ -213,6 +216,7 @@ apiINTERNAL = internalStatus :<|> internalDeleteTeam :<|> internalPutSsoSettings + :<|> internalGetScimUserInfo appName :: ST appName = "spar" @@ -309,9 +313,9 @@ authresp :: Sem r Void authresp mbtid arbody = logErrors $ SAML2.authResp mbtid (SamlProtocolSettings.spIssuer mbtid) (SamlProtocolSettings.responseURI mbtid) go arbody where - go :: SAML.AuthnResponse -> SAML.AccessVerdict -> Sem r Void - go resp verdict = do - result :: SAML.ResponseVerdict <- verdictHandler mbtid resp verdict + go :: SAML.AuthnResponse -> IdP -> SAML.AccessVerdict -> Sem r Void + go resp verdict idp = do + result :: SAML.ResponseVerdict <- verdictHandler resp idp verdict throw @SparError $ SAML.CustomServant result logErrors :: Sem r Void -> Sem r Void @@ -766,3 +770,9 @@ internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} = IdPConfigStore.getConfig code *> DefaultSsoCode.store code $> NoContent + +internalGetScimUserInfo :: Members '[ScimUserTimesStore] r => UserSet -> Sem r ScimUserInfos +internalGetScimUserInfo (UserSet uids) = do + results <- ScimUserTimesStore.readMulti (Set.toList uids) + let scimUserInfos = results <&> (\(uid, t, _) -> ScimUserInfo uid (Just t)) + pure $ ScimUserInfos scimUserInfos diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index ce3e10ac042..22460e0697c 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -23,8 +23,7 @@ module Spar.App ( Env (..), throwSparSem, verdictHandler, - GetUserResult (..), - getUserIdByUref, + getUserByUrefUnsafe, getUserIdByScimExternalId, validateEmailIfExists, validateEmail, @@ -60,7 +59,6 @@ import SAML2.WebSSO explainDeniedReason, idpExtraInfo, idpId, - uidTenant, ) import qualified SAML2.WebSSO as SAML import Servant @@ -110,52 +108,27 @@ data Env = Env sparCtxRequestId :: RequestId } --- | Look up user locally in table @spar.user@ or @spar.scim_user@ (depending on the --- argument), then in brig, then return the 'UserId'. If either lookup fails, or user is not --- in a team, return 'Nothing'. +-- | Get a user by UserRef, no matter what the team. -- --- It makes sense to require that users are required to be team members: both IdPs and SCIM --- tokens are created in the context of teams, and the only way for users to be created is as --- team members. If a user is not a team member, it cannot have been created using SAML or --- SCIM. +-- Look up user locally in table @spar.user@ or @spar.scim_user@ (depending on the +-- argument), then in brig, then return the 'User'. If either lookup fails, or user is not +-- in a team, return 'Nothing'. -- -- If a user has been created via scim invite (ie., no IdP present), and has status --- 'PendingInvitation', its 'UserId' will be returned here, since for SCIM purposes it is an +-- 'PendingInvitation', it will be returned here, since for SCIM purposes it is an -- existing (if inactive) user. If 'getUser' is called during SAML authentication, this may -- cause an inactive user to log in, but that's ok: `PendingActivation` means that email and -- password handshake have not been completed; it's still ok for the user to gain access to -- the team with valid SAML credentials. -- --- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR. (in https://github.com/wireapp/wire-server/pull/1410, undo https://github.com/wireapp/wire-server/pull/1418) -getUserIdByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Sem r (GetUserResult UserId) -getUserIdByUref mbteam uref = userId <$$> getUserByUref mbteam uref - -getUserByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Sem r (GetUserResult User) -getUserByUref mbteam uref = do - muid <- SAMLUserStore.get uref - case muid of - Nothing -> pure GetUserNotFound - Just uid -> do - let withpending = Intra.WithPendingInvitations -- see haddocks above - Intra.getBrigUser withpending uid >>= \case - Nothing -> pure GetUserNotFound - Just user - | isNothing (userTeam user) -> pure GetUserNoTeam - | isJust mbteam && mbteam /= userTeam user -> pure GetUserWrongTeam - | otherwise -> pure $ GetUserFound user - -data GetUserResult usr - = GetUserFound usr - | GetUserNotFound - | GetUserNoTeam - | GetUserWrongTeam - deriving (Eq, Show) - -instance Functor GetUserResult where - fmap f (GetUserFound usr) = GetUserFound (f usr) - fmap _ GetUserNotFound = GetUserNotFound - fmap _ GetUserNoTeam = GetUserNoTeam - fmap _ GetUserWrongTeam = GetUserWrongTeam +-- FUTUREWORK: Remove and reinstate getUser, in AuthID refactoring PR. (in +-- https://github.com/wireapp/wire-server/pull/1410, undo +-- https://github.com/wireapp/wire-server/pull/1418) +-- +-- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQSERVICES-1655 +getUserByUrefUnsafe :: Members '[BrigAccess, SAMLUserStore] r => SAML.UserRef -> Sem r (Maybe User) +getUserByUrefUnsafe uref = do + maybe (pure Nothing) (Intra.getBrigUser Intra.WithPendingInvitations) =<< SAMLUserStore.get uref -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR getUserIdByScimExternalId :: Members '[BrigAccess, ScimExternalIdStore] r => TeamId -> Email -> Sem r (Maybe UserId) @@ -202,28 +175,9 @@ createSamlUserWithId teamid buid suid = do SAMLUserStore.insert suid buid -- | If the team has no scim token, call 'createSamlUser'. Otherwise, raise "invalid --- credentials". +-- credentials". (FUTUREWORK: Assumes that `UserRef` is still available globally. See +-- https://wearezeta.atlassian.net/browse/SQSERVICES-1655) autoprovisionSamlUser :: - Members - '[ Random, - GalleyAccess, - BrigAccess, - ScimTokenStore, - IdPConfigStore, - Error SparError, - SAMLUserStore - ] - r => - Maybe TeamId -> - SAML.UserRef -> - Sem r UserId -autoprovisionSamlUser mbteam suid = do - buid <- Id <$> Random.uuid - autoprovisionSamlUserWithId mbteam buid suid - pure buid - --- | Like 'autoprovisionSamlUser', but for an already existing 'UserId'. -autoprovisionSamlUserWithId :: forall r. Members '[ GalleyAccess, @@ -234,28 +188,25 @@ autoprovisionSamlUserWithId :: SAMLUserStore ] r => - Maybe TeamId -> + IdP -> UserId -> SAML.UserRef -> Sem r () -autoprovisionSamlUserWithId mbteam buid suid = do - idp <- case mbteam of - Just team -> IdPConfigStore.getIdPByIssuerV2 (suid ^. uidTenant) team - Nothing -> IdPConfigStore.getIdPByIssuerV1 (suid ^. uidTenant) - guardReplacedIdP idp - guardScimTokens idp +autoprovisionSamlUser idp buid suid = do + guardReplacedIdP + guardScimTokens createSamlUserWithId (idp ^. idpExtraInfo . wiTeam) buid suid validateEmailIfExists buid suid where -- Replaced IdPs are not allowed to create new wire accounts. - guardReplacedIdP :: IdP -> Sem r () - guardReplacedIdP idp = do + guardReplacedIdP :: Sem r () + guardReplacedIdP = do unless (isNothing $ idp ^. idpExtraInfo . wiReplacedBy) $ do throwSparSem $ SparCannotCreateUsersOnReplacedIdP (cs . SAML.idPIdToST $ idp ^. idpId) -- IdPs in teams with scim tokens are not allowed to auto-provision. - guardScimTokens :: IdP -> Sem r () - guardScimTokens idp = do + guardScimTokens :: Sem r () + guardScimTokens = do let teamid = idp ^. idpExtraInfo . wiTeam scimtoks <- ScimTokenStore.lookupByTeam teamid unless (null scimtoks) $ do @@ -301,11 +252,11 @@ verdictHandler :: SAMLUserStore ] r => - Maybe TeamId -> SAML.AuthnResponse -> SAML.AccessVerdict -> + IdP -> Sem r SAML.ResponseVerdict -verdictHandler mbteam aresp verdict = do +verdictHandler aresp verdict idp = do -- [3/4.1.4.2] -- [...] If the containing message is in response to an , then -- the InResponseTo attribute MUST match the request's ID. @@ -314,9 +265,9 @@ verdictHandler mbteam aresp verdict = do format :: Maybe VerdictFormat <- VerdictFormatStore.get reqid resp <- case format of Just VerdictFormatWeb -> - verdictHandlerResult mbteam verdict >>= verdictHandlerWeb + verdictHandlerResult verdict idp >>= verdictHandlerWeb Just (VerdictFormatMobile granted denied) -> - verdictHandlerResult mbteam verdict >>= verdictHandlerMobile granted denied + verdictHandlerResult verdict idp >>= verdictHandlerMobile granted denied Nothing -> -- (this shouldn't happen too often, see 'storeVerdictFormat') throwSparSem SparNoSuchRequest @@ -343,12 +294,12 @@ verdictHandlerResult :: SAMLUserStore ] r => - Maybe TeamId -> SAML.AccessVerdict -> + IdP -> Sem r VerdictHandlerResult -verdictHandlerResult mbteam verdict = do +verdictHandlerResult verdict idp = do Logger.log Logger.Debug $ "entering verdictHandlerResult" - result <- catchVerdictErrors $ verdictHandlerResultCore mbteam verdict + result <- catchVerdictErrors $ verdictHandlerResultCore idp verdict Logger.log Logger.Debug $ "leaving verdictHandlerResult" <> show result pure result @@ -372,8 +323,10 @@ catchVerdictErrors = (`catch` hndlr) -- | If a user attempts to login presenting a new IdP issuer, but there is no entry in -- @"spar.user"@ for her: lookup @"old_issuers"@ from @"spar.idp"@ for the new IdP, and --- traverse the old IdPs in search for the old entry. Return that old entry. -findUserIdWithOldIssuer :: +-- traverse the old issuers in search for the old entry. +-- +-- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQSERVICES-1655 +getUserByUrefViaOldIssuerUnsafe :: forall r. Members '[ BrigAccess, @@ -382,19 +335,17 @@ findUserIdWithOldIssuer :: Error SparError ] r => - Maybe TeamId -> + IdP -> SAML.UserRef -> - Sem r (GetUserResult (SAML.UserRef, UserId)) -findUserIdWithOldIssuer mbteam (SAML.UserRef issuer subject) = do - idp <- case mbteam of - Just team -> IdPConfigStore.getIdPByIssuerV2 issuer team - Nothing -> IdPConfigStore.getIdPByIssuerV1 issuer - let tryFind :: GetUserResult (SAML.UserRef, UserId) -> Issuer -> Sem r (GetUserResult (SAML.UserRef, UserId)) - tryFind found@(GetUserFound _) _ = pure found - tryFind _ oldIssuer = (uref,) <$$> getUserIdByUref mbteam uref + Sem r (Maybe (SAML.UserRef, User)) +getUserByUrefViaOldIssuerUnsafe idp (SAML.UserRef _ subject) = do + let tryFind :: Maybe (SAML.UserRef, User) -> Issuer -> Sem r (Maybe (SAML.UserRef, User)) + tryFind found@(Just _) _ = pure found + tryFind Nothing oldIssuer = (uref,) <$$> getUserByUrefUnsafe uref where uref = SAML.UserRef oldIssuer subject - foldM tryFind GetUserNotFound (idp ^. idpExtraInfo . wiOldIssuers) + + foldM tryFind Nothing (idp ^. idpExtraInfo . wiOldIssuers) -- | After a user has been found using 'findUserWithOldIssuer', update it everywhere so that -- the old IdP is not needed any more next time. @@ -417,38 +368,33 @@ verdictHandlerResultCore :: SAMLUserStore ] r => - Maybe TeamId -> + IdP -> SAML.AccessVerdict -> Sem r VerdictHandlerResult -verdictHandlerResultCore mbteam = \case +verdictHandlerResultCore idp = \case SAML.AccessDenied reasons -> do pure $ VerifyHandlerDenied reasons - SAML.AccessGranted userref -> do + SAML.AccessGranted uref -> do uid :: UserId <- do - viaSparCassandra <- getUserIdByUref mbteam userref - -- race conditions: if the user has been created on spar, but not on brig, 'getUser' - -- returns 'Nothing'. this is ok assuming 'createUser' (called below) is - -- idempotent. - viaSparCassandraOldIssuer <- - case viaSparCassandra of - GetUserFound _ -> pure GetUserNotFound - _ -> findUserIdWithOldIssuer mbteam userref - let err = - SparUserRefInNoOrMultipleTeams . cs $ - show (userref, viaSparCassandra, viaSparCassandraOldIssuer) - case (viaSparCassandra, viaSparCassandraOldIssuer) of - (GetUserNoTeam, _) -> throwSparSem err - (GetUserWrongTeam, _) -> throwSparSem err - (_, GetUserNoTeam) -> throwSparSem err - (_, GetUserWrongTeam) -> throwSparSem err - -- This is the first SSO authentication, so we auto-create a user. We know the user - -- has not been created via SCIM because then we would've ended up in the - -- "reauthentication" branch. - (GetUserNotFound, GetUserNotFound) -> autoprovisionSamlUser mbteam userref - -- If the user is only found under an old (previous) issuer, move it here. - (GetUserNotFound, GetUserFound (oldUserRef, uid)) -> moveUserToNewIssuer oldUserRef userref uid >> pure uid - -- SSO re-authentication (the most common case). - (GetUserFound uid, _) -> pure uid + let team = idp ^. idpExtraInfo . wiTeam + err = SparUserRefInNoOrMultipleTeams . cs . show $ uref + getUserByUrefUnsafe uref >>= \case + Just usr -> do + if userTeam usr == Just team + then pure (userId usr) + else throwSparSem err + Nothing -> do + getUserByUrefViaOldIssuerUnsafe idp uref >>= \case + Just (olduref, usr) -> do + let uid = userId usr + if userTeam usr == Just team + then moveUserToNewIssuer olduref uref uid >> pure uid + else throwSparSem err + Nothing -> do + buid <- Id <$> Random.uuid + autoprovisionSamlUser idp buid uref + pure buid + Logger.log Logger.Debug ("granting sso login for " <> show uid) cky <- BrigAccess.ssoLogin uid pure $ VerifyHandlerGranted cky uid diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 2401223ed7d..72dfe7365ba 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -62,7 +62,7 @@ import Network.URI (URI, parseURI) import Polysemy import Polysemy.Input import qualified SAML2.WebSSO as SAML -import Spar.App (GetUserResult (..), getUserIdByScimExternalId, getUserIdByUref, validateEmail, validateEmailIfExists) +import Spar.App (getUserByUrefUnsafe, getUserIdByScimExternalId, validateEmail, validateEmailIfExists) import qualified Spar.Intra.BrigApp as Brig import Spar.Scim.Auth () import Spar.Scim.Types (normalizeLikeStored) @@ -760,9 +760,7 @@ assertExternalIdUnused = [Nothing] "externalId is already taken" --- | --- Check that the UserRef is not taken any user other than the passed 'UserId' --- (it is also acceptable if it is not taken by anybody). +-- | `UserRef` must map to the given `UserId` or to `Nothing`. -- -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. @@ -780,13 +778,7 @@ assertExternalIdInAllowedValues allowedValues errmsg tid veid = do lift $ ST.runValidExternalIdBoth (\ma mb -> (&&) <$> ma <*> mb) - ( \uref -> - getUserIdByUref (Just tid) uref <&> \case - (Spar.App.GetUserFound uid) -> Just uid `elem` allowedValues - Spar.App.GetUserNotFound -> Nothing `elem` allowedValues - Spar.App.GetUserNoTeam -> False -- this is never allowed (and also hopefully impossible) - Spar.App.GetUserWrongTeam -> False -- this can happen, but it's violating all our assertions - ) + (\uref -> getUserByUrefUnsafe uref <&> (`elem` allowedValues) . fmap userId) (fmap (`elem` allowedValues) . getUserIdByScimExternalId tid) veid unless isGood $ diff --git a/services/spar/src/Spar/Sem/SAML2.hs b/services/spar/src/Spar/Sem/SAML2.hs index aa0411db819..2642e9e21b9 100644 --- a/services/spar/src/Spar/Sem/SAML2.hs +++ b/services/spar/src/Spar/Sem/SAML2.hs @@ -34,6 +34,7 @@ import Imports (Maybe) import Polysemy import SAML2.WebSSO hiding (meta, toggleCookie) import URI.ByteString (URI) +import Wire.API.User.IdentityProvider (IdP) data SAML2 m a where AuthReq :: @@ -45,7 +46,7 @@ data SAML2 m a where Maybe TeamId -> m Issuer -> m URI -> - (AuthnResponse -> AccessVerdict -> m resp) -> + (AuthnResponse -> IdP -> AccessVerdict -> m resp) -> AuthnResponseBody -> SAML2 m resp Meta :: ST -> m Issuer -> m URI -> SAML2 m SPMetadata diff --git a/services/spar/src/Spar/Sem/SAML2/Library.hs b/services/spar/src/Spar/Sem/SAML2/Library.hs index d4bda54c332..bb434989e39 100644 --- a/services/spar/src/Spar/Sem/SAML2/Library.hs +++ b/services/spar/src/Spar/Sem/SAML2/Library.hs @@ -131,10 +131,10 @@ saml2ToSaml2WebSso = AuthResp mitlt ma mb mc ab -> do get_a <- runT ma get_b <- runT mb - get_c <- bindT $ uncurry mc + get_c <- bindT $ \(a, (b, c)) -> mc a b c ins <- getInspectorT s <- getInitialStateT - x <- raise $ unSPImpl $ SAML.authresp mitlt (inspectOrBomb ins get_a) (inspectOrBomb ins get_b) (\x y -> inspectOrBomb ins $ get_c $ (x, y) <$ s) ab + x <- raise $ unSPImpl $ SAML.authresp mitlt (inspectOrBomb ins get_a) (inspectOrBomb ins get_b) (\x y z -> inspectOrBomb ins $ get_c $ (x, (y, z)) <$ s) ab pure $ x <$ s Meta t ma mb -> do get_a <- runT ma diff --git a/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs index c33baf07f2d..00eac038b59 100644 --- a/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs +++ b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs @@ -29,10 +29,6 @@ import qualified SAML2.WebSSO as SAML import Spar.Sem.SamlProtocolSettings import Wire.API.Routes.Public.Spar --- TODO(sandy): Why is this instance not provided by SAML? Very rude! -instance SAML.HasConfig ((->) SAML.Config) where - getConfig = id - sparRouteToServant :: SAML.Config -> Sem (SamlProtocolSettings ': r) a -> Sem r a sparRouteToServant cfg = interpret $ \case SpIssuer mitlt -> pure $ sparSPIssuer mitlt cfg diff --git a/services/spar/src/Spar/Sem/ScimUserTimesStore.hs b/services/spar/src/Spar/Sem/ScimUserTimesStore.hs index 8b9bdc445c3..0efb17527bd 100644 --- a/services/spar/src/Spar/Sem/ScimUserTimesStore.hs +++ b/services/spar/src/Spar/Sem/ScimUserTimesStore.hs @@ -21,6 +21,7 @@ module Spar.Sem.ScimUserTimesStore ( ScimUserTimesStore (..), write, read, + readMulti, delete, ) where @@ -35,6 +36,7 @@ import Web.Scim.Schema.Meta (WithMeta) data ScimUserTimesStore m a where Write :: WithMeta (WithId UserId t) -> ScimUserTimesStore m () Read :: UserId -> ScimUserTimesStore m (Maybe (UTCTimeMillis, UTCTimeMillis)) + ReadMulti :: [UserId] -> ScimUserTimesStore m [(UserId, UTCTimeMillis, UTCTimeMillis)] Delete :: UserId -> ScimUserTimesStore m () makeSem ''ScimUserTimesStore diff --git a/services/spar/src/Spar/Sem/ScimUserTimesStore/Cassandra.hs b/services/spar/src/Spar/Sem/ScimUserTimesStore/Cassandra.hs index 689b47b9b63..52dfbe11f26 100644 --- a/services/spar/src/Spar/Sem/ScimUserTimesStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/ScimUserTimesStore/Cassandra.hs @@ -35,6 +35,7 @@ scimUserTimesStoreToCassandra = embed @m . \case Write wm -> writeScimUserTimes wm Read uid -> readScimUserTimes uid + ReadMulti uids -> readScimUserTimesMulti uids Delete uid -> deleteScimUserTimes uid ---------------------------------------------------------------------- @@ -64,6 +65,13 @@ readScimUserTimes uid = do sel :: PrepQuery R (Identity UserId) (UTCTimeMillis, UTCTimeMillis) sel = "SELECT created_at, last_updated_at FROM scim_user_times WHERE uid = ?" +readScimUserTimesMulti :: (HasCallStack, MonadClient m) => [UserId] -> m [(UserId, UTCTimeMillis, UTCTimeMillis)] +readScimUserTimesMulti uid = do + retry x1 . query sel $ params LocalQuorum (Identity uid) + where + sel :: PrepQuery R (Identity [UserId]) (UserId, UTCTimeMillis, UTCTimeMillis) + sel = "SELECT uid, created_at, last_updated_at FROM scim_user_times WHERE uid IN ?" + -- | Delete a SCIM user's access times by id. -- You'll also want to ensure they are deleted in Brig and in the SAML Users table. deleteScimUserTimes :: diff --git a/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs b/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs index 85a2e5ab0e6..fa5f027d8a4 100644 --- a/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs +++ b/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs @@ -39,4 +39,5 @@ scimUserTimesStoreToMem = (runState mempty .) $ reinterpret $ \case Write (WithMeta meta (WithId uid _)) -> modify $ M.insert uid (toUTCTimeMillis $ created meta, toUTCTimeMillis $ lastModified meta) Read uid -> gets $ M.lookup uid + ReadMulti uids -> gets $ map (\(u, (a, b)) -> (u, a, b)) . filter ((`elem` uids) . fst) . M.toList Delete uid -> modify $ M.delete uid diff --git a/services/spar/test-integration/Test/Spar/AppSpec.hs b/services/spar/test-integration/Test/Spar/AppSpec.hs index 9b06e7dc125..806c93fe2de 100644 --- a/services/spar/test-integration/Test/Spar/AppSpec.hs +++ b/services/spar/test-integration/Test/Spar/AppSpec.hs @@ -167,11 +167,7 @@ requestAccessVerdict idp isGranted mkAuthnReq = do then SAML.AccessGranted uref else SAML.AccessDenied [DeniedNoBearerConfSubj, DeniedNoAuthnStatement] outcome :: ResponseVerdict <- do - mbteam <- - asks (^. teWireIdPAPIVersion) <&> \case - User.WireIdPAPIV1 -> Nothing - User.WireIdPAPIV2 -> Just (idp ^. SAML.idpExtraInfo . User.wiTeam) - runSpar $ Spar.verdictHandler mbteam authnresp verdict + runSpar $ Spar.verdictHandler authnresp verdict idp let loc :: URI.URI loc = maybe (error "no location") (either error id . SAML.parseURI' . cs) diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index b1ed37e0c9a..2c7b2d5c06a 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -121,12 +121,12 @@ testCreateTokenWithVerificationCode = do let reqMissingCode = CreateScimToken "testCreateToken" (Just defPassword) Nothing createTokenFailsWith owner reqMissingCode 403 "code-authentication-required" - requestVerificationCode (env ^. teBrig) email Public.CreateScimToken + void $ requestVerificationCode (env ^. teBrig) email Public.CreateScimToken let wrongCode = Code.Value $ unsafeRange (fromRight undefined (validate "123456")) let reqWrongCode = CreateScimToken "testCreateToken" (Just defPassword) (Just wrongCode) createTokenFailsWith owner reqWrongCode 403 "code-authentication-failed" - requestVerificationCode (env ^. teBrig) email Public.CreateScimToken + void $ retryNUntil 6 ((==) 200 . statusCode) $ requestVerificationCode (env ^. teBrig) email Public.CreateScimToken code <- getVerificationCode (env ^. teBrig) owner Public.CreateScimToken let reqWithCode = CreateScimToken "testCreateToken" (Just defPassword) (Just code) CreateScimTokenResponse token _ <- createToken owner reqWithCode @@ -135,6 +135,11 @@ testCreateTokenWithVerificationCode = do let fltr = filterBy "externalId" "67c196a0-cd0e-11ea-93c7-ef550ee48502" listUsers_ (Just token) (Just fltr) (env ^. teSpar) !!! const 200 === statusCode + where + requestVerificationCode :: BrigReq -> Email -> Public.VerificationAction -> TestSpar ResponseLBS + requestVerificationCode brig email action = do + call $ + post (brig . paths ["verification-code", "send"] . contentJson . json (Public.SendVerificationCode action email)) -- @END @@ -149,12 +154,6 @@ setSndFactorPasswordChallengeStatus galley tid status = do put (galley . paths ["i", "teams", toByteString' tid, "features", featureNameBS @Public.SndFactorPasswordChallengeConfig] . contentJson . body js) !!! const 200 === statusCode -requestVerificationCode :: BrigReq -> Email -> Public.VerificationAction -> TestSpar () -requestVerificationCode brig email action = do - call $ - post (brig . paths ["verification-code", "send"] . contentJson . json (Public.SendVerificationCode action email)) - !!! const 200 === statusCode - getVerificationCode :: BrigReq -> UserId -> Public.VerificationAction -> TestSpar Code.Value getVerificationCode brig uid action = do resp <- diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index f8af13e45a4..e8ec711264d 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -67,6 +67,7 @@ import qualified Spar.Sem.BrigAccess as BrigAccess import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import qualified Spar.Sem.ScimUserTimesStore as ScimUserTimesStore +import Test.Tasty.HUnit ((@?=)) import qualified Text.XML.DSig as SAML import Util import Util.Invitation @@ -2066,6 +2067,8 @@ testDeletedUsersFreeExternalIdNoIdp = do (runSpar $ ScimExternalIdStore.lookup tid email) (== Nothing) +-- | CSV download of team members is mainly tested here: 'API.Teams.testListTeamMembersCsv'. +-- the additional CSV download test here is specifically focused on SCIM users specSCIMManaged :: SpecWith TestEnv specSCIMManaged = do describe "SCIM-managed users" $ do @@ -2112,6 +2115,27 @@ specSCIMManaged = do updateProfileBrig brig uid uupd !!! do (fmap Wai.label . responseJsonEither @Wai.Error) === const (Right "managed-by-scim") statusCode === const 403 + it "created_on should be filled in CSV export" $ do + g <- view teGalley + user <- randomScimUser + (tok, (owner, tid, _idp)) <- registerIdPAndScimToken + scimStoredUser <- createUser tok user + let _userid = scimUserId scimStoredUser + putStrLn $ "userid: " <> show _userid + resp <- + call $ + get (g . accept "text/csv" . paths ["teams", toByteString' tid, "members/csv"] . zUser owner) m Text randomAlphaNum = liftIO $ do diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 51ee1ac0699..51c5098d022 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -131,6 +131,7 @@ module Util.Core checkChangeRoleOfTeamMember, eventually, getIdPByIssuer, + retryNUntil, ) where @@ -314,6 +315,13 @@ aFewTimes action good = do (\_ -> pure . not . good) (\_ -> action `runReaderT` env) +retryNUntil :: (MonadIO m) => Int -> (a -> Bool) -> m a -> m a +retryNUntil n good m = + retrying + (constantDelay 1000000 <> limitRetries n) + (const (pure . not . good)) + (const m) + aFewTimesAssert :: HasCallStack => TestSpar a -> (a -> Bool) -> TestSpar () aFewTimesAssert action good = do result <- aFewTimes action good diff --git a/stack.yaml b/stack.yaml index 5ebff33258d..70c85848043 100644 --- a/stack.yaml +++ b/stack.yaml @@ -87,7 +87,7 @@ extra-deps: # a version > 1.0.0 of wai-middleware-prometheus is available # (required: https://github.com/fimad/prometheus-haskell/pull/45) - git: https://github.com/wireapp/saml2-web-sso - commit: 4227e38be5c0810012dc472fc6931f6087fbce68 # master (Dec 07, 2021) + commit: 74371cd775cb98d6cf85f6e182244a3c4fd48702 # master (Jul 07, 2022) - git: https://github.com/kim/hs-collectd commit: 885da222be2375f78c7be36127620ed772b677c9 diff --git a/stack.yaml.lock b/stack.yaml.lock index 985811c0008..c464f671662 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -26,15 +26,15 @@ packages: commit: 2e3282e5fb27ba8d989c271a0a989823fad7ec43 - completed: name: saml2-web-sso - version: '0.18' + version: '0.19' git: https://github.com/wireapp/saml2-web-sso pantry-tree: size: 4887 - sha256: 9d6d175cc7bbdb57558f25557e4d0d698c4aecc250f6ca03296a3d94671bf657 - commit: 4227e38be5c0810012dc472fc6931f6087fbce68 + sha256: bb082762abbd48527788941f8555706eb5af6c03761834f255dada3e962d5f5e + commit: 74371cd775cb98d6cf85f6e182244a3c4fd48702 original: git: https://github.com/wireapp/saml2-web-sso - commit: 4227e38be5c0810012dc472fc6931f6087fbce68 + commit: 74371cd775cb98d6cf85f6e182244a3c4fd48702 - completed: name: collectd version: 0.0.0.2